packages feed

curry-frontend 0.2.12 → 2.0.0

raw patch · 170 files changed

Files

+ CHANGELOG.md view
@@ -0,0 +1,327 @@+Change log for curry-frontend+=============================++Version 2.0.0+=============++  * Implemented the "MonadFail-Proposal" for curry+    (see <https://wiki.haskell.org/MonadFail_Proposal>)+  * Data class (see <https://arxiv.org/abs/1908.10607>)+  * Fixed bug with partially imported Typeclasses+  * Fixed bug with parsing of empty blocks+  * Fixed bug with re-export of record labels++Version 1.0.4+=============++  * Fixed bug in type checking of instances+  * Fixed bugs in deriving of `Bounded` instances.++Version 1.0.3+=============++  * Fixed bug in type checking of typeclasses++Version 1.0.2+=============++  * Added 'short-ast' and 'ast' as new compilation targets+  * Fixed bug with wrong type of free variables in the intermediate language.+  * Fixed bug with generated default implementations of nullary class methods.+  * Fixed bug in desugaring of record patterns.+  * Fixed bug that external data declarations weren't considered when+    AbstractCurry was generated++Version 1.0.1+=============++  * Fixed bug with wrong order of super classes in selector functions+    generated by the dictionary transformation.+  * Changed desugaring of numeric literals. It now generates calls to the+    functions `Prelude.fromInt` and `Prelude.fromFloat`.+  * Fixed bug with wrong original names of imported record labels+  * Fixed bug when compiling type constructor classes with super classes+  * Adjusted warning message for potentially unreachable pattern matches++Version 1.0.0+=============++  * Added support for typeclasses as known from Haskell++Version 0.4.2+=============++  * Improved readability of environment information in dumps+    (option dump-simple)+  * Added option to dump all bindings instead of just local ones+    (dump-all-bindings)+  * Introduced annotated FlatCurry as a new output format+    (annotated-flat)++Version 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)+  * Added syntax extension `ExistentialQuantification` that allows the use+    of existentially quantified types in data and newtype constructors+  * Fixed bug that type declarations weren't syntax checked++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 `<Module>_curry.html`, i.e., no sub-folders reflecting+    the the module name hierarchy are generated. In addition, if the option+    `--html-dir` is not given, the current directory is used as the output+    directory.++  * Removed record type extensions++  * Enabled declaration of (mutually) recursive record types++  * 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 <Module> (<source file>, <target file>)++  * 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 <cmd>` set the preprocessor command to `<cmd>`+    * `-optF <arg>` 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).+
LICENSE view
@@ -1,4 +1,5 @@ Copyright (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
− LIESMICH 
@@ -1,172 +0,0 @@-===============================================================================-==-==  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 <Distribution>.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 <Distribution>.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 <filename>--Hierdurch werden die Dateien mit den entsprechenden Endungen ".fcy" und-".fint" generiert. Der Dateiname <filename> kann hierbei mit oder ohne -Endung ".curry" bzw. ".lcurry" angegeben werden.--Die analogen Übersetzungen in die FlatXML-Darstellung bewirkt folgendes-Kommando:--	cymake --xml <file name>--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 <filename>--Hierdurch wird die entsprechende Datei (mit der Endung ".acy") generiert.-Der Dateiname <filename> kann hierbei mit oder ohne Endung ".curry" bzw.-".lcurry" angegeben werden.--Ungetypte, bzw. typsignierte AbstractCurry-Programme werden mit folgendem-Kommando generiert:--	cymake --uacy <filename>--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=<pakcs path>/pacs/lib:<pakcs path>/pacs/lib/meta:...--  wobei <pakcs path> 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 = <expr>-               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.--
+ README.md view
@@ -0,0 +1,65 @@+# Curry Frontend++The frontend lexes, parses, type-checks and transforms Curry source files into a variety of intermediate formats, including++* **FlatCurry** for program analyzers and backends+* **AbstractCurry** for program manipulation tools+* **HTML** for documentation++It is used by the two major Curry compilers, [PAKCS](https://git.ps.informatik.uni-kiel.de/curry/pakcs) and+[KiCS2](https://git.ps.informatik.uni-kiel.de/curry/kics2).++## Requirements++* Make sure that a recent version of Haskell Stack is installed on your computer++## Building++* To build the project, run `make`.+* To test the project, run `make runtests`.++The built executable will be located at `bin/curry-frontend`.++## Usage++For a detailed overview of the available options, you can use the following command:++`curry-frontend --help`++### Available Formats++```+--flat  : Generate a FlatCurry (.fcy) and FlatInterface (.fint) file+--xml   : Generate a FlatXML (_flat.xml) file+--acy   : Generate a (type-inferred) AbstractCurry (.acy) file+--uacy  : Generate an untyped AbstractCurry (.uacy) file+```++The generation of an untyped AbstractCurry program is performed without+type checking (i.e. programs with type checks will compile). All functions+will either have the type signature specified in the source or, if not+available, the dummy type `prelude.untyped`.++FlatCurry files will always be generated for the imported modules,+since the interfaces are required for static-semantic analysis and type+inference (only for typed AbstractCurry).++## Remarks++- To use the PAKCS libraries (especially for the `Prelude`), the environment+  variable `PAKCS_LIB` has to point to the correct paths, e.g. using+  +  `export PAKCS_LIB=[pakcs path]/pacs/lib:[pakcs path]/pacs/lib/meta:...`++  where `[pakcs path]` is the directory containing the PAKCS distribution.++- In contrast to PAKCS, the frontend allow use of anonymous variables+  (denoted by an underscore `_`) in type declarations, e.g.+  +  ```curry+  data T _ = c+  ```++## Known Issues++[See GitLab](https://git.ps.informatik.uni-kiel.de/curry/curry-frontend/-/issues)
+ app/cymake.hs view
@@ -0,0 +1,57 @@+{- |+    Module      :  $Header$+    Description :  Main module+    Copyright   :  (c) 2005        Martin Engelke+                       2011 - 2016 Björn Peemöller+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    Command line tool for generating Curry representations (e.g. FlatCurry,+    AbstractCurry) for a Curry source file including all imported modules.+-}+module Main (main) where++import Curry.Base.Monad (runCYIO)++import Base.Messages+import Files.CymakePath (cymakeGreeting, cymakeVersion)++import CurryBuilder     (buildCurry)+import CompilerOpts     (Options (..), CymakeMode (..), getCompilerOpts, usage)++-- |The command line tool cymake+main :: IO ()+main = getCompilerOpts >>= cymake++-- |Invoke the curry builder w.r.t the command line arguments+cymake :: (String, Options, [String], [String]) -> IO ()+cymake (prog, opts, files, errs) = case optMode opts of+  ModeHelp             -> printUsage prog+  ModeVersion          -> printVersion+  ModeNumericVersion   -> printNumericVersion+  ModeMake | not (null errs) -> badUsage prog errs+           | null files      -> badUsage prog ["No input files"]+           | otherwise       -> runCYIO (mapM_ (buildCurry opts) files) >>=+                                either abortWithMessages continueWithMessages+  where continueWithMessages = warnOrAbort (optWarnOpts opts) . snd++-- |Print the usage information of the command line tool+printUsage :: String -> IO ()+printUsage prog = putStrLn $ usage prog++-- |Print the program version+printVersion :: IO ()+printVersion = putStrLn cymakeGreeting++-- |Print the numeric program version+printNumericVersion :: IO ()+printNumericVersion = putStrLn cymakeVersion++-- |Print errors and abort execution on bad parameters+badUsage :: String -> [String] -> IO ()+badUsage prog errs = do+  putErrsLn $ map (\ err -> prog ++ ": " ++ err) errs+  abortWith ["Try '" ++ prog ++ " --help' for more information"]
curry-frontend.cabal view
@@ -1,71 +1,207 @@-Name:          curry-frontend-Version:       0.2.12-Cabal-Version: >= 1.6-Synopsis:      Compile the functional logic language Curry to several+name:          curry-frontend+version:       2.0.0+cabal-version: 2.0+synopsis:      Compile the functional logic language Curry to several                intermediate formats-Description:   The Curry Frontend consists of the executable program "cymake".+description:   The Curry front end consists of the executable program+               "curry-frontend".                It is used by various backends to compile Curry programs to-               an internal representation.+               an intermediate representation.                The code is a stripped-down version of an early version of                the Muenster Curry Compiler-               (<http://danae.uni-muenster.de/~lux/curry/>)-Category:      Language-License:       OtherLicense-License-File:  LICENSE-Author:        Wolfgang Lux, Martin Engelke, Bernd Brassel, Holger Siegel-Maintainer:    Björn Peemöller-Bug-Reports:   http://www-ps.informatik.uni-kiel.de/redmine/projects/curry-frontend-Homepage:      http://www.curry-language.org-Build-Type:    Simple-Stability:     experimental+               (<http://danae.uni-muenster.de/curry/>)+               which has been extended to produce different intermediate+               representations.+               For further information, please check+               <http://curry-language.org>+category:      Language+license:       BSD3+license-file:  LICENSE+author:        Wolfgang Lux, Martin Engelke, Bernd Brassel, Holger Siegel,+               Bjoern Peemoeller, Finn Teegen+maintainer:    fte@informatik.uni-kiel.de+homepage:      http://curry-language.org+build-type:    Simple+stability:     experimental -Extra-Source-Files: LIESMICH-Data-Files:         src/currydoc.css+extra-source-files: README.md CHANGELOG.md -Flag split-syb-  Description: Has the syb functionality been split into the package syb?-  Default:     True+data-dir:   data+data-files: currysource.css -Executable cymake-  hs-source-dirs: src-  Main-is:        cymake.hs-  if flag(split-syb)-    Build-Depends: base == 4.*, syb-  else-    Build-Depends: base == 3.*-  Build-Depends:-    curry-base >= 0.2.9 && < 0.3-    , mtl, old-time, containers, pretty-  ghc-options: -Wall-  Other-Modules:    Curry.Syntax.Lexer, Curry.Syntax.LexComb-                    Curry.Syntax.Parser, Curry.Syntax.LLParseComb-                    Curry.Syntax.ShowModule, Curry.Syntax.Pretty-                    Curry.Syntax, Curry.Syntax.Type-                    Curry.Syntax.Unlit,-                    Curry.Syntax.Utils,-                    Curry.Syntax.Frontend,-                    CurryBuilder, IL.Type-                    CurryCompilerOpts, Modules, Subst, Arity-                    CurryDeps, Eval, IL.Pretty, NestEnv, SyntaxCheck, Base-                    Exports, IL.Scope, SyntaxColoring, CurryEnv-                    IL.CurryToIL, OldScopeEnv, CurryHtml-                    IL.XML, PatchPrelude, TopEnv, CaseCompletion-                    Imports,-                    TypeCheck,-                    InterfaceCheck,-                    Types, PrecCheck-                    TypeSubst, GenAbstractCurry-                    Typing-                    GenFlatCurry, KindCheck, Qual-                    SCC, Utils-                    Lift, ScopeEnv, WarnCheck-                    Desugar,-                    Simplify+source-repository head+  type:     git+  location: https://git.ps.informatik.uni-kiel.de/curry/curry-frontend.git -Library-  hs-source-dirs:  src-  Build-Depends:   filepath-  Exposed-Modules:-    Curry.Files.CymakePath-  Other-Modules:-    Paths_curry_frontend+library+  hs-source-dirs:   src+  default-language: Haskell2010+  other-extensions: CPP, TemplateHaskell+  ghc-options:      -Wall+  build-depends:+      base             >= 4.11  && < 4.15+    , template-haskell >= 2.10  && < 2.16+    , extra            >= 1.4.6 && < 1.8+    , transformers     >= 0.5   && < 0.6+    , mtl              >= 2.2   && < 2.3+    , directory        >= 1.2   && < 1.4+    , filepath         >= 1.4   && < 1.5+    , file-embed       >= 0.0   && < 0.1+    , containers       >= 0.6   && < 0.7+    , set-extra        >= 1.4   && < 1.5+    , bytestring       >= 0.10  && < 0.11+    , process          >= 1.6   && < 1.7+    , network-uri      >= 2.6   && < 2.7+    , pretty           >= 1.1   && < 1.2+    , binary           >= 0.8   && < 0.9+    , time             >= 1.9   && < 2.0+    , parsec           >= 3.1   && < 3.2+  exposed-modules:+      Base.AnnotExpr+    , Base.CurryKinds+    , Base.CurryTypes+    , Base.Expr+    , Base.KindSubst+    , Base.Kinds+    , Base.Messages+    , Base.NestEnv+    , Base.PrettyKinds+    , Base.PrettyTypes+    , Base.SCC+    , Base.Subst+    , Base.TopEnv+    , Base.TypeExpansion+    , Base.TypeSubst+    , Base.Types+    , Base.Typing+    , Base.Utils+    , Checks+    , Checks.DeriveCheck+    , Checks.ExportCheck+    , Checks.ExtensionCheck+    , Checks.ImportSyntaxCheck+    , Checks.InstanceCheck+    , Checks.InterfaceCheck+    , Checks.InterfaceSyntaxCheck+    , Checks.KindCheck+    , Checks.PrecCheck+    , Checks.SyntaxCheck+    , Checks.TypeCheck+    , Checks.TypeSyntaxCheck+    , Checks.WarnCheck+    , Curry.AbstractCurry+    , Curry.AbstractCurry.Files+    , Curry.AbstractCurry.Type+    , Curry.Base.Ident+    , Curry.Base.LexComb+    , Curry.Base.LLParseComb+    , Curry.Base.Message+    , Curry.Base.Monad+    , Curry.Base.Position+    , Curry.Base.Pretty+    , Curry.Base.Span+    , Curry.Base.SpanInfo+    , Curry.CondCompile.Parser+    , Curry.CondCompile.Transform+    , Curry.CondCompile.Type+    , Curry.Files.Filenames+    , Curry.Files.PathUtils+    , Curry.Files.Unlit+    , Curry.FlatCurry+    , Curry.FlatCurry.Files+    , Curry.FlatCurry.Goodies+    , Curry.FlatCurry.InterfaceEquivalence+    , Curry.FlatCurry.Pretty+    , Curry.FlatCurry.Type+    , Curry.FlatCurry.Typeable+    , Curry.FlatCurry.Annotated.Goodies+    , Curry.FlatCurry.Annotated.Type+    , Curry.FlatCurry.Typed.Goodies+    , Curry.FlatCurry.Typed.Type+    , Curry.Syntax+    , Curry.Syntax.Extension+    , Curry.Syntax.InterfaceEquivalence+    , Curry.Syntax.Lexer+    , Curry.Syntax.Parser+    , Curry.Syntax.Pretty+    , Curry.Syntax.ShowModule+    , Curry.Syntax.Type+    , Curry.Syntax.Utils+    , CompilerEnv+    , CompilerOpts+    , CondCompile+    , CurryBuilder+    , CurryDeps+    , Env.Class+    , Env.Instance+    , Env.Interface+    , Env.ModuleAlias+    , Env.OpPrec+    , Env.Type+    , Env.TypeConstructor+    , Env.Value+    , Exports+    , Files.CymakePath+    , Generators+    , Generators.GenAbstractCurry+    , Generators.GenFlatCurry+    , Generators.GenTypedFlatCurry+    , Generators.GenAnnotatedFlatCurry+    , Html.CurryHtml+    , Html.SyntaxColoring+    , IL+    , IL.Pretty+    , IL.ShowModule+    , IL.Type+    , IL.Typing+    , Imports+    , Interfaces+    , Modules+    , TokenStream+    , Transformations+    , Transformations.CaseCompletion+    , Transformations.CurryToIL+    , Transformations.Derive+    , Transformations.Desugar+    , Transformations.Dictionary+    , Transformations.Lift+    , Transformations.Newtypes+    , Transformations.Qual+    , Transformations.Simplify+    , Paths_curry_frontend+  autogen-modules:+      Paths_curry_frontend++executable curry-frontend+  hs-source-dirs:   app+  main-is:          cymake.hs+  default-language: Haskell2010+  ghc-options:      -Wall+  build-depends:+      base >= 4.11+    , curry-frontend++test-suite test-frontend+  type:             detailed-0.9+  hs-source-dirs:   test+  test-module:      TestFrontend+  default-language: Haskell2010+  other-extensions: CPP, TemplateHaskell+  ghc-options:      -Wall+  build-depends:+      base >= 4.11+    , Cabal >= 1.20+    , template-haskell >= 2.10+    , extra >= 1.4.6+    , transformers+    , mtl+    , directory >= 1.2.0.1+    , filepath+    , file-embed+    , containers+    , set-extra+    , bytestring >= 0.10+    , process+    , network-uri >= 2.6+    , pretty+    , curry-frontend
+ data/currysource.css view
@@ -0,0 +1,95 @@+:root {+  --link-bg-color: lightyellow;+  --line-number-color: grey;+  --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;+  color-scheme: light dark;+}++body {+  font-family: monospace;+  text-size-adjust: none;+  -moz-text-size-adjust: none;+  -ms-text-size-adjust: none;+  -webkit-text-size-adjust: none;+}++table {+  border-collapse: collapse;+}++/* Hyperlinks */+a:link,+a:visited,+a:active {+  background: var(--link-bg-color);+  text-decoration: none;+}++/* Line numbers */+.line-numbers {+  border-right: 1px solid var(--line-number-color);+  color: var(--line-number-color);+  min-width: 5ch;+  padding-right: 1em;+  text-align: right;+}++/* Source code */+.source-code {+  padding-left: 1em;+}++/* Code highlighting */+.pragma  { color: var(--pragma-color)  }+.comment { color: var(--comment-color) }+.keyword { color: var(--keyword-color) }+.symbol  { color: var(--symbol-color)  }+.type    { color: var(--type-color)    }+.cons    { color: var(--cons-color)    }+.label   { color: var(--label-color)   }+.func    { color: var(--func-color)    }+.ident   { color: var(--ident-color)   }+.module  { color: var(--module-color)  }+.number  { color: var(--number-color)  }+.string  { color: var(--string-color)  }+.char    { color: var(--char-color)    }++@supports not (color-scheme: light dark) {+  @media (prefers-color-scheme: dark) {+    html {+      background: hsl(0, 0%, 12%);+      color: white;+    }+  }+}++@media (prefers-color-scheme: dark) {+  :root {+    --link-bg-color: hsl(0, 0%, 17%);+    --pragma-color: hsl(0, 0%, 60%);+    --comment-color: hsl(0, 0%, 60%);+    --keyword-color: hsl(300, 66%, 70%);+    --symbol-color: hsl(0, 66%, 70%);+    --type-color: hsl(60, 66%, 70%);+    --cons-color: hsl(330, 66%, 70%);+    --label-color: hsl(240, 66%, 70%);+    --func-color: hsl(200, 66%, 70%);+    --ident-color: hsl(0, 0%, 85%);+    --module-color: hsl(20, 66%, 70%);+    --number-color: hsl(180, 66%, 70%);+    --string-color: hsl(120, 66%, 70%);+    --char-color: hsl(120, 66%, 70%);+  }+}
− src/Arity.hs 
@@ -1,133 +0,0 @@---------------------------------------------------------------------------------------------------------------------------------------------------------------------- Arity - provides functions for expanding the arity environment 'ArityEnv'---         (see Module "Base")------ September 2005,--- Martin Engelke (men@informatik.uni-kiel.de)----module Arity (bindArities) where--import Curry.Base.Ident-import Curry.Syntax--import Base(ArityEnv, bindArity)-------------------------------------------------------------------------------------- Expands the arity envorinment with (global / local) function arities and--- constructor arities-bindArities :: ArityEnv -> Module -> ArityEnv-bindArities aEnv (Module mid _ decls)-   = foldl (visitDecl mid) aEnv decls------------------------------------------------------------------------------------visitDecl :: ModuleIdent -> ArityEnv -> Decl -> ArityEnv-visitDecl mid aEnv (DataDecl _ _ _ cdecls)-   = foldl (visitConstrDecl mid) aEnv cdecls-visitDecl mid aEnv (ExternalDecl _ _ _ id texpr)-   = bindArity mid id (typeArity texpr) aEnv-visitDecl mid aEnv (FunctionDecl _ id equs)-   = let (Equation _ lhs rhs) = head equs-     in  visitRhs mid (visitLhs mid id aEnv lhs) rhs-visitDecl _ aEnv _ = aEnv---visitConstrDecl :: ModuleIdent -> ArityEnv -> ConstrDecl -> ArityEnv-visitConstrDecl mid aEnv (ConstrDecl _ _ id texprs)-   = bindArity mid id (length texprs) aEnv-visitConstrDecl mid aEnv (ConOpDecl _ _ _ id _)-   = bindArity mid id 2 aEnv---visitLhs :: ModuleIdent -> Ident -> ArityEnv -> Lhs -> ArityEnv-visitLhs mid _ aEnv (FunLhs id params)-   = bindArity mid id (length params) aEnv-visitLhs mid id aEnv (OpLhs _ _ _)-   = bindArity mid id 2 aEnv-visitLhs _ _ aEnv _ = aEnv---visitRhs :: ModuleIdent -> ArityEnv -> Rhs -> ArityEnv-visitRhs mid aEnv (SimpleRhs _ expr decls)-   = foldl (visitDecl mid) (visitExpression mid aEnv expr) decls-visitRhs mid aEnv (GuardedRhs cexprs decls)-   = foldl (visitDecl mid) (foldl (visitCondExpr mid) aEnv cexprs) decls---visitCondExpr :: ModuleIdent -> ArityEnv -> CondExpr -> ArityEnv-visitCondExpr mid aEnv (CondExpr _ cond expr)-   = visitExpression mid (visitExpression mid aEnv expr) cond---visitExpression :: ModuleIdent -> ArityEnv -> Expression -> ArityEnv-visitExpression mid aEnv (Paren expr)-   = visitExpression mid aEnv expr-visitExpression mid aEnv (Typed expr _)-   = visitExpression mid aEnv expr-visitExpression mid aEnv (Tuple _ exprs)-   = foldl (visitExpression mid) aEnv exprs-visitExpression mid aEnv (List _ exprs)-   = foldl (visitExpression mid) aEnv exprs-visitExpression mid aEnv (ListCompr _ expr stmts)-   = foldl (visitStatement mid) (visitExpression mid aEnv expr) stmts-visitExpression mid aEnv (EnumFrom expr)-   = visitExpression mid aEnv expr-visitExpression mid aEnv (EnumFromThen expr1 expr2)-   = foldl (visitExpression mid) aEnv [expr1,expr2]-visitExpression mid aEnv (EnumFromTo expr1 expr2)-   = foldl (visitExpression mid) aEnv [expr1,expr2]-visitExpression mid aEnv (EnumFromThenTo expr1 expr2 expr3)-   = foldl (visitExpression mid) aEnv [expr1,expr2,expr3]-visitExpression mid aEnv (UnaryMinus _ expr)-   = visitExpression mid aEnv expr-visitExpression mid aEnv (Apply expr1 expr2)-   = foldl (visitExpression mid) aEnv [expr1,expr2]-visitExpression mid aEnv (InfixApply expr1 _ expr2)-   = foldl (visitExpression mid) aEnv [expr1,expr2]-visitExpression mid aEnv (LeftSection expr _)-   = visitExpression mid aEnv expr-visitExpression mid aEnv (RightSection _ expr)-   = visitExpression mid aEnv expr-visitExpression mid aEnv (Lambda _ _ expr)-   = visitExpression mid aEnv expr-visitExpression mid aEnv (Let decls expr)-   = foldl (visitDecl mid) (visitExpression mid aEnv expr) decls-visitExpression mid aEnv (Do stmts expr)-   = foldl (visitStatement mid) (visitExpression mid aEnv expr) stmts-visitExpression mid aEnv (IfThenElse _ expr1 expr2 expr3)-   = foldl (visitExpression mid) aEnv [expr1,expr2,expr3]-visitExpression mid aEnv (Case _ expr alts)-   = visitExpression mid (foldl (visitAlt mid) aEnv alts) expr-visitExpression _ aEnv _ = aEnv---visitStatement :: ModuleIdent -> ArityEnv -> Statement -> ArityEnv-visitStatement mid aEnv (StmtExpr _ expr)-   = visitExpression mid aEnv expr-visitStatement mid aEnv (StmtDecl decls)-   = foldl (visitDecl mid) aEnv decls-visitStatement mid aEnv (StmtBind _ _ expr)-   = visitExpression mid aEnv expr---visitAlt :: ModuleIdent -> ArityEnv -> Alt -> ArityEnv-visitAlt mid aEnv (Alt _ _ rhs)-   = visitRhs mid aEnv rhs--------------------------------------------------------------------------------------- Computes the function arity using a type expression-typeArity :: TypeExpr -> Int-typeArity (ArrowType _ t2) = 1 + typeArity t2-typeArity _                = 0------------------------------------------------------------------------------------------------------------------------------------------------------------------
− src/Base.lhs 
@@ -1,557 +0,0 @@-% $Id: Base.lhs,v 1.77 2004/02/15 22:10:25 wlux Exp $-%-% Copyright (c) 1999-2004, Wolfgang Lux-% See LICENSE for the full license.-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-%-\nwfilename{Base.lhs}-\section{Common Definitions for the Compiler}--The module Base implements the anti-pattern 'God-object'.-By providing definitions for various unrelated phases of the-compiler, it irrevocably turns the module structure into spaghetti.-(hsi, 2009)--\begin{verbatim}--> module Base where--> import Data.List-> import Control.Monad-> import Data.Maybe-> import qualified Data.Map as Map--> import Curry.Base.Ident -> import Curry.Base.Position-> import Types-> import qualified Curry.Syntax as CS-> import Curry.Syntax.Utils-> import TopEnv-> import Utils----\end{verbatim}-\paragraph{Types}-The functions \texttt{toType}, \texttt{toTypes}, and \texttt{fromType}-convert Curry type expressions into types and vice versa. The-functions \texttt{qualifyType} and \texttt{unqualifyType} add and-remove module qualifiers in a type, respectively.--When Curry type expression are converted with \texttt{toType} or-\texttt{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.-\begin{verbatim}--> 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 ++ tvs') [0..])) ty->   where tvs' = [tv | tv <- nub (fv ty), tv `notElem` tvs]--> toTypes :: [Ident] -> [CS.TypeExpr] -> [Type]-> toTypes tvs tys = map (toType' (Map.fromList (zip (tvs ++ tvs') [0..]))) tys->   where tvs' = [tv | tv <- nub (concatMap fv tys), tv `notElem` tvs]--> toType' :: Map.Map Ident Int -> CS.TypeExpr -> Type-> toType' tvs (CS.ConstructorType tc tys) =->   TypeConstructor tc (map (toType' tvs) tys)-> toType' tvs (CS.VariableType tv) =->   maybe (internalError ("toType " ++ show tv)) TypeVariable (Map.lookup tv tvs)-> 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.RecordType fs rty) =->   TypeRecord (concatMap (\ (ls,ty) -> map (\l -> (l, toType' tvs ty)) ls) fs)->              (maybe Nothing ->	              (\ty -> case toType' tvs ty of->	                        TypeVariable tv -> Just tv ->	                        _ -> internalError ("toType " ++ show ty))->	              rty)--> fromQualType :: ModuleIdent -> Type -> CS.TypeExpr-> fromQualType m = fromType . unqualifyType m--> fromType :: Type -> CS.TypeExpr-> fromType (TypeConstructor tc tys)->   | isTupleId c = CS.TupleType tys'->   | c == listId && length tys == 1 = CS.ListType (head tys')->   | c == unitId && null tys = CS.TupleType []->   | otherwise = CS.ConstructorType tc tys'->   where c = unqualify tc->         tys' = map fromType tys-> fromType (TypeVariable tv) =->   CS.VariableType (if tv >= 0 then nameSupply !! 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))-> fromType (TypeRecord fs rty) = ->   CS.RecordType (map (\ (l,ty) -> ([l], fromType ty)) fs)->              (maybe Nothing (Just . fromType . TypeVariable) rty)----\end{verbatim}-\paragraph{Interfaces}-The compiler maintains a global environment holding all (directly or-indirectly) imported interfaces.--The function \texttt{bindFlatInterface} transforms FlatInterface-information (type \texttt{FlatCurry.Prog} to MCC interface declarations-(type \texttt{CurrySyntax.IDecl}. This is necessary to process-FlatInterfaces instead of ".icurry" files when using MCC as frontend-for PAKCS.-\begin{verbatim}--> type ModuleEnv = Map.Map ModuleIdent [CS.IDecl]--> lookupModule :: ModuleIdent -> ModuleEnv -> Maybe [CS.IDecl]-> lookupModule = Map.lookup---\end{verbatim}-\paragraph{Type constructors}-For all defined types the compiler must maintain kind information. At-present, Curry does not support type classes. Therefore its type-language is first order and the only information that must be recorded-is the arity of each type. For algebraic data types and renaming types-the compiler also records all data constructors belonging to that-type, for alias types the type expression to be expanded is saved. In-order to manage the import and export of types, the names of the-original definitions are also recorded. On import two types are-considered equal if their original names match.--The information for a data constructor comprises the number of-existentially quantified type variables and the list of the argument-types. Note that renaming type constructors have only one type-argument.--Importing and exporting algebraic data types and renaming types is-complicated by the fact that the constructors of the type may be-(partially) hidden in the interface. This facilitates the definition-of abstract data types. An abstract type is always represented as a-data type without constructors in the interface regardless of whether-it is defined as a data type or as a renaming type. When only some-constructors of a data type are hidden, those constructors are-replaced by underscores in the interface. Furthermore, if the-right-most constructors of a data type are hidden, they are not-exported at all in order to make the interface more stable against-changes which are private to the module.-\begin{verbatim}--> data TypeInfo = DataType QualIdent Int [Maybe (Data [Type])]->               | RenamingType QualIdent Int (Data Type)->               | AliasType QualIdent Int Type->               deriving Show--> data Data a = Data Ident Int a deriving Show--> instance Entity TypeInfo where->   origName (DataType tc _ _) = tc->   origName (RenamingType tc _ _) = tc->   origName (AliasType tc _ _) = tc->   merge (DataType tc n cs) (DataType tc' _ cs')->     | tc == tc' = Just (DataType tc n (mergeData cs cs'))->     where mergeData ds [] = ds->           mergeData [] ds = ds->           mergeData (d:ds) (d':ds') = d `mplus` d' : mergeData ds ds'->   merge (DataType tc n _) (RenamingType tc' _ nc)->     | tc == tc' = Just (RenamingType tc n nc)->   merge (RenamingType tc n nc) (DataType tc' _ _)->     | tc == tc' = Just (RenamingType tc n nc)->   merge (RenamingType tc n nc) (RenamingType tc' _ _)->     | tc == tc' = Just (RenamingType tc n nc)->   merge (AliasType tc n ty) (AliasType tc' _ _)->     | tc == tc' = Just (AliasType tc n ty)->   merge _ _ = Nothing--> tcArity :: TypeInfo -> Int-> tcArity (DataType _ n _) = n-> tcArity (RenamingType _ n _) = n-> tcArity (AliasType _ n _) = n--\end{verbatim}-Types can only be defined on the top-level; no nested environments are-needed for them. Tuple types must be handled as a special case because-there is an infinite number of potential tuple types making it-impossible to insert them into the environment in advance.-\begin{verbatim}--> type TCEnv = TopEnv TypeInfo--> bindTypeInfo :: (QualIdent -> Int -> a -> TypeInfo) -> ModuleIdent->              -> Ident -> [Ident] -> a -> TCEnv -> TCEnv-> bindTypeInfo f m tc tvs x ->   = bindTopEnv "Base.bindTypeInfo" tc t ->     . qualBindTopEnv "Base.bindTypeInfo" tc' t->   where tc' = qualifyWith m tc->         t = f tc' (length tvs) x--> lookupTC :: Ident -> TCEnv -> [TypeInfo]-> lookupTC tc tcEnv = lookupTopEnv tc tcEnv ++! lookupTupleTC tc--> qualLookupTC :: QualIdent -> TCEnv -> [TypeInfo]-> qualLookupTC tc tcEnv =->   qualLookupTopEnv tc tcEnv ++! lookupTupleTC (unqualify tc)--> lookupTupleTC :: Ident -> [TypeInfo]-> lookupTupleTC tc->   | isTupleId tc = [tupleTCs !! (tupleArity tc - 2)]->   | otherwise = []--> tupleTCs :: [TypeInfo]-> tupleTCs = map typeInfo tupleData->   where typeInfo (Data c _ tys) =->           DataType (qualifyWith preludeMIdent c) (length tys)->                    [Just (Data c 0 tys)]--> tupleData :: [Data [Type]]-> tupleData = [Data (tupleId n) 0 (take n tvs) | n <- [2..]]->   where tvs = map typeVar [0..]--\end{verbatim}-\paragraph{Function and constructor types}-In order to test the type correctness of a module, the compiler needs-to determine the type of every data constructor, function,-variable, record and label in the module. -For the purpose of type checking there is no-need for distinguishing between variables and functions. For all objects-their original names and their types are saved. Functions also-contain arity information. Labels currently contain the name of their-defining record. On import two values-are considered equal if their original names match.-\begin{verbatim}--> data ValueInfo = DataConstructor QualIdent ExistTypeScheme->                | NewtypeConstructor QualIdent ExistTypeScheme->                | Value QualIdent TypeScheme->	         | Label QualIdent QualIdent TypeScheme->	           -- Label <label> <record name> <type>->                deriving Show--> instance Entity ValueInfo where->   origName (DataConstructor origName _) = origName->   origName (NewtypeConstructor origName _) = origName->   origName (Value origName _) = origName->   origName (Label origName _ _) = origName->   ->   merge (Label l r ty) (Label l' r' ty')->     | l == l' && r == r' = Just (Label l r ty)->     | otherwise = Nothing->   merge x y->     | origName x == origName y = Just x->     | otherwise = Nothing---\end{verbatim}-Even though value declarations may be nested, the compiler uses only-flat environments for saving type information. This is possible-because all identifiers are renamed by the compiler. Here we need-special cases for handling tuple constructors.--\em{Note:} the function \texttt{qualLookupValue} has been extended to-allow the usage of the qualified list constructor \texttt{(Prelude.:)}.-\begin{verbatim}--> type ValueEnv = TopEnv ValueInfo--> bindGlobalInfo :: (QualIdent -> a -> ValueInfo) -> ModuleIdent -> Ident -> a->                -> ValueEnv -> ValueEnv-> bindGlobalInfo f m c ty ->   = bindTopEnv "Base.bindGlobalInfo" c v ->     . qualBindTopEnv "Base.bindGlobalInfo" c' v->   where c' = qualifyWith m c->         v = f c' ty--> bindFun :: ModuleIdent -> Ident -> TypeScheme -> ValueEnv -> ValueEnv-> bindFun m f ty tyEnv->   | uniqueId f == 0 ->     = bindTopEnv "Base.bindFun" f v (qualBindTopEnv "Base.bindFun" f' v tyEnv)->   | otherwise = bindTopEnv "Base.bindFun" f v tyEnv->   where f' = qualifyWith m f->         v = Value f' ty--> rebindFun :: ModuleIdent -> Ident -> TypeScheme -> ValueEnv -> ValueEnv-> rebindFun m f ty->   | uniqueId f == 0 = rebindTopEnv f v . qualRebindTopEnv f' v->   | otherwise = rebindTopEnv f v->   where f' = qualifyWith m f->         v = Value f' ty--> bindLabel :: Ident -> QualIdent -> TypeScheme -> ValueEnv -> ValueEnv-> bindLabel l r ty tyEnv = bindTopEnv "Base.bindLabel" l v tyEnv->   where v  = Label (qualify l) r ty--> lookupValue :: Ident -> ValueEnv -> [ValueInfo]-> lookupValue x tyEnv = lookupTopEnv x tyEnv ++! lookupTuple x--> qualLookupValue :: QualIdent -> ValueEnv -> [ValueInfo]-> qualLookupValue x tyEnv =->   qualLookupTopEnv x tyEnv ->   ++! qualLookupCons x tyEnv->   ++! lookupTuple (unqualify x)--> qualLookupCons :: QualIdent -> ValueEnv -> [ValueInfo]-> qualLookupCons x tyEnv->    | maybe False ((==) preludeMIdent) mmid && id == consId->       = qualLookupTopEnv (qualify id) tyEnv->    | otherwise = []->  where (mmid, id) = (qualidMod x, qualidId x)--> lookupTuple :: Ident -> [ValueInfo]-> lookupTuple c->   | isTupleId c = [tupleDCs !! (tupleArity c - 2)]->   | otherwise = []--> tupleDCs :: [ValueInfo]-> tupleDCs = map dataInfo tupleTCs->   where dataInfo (DataType tc tvs [Just (Data c _ tys)]) =->           DataConstructor (qualUnqualify preludeMIdent tc)->                           (ForAllExist (length tys) 0->                                        (foldr TypeArrow (tupleType tys) tys))--\end{verbatim}-\paragraph{Arity}-In order to generate correct FlatCurry application it is necessary-to define the number of arguments as the arity value (instead of-using the arity computed from the type). For this reason the compiler-needs a table containing the information for all known functions-and constructors. -\begin{verbatim}--> type ArityEnv = TopEnv ArityInfo--> data ArityInfo = ArityInfo QualIdent Int deriving Show--> instance Entity ArityInfo where->   origName (ArityInfo origName _) = origName--> bindArity :: ModuleIdent -> Ident -> Int -> ArityEnv -> ArityEnv-> bindArity mid id arity aEnv->    | uniqueId id == 0 ->      = bindTopEnv "Base.bindArity" id arityInfo ->                   (qualBindTopEnv "Base.bindArity" qid arityInfo aEnv)->    | otherwise        ->      = bindTopEnv "Base.bindArity" id arityInfo aEnv->  where->  qid = qualifyWith mid id->  arityInfo = ArityInfo qid arity--> lookupArity :: Ident -> ArityEnv -> [ArityInfo]-> lookupArity id aEnv = lookupTopEnv id aEnv ++! lookupTupleArity id--> qualLookupArity :: QualIdent -> ArityEnv -> [ArityInfo]-> qualLookupArity qid aEnv = qualLookupTopEnv qid aEnv->		             ++! qualLookupConsArity qid aEnv->			     ++! lookupTupleArity (unqualify qid)--> qualLookupConsArity :: QualIdent -> ArityEnv -> [ArityInfo]-> qualLookupConsArity qid aEnv->    | maybe False ((==) preludeMIdent) mmid && id == consId->      = qualLookupTopEnv (qualify id) aEnv->    | otherwise->      = []->  where (mmid, id) = (qualidMod qid, qualidId qid)--> lookupTupleArity :: Ident -> [ArityInfo]-> lookupTupleArity id ->    | isTupleId id ->      = [ArityInfo (qualifyWith preludeMIdent id) (tupleArity id)]->    | otherwise->      = []--\end{verbatim}-\paragraph{Module alias}-\begin{verbatim}--> type ImportEnv = Map.Map ModuleIdent ModuleIdent--> bindAlias :: CS.Decl -> ImportEnv -> ImportEnv-> bindAlias (CS.ImportDecl _ mid _ mmid _)->    = Map.insert mid (fromMaybe mid mmid)--> lookupAlias :: ModuleIdent -> ImportEnv -> Maybe ModuleIdent-> lookupAlias = Map.lookup--> sureLookupAlias :: ModuleIdent -> ImportEnv -> ModuleIdent-> sureLookupAlias m = fromMaybe m . lookupAlias m---\end{verbatim}-\paragraph{Operator precedences}-In order to parse infix expressions correctly, the compiler must know-the precedence and fixity of each operator. Operator precedences are-associated with entities and will be checked after renaming was-applied. Nevertheless, we need to save precedences for ambiguous names-in order to handle them correctly while computing the exported-interface of a module.--If no fixity is assigned to an operator, it will be given the default-precedence 9 and assumed to be a left-associative operator.--\em{Note:} this modified version uses Haskell type \texttt{Integer}-for representing the precedence. This change had to be done due to the-introduction of unlimited integer constants in the parser / lexer.-\begin{verbatim}--> data OpPrec = OpPrec CS.Infix Integer deriving Eq--> instance Show OpPrec where->   showsPrec _ (OpPrec fix p) = showString (assoc fix) . shows p->     where assoc CS.InfixL = "left "->           assoc CS.InfixR = "right "->           assoc CS.Infix  = "non-assoc "--> defaultP :: OpPrec-> defaultP = OpPrec CS.InfixL 9--\end{verbatim}-The lookup functions for the environment which maintains the operator-precedences are simpler than for the type and value environments-because they do not need to handle tuple constructors.-\begin{verbatim}--> data PrecInfo = PrecInfo QualIdent OpPrec deriving (Eq,Show)--> instance Entity PrecInfo where->   origName (PrecInfo op _) = op--> type PEnv = TopEnv PrecInfo--> bindP :: ModuleIdent -> Ident -> OpPrec -> PEnv -> PEnv-> bindP m op p->   | uniqueId op == 0 ->     = bindTopEnv "Base.bindP" op info . qualBindTopEnv "Base.bindP" op' info->   | otherwise = bindTopEnv "Base.bindP" op info->   where op' = qualifyWith m op->         info = PrecInfo op' p--> lookupP :: Ident -> PEnv -> [PrecInfo]-> lookupP = lookupTopEnv--> qualLookupP :: QualIdent -> PEnv -> [PrecInfo]-> qualLookupP = qualLookupTopEnv--\end{verbatim}-\paragraph{Evaluation modes}-The compiler has to collect the evaluation annotations for a program-in an environment. As these annotations affect only local declarations,-a flat environment mapping unqualified names onto annotations is-sufficient.-\begin{verbatim}--> type EvalEnv = Map.Map Ident CS.EvalAnnotation---\end{verbatim}-\paragraph{Predefined types}-The list and unit data types must be predefined because their-definitions-\begin{verbatim}-data () = ()-data [] a = [] | a : [a]-\end{verbatim}-are not allowed by Curry's syntax. The corresponding types-are available in the environments \texttt{initTCEnv} and-\texttt{initDCEnv}. In addition, the precedence of the (infix) list-constructor is available in the environment \texttt{initPEnv}.--Note that only the unqualified names are predefined. This is correct,-because neither \texttt{Prelude.()} nor \texttt{Prelude.[]} are valid-identifiers.-\begin{verbatim}--> initPEnv :: PEnv-> initPEnv =->   predefTopEnv qConsId (PrecInfo qConsId (OpPrec CS.InfixR 5)) emptyTopEnv--> initTCEnv :: TCEnv-> initTCEnv = foldr (uncurry predefTC) emptyTopEnv predefTypes->   where predefTC (TypeConstructor tc tys) =->           predefTopEnv (qualify (unqualify tc)) .->             DataType tc (length tys) . map Just--> initDCEnv :: ValueEnv-> initDCEnv =->   foldr (uncurry predefDC) emptyTopEnv->         [(c,constrType (polyType ty) n' tys)->         | (ty,cs) <- predefTypes, Data c n' tys <- cs]->   where predefDC c ty = predefTopEnv c' (DataConstructor c' ty)->           where c' = qualify c->         constrType (ForAll n ty) n' = ForAllExist n n' . foldr TypeArrow ty--> initAEnv :: ArityEnv-> initAEnv->    = foldr bindPredefArity emptyTopEnv (concatMap snd predefTypes)->  where->  bindPredefArity (Data id _ ts)->     = bindArity preludeMIdent id (length ts)--> initIEnv :: ImportEnv-> initIEnv = Map.empty--> predefTypes :: [(Type,[Data [Type]])]-> predefTypes =->   let a = typeVar 0 in [->     (unitType,   [Data unitId 0 []]),->     (listType a, [Data nilId 0 [],Data consId 0 [a,listType a]])->   ]---\end{verbatim}--\paragraph{Miscellany}-Error handling-\begin{verbatim}--> errorAt :: Position -> String -> a-> errorAt p msg = error ("\n" ++ show p ++ ": " ++ msg)--> errorAt' :: (Position,String) -> a-> errorAt' = uncurry errorAt--> internalError :: String -> a-> internalError what = error ("internal error: " ++ what)--\end{verbatim}-Name supply for the generation of (type) variable names.-\begin{verbatim}--> nameSupply :: [Ident]-> nameSupply = map mkIdent [c:showNum i | i <- [0..], c <- ['a'..'z']]->   where showNum 0 = ""->         showNum n = show n--\end{verbatim}-\ToDo{The \texttt{nameSupply} should respect the current case mode, -i.e., use upper case for variables in Prolog mode.}--\end{verbatim}-The function \texttt{findDouble} checks whether a list of entities is-linear, i.e., if every entity in the list occurs only once. If it is-non-linear, the first offending object is returned.-\begin{verbatim}--> findDouble :: Eq a => [a] -> Maybe a-> findDouble (x:xs)->   | x `elem` xs = Just x->   | otherwise = findDouble xs-> findDouble [] = Nothing--\end{verbatim}---
+ src/Base/AnnotExpr.hs view
@@ -0,0 +1,124 @@+{- |+    Module      :  $Header$+    Description :  Extraction of free qualified annotated variables+    Copyright   :  (c) 2017        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    TODO+-}+module Base.AnnotExpr (QualAnnotExpr (..)) where++import qualified Data.Set  as Set (fromList, notMember)++import Curry.Base.Ident+import Curry.Base.SpanInfo+import Curry.Syntax++import Base.Expr+import Base.Types+import Base.Typing++class QualAnnotExpr e where+  -- |Free qualified annotated variables in an 'Expr'+  qafv :: ModuleIdent -> e Type -> [(Type, Ident)]++-- The 'Decl' instance of 'QualAnnotExpr' 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.++instance QualAnnotExpr Decl where+  qafv m (FunctionDecl    _ _ _ eqs) = concatMap (qafv m) eqs+  qafv m (PatternDecl       _ _ rhs) = qafv m rhs+  qafv m (ClassDecl    _ _ _ _ _ ds) = concatMap (qafv m) ds+  qafv m (InstanceDecl _ _ _ _ _ ds) = concatMap (qafv m) ds+  qafv _ _                           = []++instance QualAnnotExpr Equation where+  qafv m (Equation _ lhs rhs) = filterBv lhs $ qafv m lhs ++ qafv m rhs++instance QualAnnotExpr Lhs where+  qafv m = concatMap (qafv m) . snd . flatLhs++instance QualAnnotExpr Rhs where+  qafv m (SimpleRhs _ _ e ds) = filterBv ds $ qafv m e ++ concatMap (qafv m) ds+  qafv m (GuardedRhs _ _ es ds) =+    filterBv ds $ concatMap (qafv m) es ++ concatMap (qafv m) ds++instance QualAnnotExpr CondExpr where+  qafv m (CondExpr _ g e) = qafv m g ++ qafv m e++instance QualAnnotExpr Expression where+  qafv _ (Literal             _ _ _) = []+  qafv m (Variable           _ ty v) =+    maybe [] (return . (\v' -> (ty, v'))) $ localIdent m v+  qafv _ (Constructor         _ _ _) = []+  qafv m (Paren                 _ e) = qafv m e+  qafv m (Typed               _ e _) = qafv m e+  qafv m (Record           _ _ _ fs) = concatMap (qafvField m) fs+  qafv m (RecordUpdate       _ e fs) = qafv m e ++ concatMap (qafvField m) fs+  qafv m (Tuple                _ es) = concatMap (qafv m) es+  qafv m (List               _ _ es) = concatMap (qafv m) es+  qafv m (ListCompr          _ e qs) = foldr (qafvStmt m) (qafv m e) qs+  qafv m (EnumFrom              _ e) = qafv m e+  qafv m (EnumFromThen      _ e1 e2) = qafv m e1 ++ qafv m e2+  qafv m (EnumFromTo        _ e1 e2) = qafv m e1 ++ qafv m e2+  qafv m (EnumFromThenTo _ e1 e2 e3) = qafv m e1 ++ qafv m e2 ++ qafv m e3+  qafv m (UnaryMinus            _ e) = qafv m e+  qafv m (Apply             _ e1 e2) = qafv m e1 ++ qafv m e2+  qafv m (InfixApply     _ e1 op e2) = qafv m op ++ qafv m e1 ++ qafv m e2+  qafv m (LeftSection        _ e op) = qafv m op ++ qafv m e+  qafv m (RightSection       _ op e) = qafv m op ++ qafv m e+  qafv m (Lambda             _ ts e) = filterBv ts $ qafv m e+  qafv m (Let              _ _ ds e) =+    filterBv ds $ concatMap (qafv m) ds ++ qafv m e+  qafv m (Do              _ _ sts e) = foldr (qafvStmt m) (qafv m e) sts+  qafv m (IfThenElse     _ e1 e2 e3) = qafv m e1 ++ qafv m e2 ++ qafv m e3+  qafv m (Case         _ _ _ e alts) = qafv m e ++ concatMap (qafv m) alts++qafvField :: QualAnnotExpr e => ModuleIdent -> Field (e Type) -> [(Type, Ident)]+qafvField m (Field _ _ t) = qafv m t++qafvStmt :: ModuleIdent -> Statement Type -> [(Type, Ident)] -> [(Type, Ident)]+qafvStmt m st fvs = qafv m st ++ filterBv st fvs++instance QualAnnotExpr Statement where+  qafv m (StmtExpr   _  e) = qafv m e+  qafv m (StmtDecl _ _ ds) = filterBv ds $ concatMap (qafv m) ds+  qafv m (StmtBind _ _  e) = qafv m e++instance QualAnnotExpr Alt where+  qafv m (Alt _ t rhs) = filterBv t $ qafv m rhs++instance QualAnnotExpr InfixOp where+  qafv m (InfixOp    ty op) = qafv m $ Variable NoSpanInfo ty op+  qafv _ (InfixConstr _ _ ) = []++instance QualAnnotExpr Pattern where+  qafv _ (LiteralPattern           _ _ _) = []+  qafv _ (NegativePattern          _ _ _) = []+  qafv _ (VariablePattern          _ _ _) = []+  qafv m (ConstructorPattern    _ _ _ ts) = concatMap (qafv m) ts+  qafv m (InfixPattern       _ _ t1 _ t2) = qafv m t1 ++ qafv m t2+  qafv m (ParenPattern               _ t) = qafv m t+  qafv m (RecordPattern         _ _ _ fs) = concatMap (qafvField m) fs+  qafv m (TuplePattern              _ ts) = concatMap (qafv m) ts+  qafv m (ListPattern             _ _ ts) = concatMap (qafv m) ts+  qafv m (AsPattern                _ _ t) = qafv m t+  qafv m (LazyPattern                _ t) = qafv m t+  qafv m (FunctionPattern      _ ty f ts) =+    maybe [] (return . (\f' -> (ty', f'))) (localIdent m f) +++      concatMap (qafv m) ts+    where ty' = foldr TypeArrow ty $ map typeOf ts+  qafv m (InfixFuncPattern _ ty t1 op t2) =+    maybe [] (return . (\op' -> (ty', op'))) (localIdent m op) +++      concatMap (qafv m) [t1, t2]+    where ty' = foldr TypeArrow ty $ map typeOf [t1, t2]++filterBv :: QuantExpr e => e -> [(Type, Ident)] -> [(Type, Ident)]+filterBv e = filter ((`Set.notMember` Set.fromList (bv e)) . snd)
+ src/Base/CurryKinds.hs view
@@ -0,0 +1,45 @@+{- |+    Module      :  $Header$+    Description :  Conversion of kind representation+    Copyright   :  (c) 2016        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++   The functions 'tokind' and 'fromKind' convert Curry kind expressions into+   kinds and vice versa.++   When Curry kinds are converted with 'fromKind', kind variables are+   instantiated with the kind *.+-}++module Base.CurryKinds+  ( toKind, toKind', fromKind, fromKind', ppKind+  ) where++import Curry.Base.Pretty (Doc)+import Curry.Syntax.Pretty (pPrintPrec)+import Curry.Syntax.Type (KindExpr (..))++import Base.Kinds++toKind :: KindExpr -> Kind+toKind Star              = KindStar+toKind (ArrowKind k1 k2) = KindArrow (toKind k1) (toKind k2)++toKind' :: Maybe KindExpr -> Int -> Kind+toKind' k n = maybe (simpleKind n) toKind k++fromKind :: Kind -> KindExpr+fromKind KindStar          = Star+fromKind (KindVariable  _) = Star+fromKind (KindArrow k1 k2) = ArrowKind (fromKind k1) (fromKind k2)++fromKind' :: Kind -> Int -> Maybe KindExpr+fromKind' k n | k == simpleKind n = Nothing+              | otherwise         = Just (fromKind k)++ppKind :: Kind -> Doc+ppKind = pPrintPrec 0 . fromKind
+ src/Base/CurryTypes.hs view
@@ -0,0 +1,213 @@+{- |+    Module      :  $Header$+    Description :  Conversion of type representation+    Copyright   :  (c)         Wolfgang Lux+                   2011 - 2012 Björn Peemöller+                   2015        Jan Tikovsky+                   2016        Finn Teegen+    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+  ( toType, toTypes, toQualType, toQualTypes+  , toPred, toQualPred, toPredSet, toQualPredSet, toPredType, toQualPredType+  , toConstrType, toMethodType+  , fromType, fromQualType+  , fromPred, fromQualPred, fromPredSet, fromQualPredSet, fromPredType+  , fromQualPredType+  , ppType, ppPred, ppPredType, ppTypeScheme+  ) where++import Data.List (nub)+import qualified Data.Map as Map (Map, fromList, lookup)+import qualified Data.Set as Set++import Curry.Base.Ident+import Curry.Base.Pretty (Doc)+import Curry.Base.SpanInfo+import qualified Curry.Syntax as CS+import Curry.Syntax.Pretty (pPrint, pPrintPrec)++import Base.Expr+import Base.Messages (internalError)+import Base.Types++enumTypeVars :: (Expr a, QuantExpr a) => [Ident] -> a -> Map.Map Ident Int+enumTypeVars tvs ty = Map.fromList $ zip (tvs ++ tvs') [0..]+  where+    tvs' = [tv | tv <- nub (fv ty), tv `notElem` tvs] +++             [tv | tv <- nub (bv ty), tv `notElem` tvs]++toType :: [Ident] -> CS.TypeExpr -> Type+toType tvs ty = toType' (enumTypeVars tvs ty) ty []++toTypes :: [Ident] -> [CS.TypeExpr] -> [Type]+toTypes tvs tys = map ((flip (toType' (enumTypeVars tvs tys))) []) tys++toType' :: Map.Map Ident Int -> CS.TypeExpr -> [Type] -> Type+toType' _   (CS.ConstructorType _ tc) tys = applyType (TypeConstructor tc) tys+toType' tvs (CS.ApplyType  _ ty1 ty2) tys =+  toType' tvs ty1 (toType' tvs ty2 [] : tys)+toType' tvs (CS.VariableType    _ tv) tys =+  applyType (TypeVariable (toVar tvs tv)) tys+toType' tvs (CS.TupleType      _ tys) tys'+  | null tys  = internalError "Base.CurryTypes.toType': zero-element tuple"+  | null tys' = tupleType $ map ((flip $ toType' tvs) []) tys+  | otherwise = internalError "Base.CurryTypes.toType': tuple type application"+toType' tvs (CS.ListType        _ ty) tys+  | null tys  = listType $ toType' tvs ty []+  | otherwise = internalError "Base.CurryTypes.toType': list type application"+toType' tvs (CS.ArrowType  _ ty1 ty2) tys+  | null tys = TypeArrow (toType' tvs ty1 []) (toType' tvs ty2 [])+  | otherwise = internalError "Base.CurryTypes.toType': arrow type application"+toType' tvs (CS.ParenType       _ ty) tys = toType' tvs ty tys+toType' tvs (CS.ForallType _ tvs' ty) tys+  | null tvs' = toType' tvs ty tys+  | otherwise = applyType (TypeForall (map (toVar tvs) tvs')+                                      (toType' tvs ty []))+                          tys++toVar :: Map.Map Ident Int -> Ident -> Int+toVar tvs tv = case Map.lookup tv tvs of+  Just tv' -> tv'+  Nothing  -> internalError "Base.CurryTypes.toVar: unknown type variable"++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++toPred :: [Ident] -> CS.Constraint -> Pred+toPred tvs c = toPred' (enumTypeVars tvs c) c++toPred' :: Map.Map Ident Int -> CS.Constraint -> Pred+toPred' tvs (CS.Constraint _ qcls ty) = Pred qcls (toType' tvs ty [])++toQualPred :: ModuleIdent -> [Ident] -> CS.Constraint -> Pred+toQualPred m tvs = qualifyPred m . toPred tvs++toPredSet :: [Ident] -> CS.Context -> PredSet+toPredSet tvs cx = toPredSet' (enumTypeVars tvs cx) cx++toPredSet' :: Map.Map Ident Int -> CS.Context -> PredSet+toPredSet' tvs = Set.fromList . map (toPred' tvs)++toQualPredSet :: ModuleIdent -> [Ident] -> CS.Context -> PredSet+toQualPredSet m tvs = qualifyPredSet m . toPredSet tvs++toPredType :: [Ident] -> CS.QualTypeExpr -> PredType+toPredType tvs qty = toPredType' (enumTypeVars tvs qty) qty++toPredType' :: Map.Map Ident Int -> CS.QualTypeExpr -> PredType+toPredType' tvs (CS.QualTypeExpr _ cx ty) =+  PredType (toPredSet' tvs cx) (toType' tvs ty [])++toQualPredType :: ModuleIdent -> [Ident] -> CS.QualTypeExpr -> PredType+toQualPredType m tvs = qualifyPredType m . toPredType tvs++-- The function 'toConstrType' returns the type of a data or newtype+-- constructor. Hereby, it restricts the context to those type variables+-- which are free in the argument types.++toConstrType :: QualIdent -> [Ident] -> [CS.TypeExpr] -> PredType+toConstrType tc tvs tys = toPredType tvs $+  CS.QualTypeExpr NoSpanInfo [] ty'+  where ty'  = foldr (CS.ArrowType NoSpanInfo) ty0 tys+        ty0  = foldl (CS.ApplyType NoSpanInfo)+                     (CS.ConstructorType NoSpanInfo tc)+                     (map (CS.VariableType NoSpanInfo) tvs)++-- The function 'toMethodType' returns the type of a type class method.+-- It adds the implicit type class constraint to the method's type signature+-- and ensures that the class' type variable is always assigned index 0.++toMethodType :: QualIdent -> Ident -> CS.QualTypeExpr -> PredType+toMethodType qcls clsvar (CS.QualTypeExpr spi cx ty) =+  toPredType [clsvar] (CS.QualTypeExpr spi cx' ty)+  where cx' = CS.Constraint NoSpanInfo qcls+                (CS.VariableType NoSpanInfo clsvar) : cx++fromType :: [Ident] -> Type -> CS.TypeExpr+fromType tvs ty = fromType' tvs ty []++fromType' :: [Ident] -> Type -> [CS.TypeExpr] -> CS.TypeExpr+fromType' _   (TypeConstructor    tc) tys+  | isQTupleId tc && qTupleArity tc == length tys+    = CS.TupleType NoSpanInfo tys+  | tc == qListId && length tys == 1+    = CS.ListType NoSpanInfo (head tys)+  | otherwise+  = foldl (CS.ApplyType NoSpanInfo) (CS.ConstructorType NoSpanInfo tc) tys+fromType' tvs (TypeApply     ty1 ty2) tys =+  fromType' tvs ty1 (fromType tvs ty2 : tys)+fromType' tvs (TypeVariable       tv) tys =+  foldl (CS.ApplyType NoSpanInfo) (CS.VariableType NoSpanInfo (fromVar tvs tv))+    tys+fromType' tvs (TypeArrow     ty1 ty2) tys =+  foldl (CS.ApplyType NoSpanInfo)+    (CS.ArrowType NoSpanInfo (fromType tvs ty1) (fromType tvs ty2)) tys+fromType' tvs (TypeConstrained tys _) tys' = fromType' tvs (head tys) tys'+fromType' tvs (TypeForall    tvs' ty) tys+  | null tvs' = fromType' tvs ty tys+  | otherwise = foldl (CS.ApplyType NoSpanInfo)+                      (CS.ForallType NoSpanInfo (map (fromVar tvs) tvs')+                                                (fromType tvs ty))+                      tys++fromVar :: [Ident] -> Int -> Ident+fromVar tvs tv = if tv >= 0 then tvs !! tv else mkIdent ('_' : show (-tv))++fromQualType :: ModuleIdent -> [Ident] -> Type -> CS.TypeExpr+fromQualType m tvs = fromType tvs . unqualifyType m++fromPred :: [Ident] -> Pred -> CS.Constraint+fromPred tvs (Pred qcls ty) = CS.Constraint NoSpanInfo qcls (fromType tvs ty)++fromQualPred :: ModuleIdent -> [Ident] -> Pred -> CS.Constraint+fromQualPred m tvs = fromPred tvs .  unqualifyPred m++-- Due to the sorting of the predicate set, the list of constraints is sorted+-- as well.++fromPredSet :: [Ident] -> PredSet -> CS.Context+fromPredSet tvs = map (fromPred tvs) . Set.toAscList++fromQualPredSet :: ModuleIdent -> [Ident] -> PredSet -> CS.Context+fromQualPredSet m tvs = fromPredSet tvs . unqualifyPredSet m++fromPredType :: [Ident] -> PredType -> CS.QualTypeExpr+fromPredType tvs (PredType ps ty) =+  CS.QualTypeExpr NoSpanInfo (fromPredSet tvs ps) (fromType tvs ty)++fromQualPredType :: ModuleIdent -> [Ident] -> PredType -> CS.QualTypeExpr+fromQualPredType m tvs = fromPredType tvs . unqualifyPredType m++-- The following functions implement pretty-printing for types.++ppType :: ModuleIdent -> Type -> Doc+ppType m = pPrintPrec 0 . fromQualType m identSupply++ppPred :: ModuleIdent -> Pred -> Doc+ppPred m = pPrint . fromQualPred m identSupply++ppPredType :: ModuleIdent -> PredType -> Doc+ppPredType m = pPrint . fromQualPredType m identSupply++ppTypeScheme :: ModuleIdent -> TypeScheme -> Doc+ppTypeScheme m (ForAll _ pty) = ppPredType m pty
+ src/Base/Expr.hs view
@@ -0,0 +1,212 @@+{- |+    Module      :  $Header$+    Description :  Extraction of free and bound variables+    Copyright   :  (c)             Wolfgang Lux+                       2011 - 2015 Björn Peemöller+                       2015        Jan Tikovsky+                       2016        Finn Teegen+    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.Base.SpanInfo+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.++instance QualExpr (Decl a) where+  qfv m (FunctionDecl    _ _ _ eqs) = qfv m eqs+  qfv m (PatternDecl       _ _ rhs) = qfv m rhs+  qfv m (ClassDecl    _ _ _ _ _ ds) = qfv m ds+  qfv m (InstanceDecl _ _ _ _ _ ds) = qfv m ds+  qfv _ _                           = []++instance QuantExpr (Decl a) where+  bv (TypeSig         _ vs _) = vs+  bv (FunctionDecl   _ _ f _) = [f]+  bv (ExternalDecl      _ vs) = bv vs+  bv (PatternDecl      _ t _) = bv t+  bv (FreeDecl          _ vs) = bv vs+  bv (ClassDecl _ _ _ _ _ ds) = concatMap methods ds+  bv _                        = []++instance QualExpr (Equation a) where+  qfv m (Equation _ lhs rhs) = filterBv lhs $ qfv m lhs ++ qfv m rhs++instance QuantExpr (Lhs a) where+  bv = bv . snd . flatLhs++instance QualExpr (Lhs a) where+  qfv m lhs = qfv m $ snd $ flatLhs lhs++instance QualExpr (Rhs a) 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 a) where+  qfv m (CondExpr _ g e) = qfv m g ++ qfv m e++instance QualExpr (Expression a) 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 a) -> [Ident] -> [Ident]+qfvStmt m st fvs = qfv m st ++ filterBv st fvs++instance QualExpr (Statement a) 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 a) where+  qfv m (Alt _ t rhs) = filterBv t $ qfv m rhs++instance QuantExpr (Var a) where+  bv (Var _ v) = [v]++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 a) where+  bv (StmtExpr   _ _)  = []+  bv (StmtBind _ t _)  = bv t+  bv (StmtDecl _ _ ds) = bv ds++instance QualExpr (InfixOp a) where+  qfv m (InfixOp     a op) = qfv m $ Variable NoSpanInfo a op+  qfv _ (InfixConstr _ _ ) = []++instance QuantExpr (Pattern a) 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 a) 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 Constraint where+  fv (Constraint _ _ ty) = fv ty++instance QuantExpr Constraint where+  bv _ = []++instance Expr QualTypeExpr where+  fv (QualTypeExpr _ _ ty) = fv ty++instance QuantExpr QualTypeExpr where+  bv (QualTypeExpr _ _ ty) = bv ty++instance Expr TypeExpr where+  fv (ConstructorType     _ _) = []+  fv (ApplyType     _ ty1 ty2) = fv ty1 ++ fv ty2+  fv (VariableType       _ tv) = [tv]+  fv (TupleType         _ tys) = fv tys+  fv (ListType          _  ty) = fv ty+  fv (ArrowType     _ ty1 ty2) = fv ty1 ++ fv ty2+  fv (ParenType          _ ty) = fv ty+  fv (ForallType      _ vs ty) = filter (`notElem` vs) $ fv ty++instance QuantExpr TypeExpr where+  bv (ConstructorType     _ _) = []+  bv (ApplyType     _ ty1 ty2) = bv ty1 ++ bv ty2+  bv (VariableType        _ _) = []+  bv (TupleType         _ tys) = bv tys+  bv (ListType           _ ty) = bv ty+  bv (ArrowType     _ ty1 ty2) = bv ty1 ++ bv ty2+  bv (ParenType          _ ty) = bv ty+  bv (ForallType     _ tvs ty) = tvs ++ bv ty++filterBv :: QuantExpr e => e -> [Ident] -> [Ident]+filterBv e = filter (`Set.notMember` Set.fromList (bv e))
+ src/Base/KindSubst.hs view
@@ -0,0 +1,48 @@+{- |+    Module      :  $Header$+    Description :  Kind substitution+    Copyright   :  (c) 2016      Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++   This module implements substitutions on kinds.+-}++module Base.KindSubst+  ( module Base.KindSubst, idSubst, singleSubst, bindSubst, compose+  ) where++import Base.Kinds+import Base.Subst+import Base.TopEnv++import Env.TypeConstructor++type KindSubst = Subst Int Kind++class SubstKind a where+  subst :: KindSubst -> a -> a++bindVar :: Int -> Kind -> KindSubst -> KindSubst+bindVar kv k = compose (bindSubst kv k idSubst)++substVar :: KindSubst -> Int -> Kind+substVar = substVar' KindVariable subst++instance SubstKind Kind where+  subst _     KindStar             = KindStar+  subst sigma (KindVariable    kv) = substVar sigma kv+  subst sigma (KindArrow    k1 k2) = KindArrow (subst sigma k1) (subst sigma k2)++instance SubstKind TypeInfo where+  subst theta (DataType     tc k cs) = DataType tc (subst theta k) cs+  subst theta (RenamingType tc k nc) = RenamingType tc (subst theta k) nc+  subst theta (AliasType  tc k n ty) = AliasType tc (subst theta k) n ty+  subst theta (TypeClass   cls k ms) = TypeClass cls (subst theta k) ms+  subst theta (TypeVar            k) = TypeVar (subst theta k)++instance SubstKind a => SubstKind (TopEnv a) where+  subst = fmap . subst
+ src/Base/Kinds.hs view
@@ -0,0 +1,62 @@+{- |+    Module      :  $Header$+    Description :  Internal representation of kinds+    Copyright   :  (c) 2016        Finn Teegen+    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 kinds in the compiler.+-}++module Base.Kinds where++-- A kind is either *, which is the kind of a value's type, a kind+-- variable, or an arrow kind. Kind variables are used internally during+-- kind inference. Kind variables are not supported in Curry kind+-- expressions and all kind variables that remain free after kind+-- inference are instantiated to *.++data Kind = KindStar+          | KindVariable Int+          | KindArrow Kind Kind+  deriving (Eq, Show)++-- |The function 'kindArity' computes the arity n of a kind.+kindArity :: Kind -> Int+kindArity (KindArrow _ k) = 1 + kindArity k+kindArity _               = 0++-- |The function 'kindVars' returns a list of all kind variables+-- occurring in a kind.+kindVars :: Kind -> [Int]+kindVars k = vars k []+  where+    vars KindStar          kvs = kvs+    vars (KindVariable kv) kvs = kv : kvs+    vars (KindArrow k1 k2) kvs = vars k1 $ vars k2 kvs++-- |The function 'defaultKind' instantiates all kind variables+-- occurring in a kind to *.+defaultKind :: Kind -> Kind+defaultKind (KindArrow k1 k2) = KindArrow (defaultKind k1) (defaultKind k2)+defaultKind _                 = KindStar++-- |The function 'simpleKind' returns the kind of a type+-- constructor with arity n whose arguments all have kind *.+simpleKind :: Int -> Kind+simpleKind n = foldr KindArrow KindStar $ replicate n KindStar++-- |The function 'isSimpleKind' returns whether a kind is simple or not.+isSimpleKind :: Kind -> Bool+isSimpleKind k = k == simpleKind (kindArity k)++-- |Fetches a kind's 'arguments', i.e. everything before an+-- arrow at the top-level. For example: A kind k1 -> k2 -> k3+-- would have the arguments [k1, k2].+kindArgs :: Kind -> [Kind]+kindArgs (KindArrow k k') = k : kindArgs k'+kindArgs _                = []
+ src/Base/Messages.hs view
@@ -0,0 +1,78 @@+{- |+    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, spanInfoMessage+  ) 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, spanInfoMessage+                                  , ppWarning, ppMessagesWithPreviews, 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 =<< (fmap show $ ppMessagesWithPreviews msgType $ sort msgs)++-- |Raise an internal error+internalError :: String -> a+internalError msg = error $ "Internal error: " ++ msg
+ src/Base/NestEnv.hs view
@@ -0,0 +1,120 @@+{- |+    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
+ src/Base/PrettyKinds.hs view
@@ -0,0 +1,22 @@+{- |+    Module      :  $Header$+    Description :  TODO+    Copyright   :  (c) 2017        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++   TODO+-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Base.PrettyKinds where++import Curry.Base.Pretty++import Base.CurryKinds+import Base.Kinds++instance Pretty Kind where+  pPrint = ppKind
+ src/Base/PrettyTypes.hs view
@@ -0,0 +1,55 @@+{- |+    Module      :  $Header$+    Description :  TODO+    Copyright   :  (c) 2017        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++   TODO+-}+{-# LANGUAGE     CPP        #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Base.PrettyTypes where++#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif++import Data.Maybe (fromMaybe)+import qualified Data.Set as Set (Set, toAscList)++import Curry.Base.Ident (identSupply)+import Curry.Base.Pretty++import Base.CurryTypes+import Base.Types++instance Pretty Type where+  pPrint = pPrintPrec 0 . fromType identSupply++instance Pretty Pred where+  pPrint = pPrint . fromPred identSupply++instance Pretty a => Pretty (Set.Set a) where+  pPrint = parens . list . map pPrint . Set.toAscList++instance Pretty PredType where+  pPrint = pPrint . fromPredType identSupply++instance Pretty DataConstr where+  pPrint (DataConstr i tys)      = pPrint i <+> hsep (map pPrint tys)+  pPrint (RecordConstr i ls tys) =     pPrint i+                                   <+> braces (hsep (punctuate comma pLs))+    where+      pLs = zipWith (\l ty -> pPrint l <+> colon <> colon <+> pPrint ty) ls tys++instance Pretty ClassMethod where+  pPrint (ClassMethod f mar pty) =     pPrint f+                                   <>  text "/" <> int (fromMaybe 0 mar)+                                   <+> colon <> colon <+> pPrint pty++instance Pretty TypeScheme where+  pPrint (ForAll _ ty) = pPrint ty
+ src/Base/SCC.hs view
@@ -0,0 +1,62 @@+{- |+    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
+ src/Base/Subst.hs view
@@ -0,0 +1,127 @@+{- |+    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))
+ src/Base/TopEnv.hs view
@@ -0,0 +1,181 @@+{- |+    Module      :  $Header$+    Description :  Top-Level Environments+    Copyright   :   1999 - 2003 Wolfgang Lux+                    2005        Martin Engelke+                    2011 - 2012 Björn Peemöller+                    2016        Finn Teegen+    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, qualUnbindTopEnv+  , lookupTopEnv, qualLookupTopEnv, qualElemTopEnv+  , allImports, moduleImports, localBindings, allLocalBindings, allBindings+  , allEntities+  ) 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++qualUnbindTopEnv :: QualIdent -> TopEnv a -> TopEnv a+qualUnbindTopEnv x (TopEnv env) =+  TopEnv $ Map.insert x (unbind (entities x env)) env+  where unbind [] = internalError $ "TopEnv.qualUnbindTopEnv " ++ show x+        unbind _  = []++lookupTopEnv :: Ident -> TopEnv a -> [a]+lookupTopEnv = qualLookupTopEnv . qualify++qualLookupTopEnv :: QualIdent -> TopEnv a -> [a]+qualLookupTopEnv x (TopEnv env) = map snd (entities x env)++qualElemTopEnv :: QualIdent -> TopEnv a -> Bool+qualElemTopEnv x env = not (null (qualLookupTopEnv 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 ]++allBindings :: TopEnv a -> [(QualIdent, a)]+allBindings (TopEnv env) = [(x, y) | (x, ys) <- Map.toList env, (_, y) <- ys]++allEntities :: TopEnv a -> [a]+allEntities (TopEnv env) = [ y | (_, ys) <- Map.toList env, (_, y) <- ys]
+ src/Base/TypeExpansion.hs view
@@ -0,0 +1,112 @@+{- |+    Module      :  $Header$+    Description :  Type expansion+    Copyright   :  (c) 2016 Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++   This module implements expansion of alias types in types and predicates.+-}++module Base.TypeExpansion+  ( module Base.TypeExpansion+  ) where++import qualified Data.Set.Extra as Set (map)++import Curry.Base.Ident+import Curry.Syntax++import Base.CurryTypes+import Base.Messages+import Base.Types+import Base.TypeSubst++import Env.Class+import Env.TypeConstructor++-- 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. Similarly, 'expandPred' expands all+-- type synonyms in a predicate and also qualifies all class identifiers+-- with the name of the module in which the class was defined. The+-- function 'expandPredSet' minimizes the predicate set after expansion.++expandType :: ModuleIdent -> TCEnv -> Type -> Type+expandType m tcEnv ty = expandType' m tcEnv ty []++expandType' :: ModuleIdent -> TCEnv -> Type -> [Type] -> Type+expandType' m tcEnv (TypeConstructor     tc) tys =+  case qualLookupTypeInfo tc tcEnv of+    [DataType       tc' _ _ ] -> applyType (TypeConstructor tc') tys+    [RenamingType   tc' _ _ ] -> applyType (TypeConstructor tc') tys+    [AliasType    _ _   n ty] -> let (tys', tys'') = splitAt n tys+                                 in  applyType (expandAliasType tys' ty) tys''+    _ -> case qualLookupTypeInfo (qualQualify m tc) tcEnv of+      [DataType       tc' _ _ ] -> applyType (TypeConstructor tc') tys+      [RenamingType   tc' _ _ ] -> applyType (TypeConstructor tc') tys+      [AliasType    _ _   n ty] -> let (tys', tys'') = splitAt n tys+                                   in  applyType (expandAliasType tys' ty) tys''+      _ -> internalError $ "Base.TypeExpansion.expandType: " ++ show tc+expandType' m tcEnv (TypeApply      ty1 ty2) tys =+  expandType' m tcEnv ty1 (expandType m tcEnv ty2 : tys)+expandType' _ _     tv@(TypeVariable      _) tys = applyType tv tys+expandType' _ _     tc@(TypeConstrained _ _) tys = applyType tc tys+expandType' m tcEnv (TypeArrow      ty1 ty2) tys =+  applyType (TypeArrow (expandType m tcEnv ty1) (expandType m tcEnv ty2)) tys+expandType' m tcEnv (TypeForall      tvs ty) tys =+  applyType (TypeForall tvs (expandType m tcEnv ty)) tys++expandPred :: ModuleIdent -> TCEnv -> Pred -> Pred+expandPred m tcEnv (Pred qcls ty) = case qualLookupTypeInfo qcls tcEnv of+  [TypeClass ocls _ _] -> Pred ocls (expandType m tcEnv ty)+  _ -> case qualLookupTypeInfo (qualQualify m qcls) tcEnv of+    [TypeClass ocls _ _] -> Pred ocls (expandType m tcEnv ty)+    _ -> internalError $ "Base.TypeExpansion.expandPred: " ++ show qcls++expandPredSet :: ModuleIdent -> TCEnv -> ClassEnv -> PredSet -> PredSet+expandPredSet m tcEnv clsEnv = minPredSet clsEnv . Set.map (expandPred m tcEnv)++expandPredType :: ModuleIdent -> TCEnv -> ClassEnv -> PredType -> PredType+expandPredType m tcEnv clsEnv (PredType ps ty) =+  PredType (expandPredSet m tcEnv clsEnv ps) (expandType m tcEnv ty)++-- The functions 'expandMonoType' and 'expandPolyType' convert (qualified)+-- type expressions into (predicated) types and also expand all type synonyms+-- and qualify all type constructors during the conversion.++expandMonoType :: ModuleIdent -> TCEnv -> [Ident] -> TypeExpr -> Type+expandMonoType m tcEnv tvs = expandType m tcEnv . toType tvs++expandPolyType :: ModuleIdent -> TCEnv -> ClassEnv -> QualTypeExpr -> PredType+expandPolyType m tcEnv clsEnv =+  normalize 0 . expandPredType m tcEnv clsEnv . toPredType []++-- The function 'expandConstrType' computes the predicated type for a data+-- or newtype constructor. Similar to 'toConstrType' from 'CurryTypes', the+-- type's context is restricted to those type variables which are free in+-- the argument types. However, type synonyms are expanded and type constructors+-- and type classes are qualified with the name of the module containing their+-- definition.++expandConstrType :: ModuleIdent -> TCEnv -> ClassEnv -> QualIdent -> [Ident]+                 -> [TypeExpr] -> PredType+expandConstrType m tcEnv clsEnv tc tvs tys =+  normalize n $ expandPredType m tcEnv clsEnv pty+  where n = length tvs+        pty = toConstrType tc tvs tys++-- The function 'expandMethodType' converts the type of a type class method+-- Similar to function 'toMethodType' from 'CurryTypes', the implicit class+-- constraint is added to the method's type and the class' type variable is+-- assigned index 0. However, type synonyms are expanded and type constructors+-- and type classes are qualified with the name of the module containing their+-- definition.++expandMethodType :: ModuleIdent -> TCEnv -> ClassEnv -> QualIdent -> Ident+                 -> QualTypeExpr -> PredType+expandMethodType m tcEnv clsEnv qcls tv =+  normalize 1 . expandPredType m tcEnv clsEnv . toMethodType qcls tv
+ src/Base/TypeSubst.hs view
@@ -0,0 +1,137 @@+{- |+    Module      :  $Header$+    Description :  Type substitution+    Copyright   :  (c) 2003 Wolfgang Lux+                       2016 Finn Teegen+    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           Data.Maybe      (fromMaybe)+import qualified Data.Set as Set (Set, map)++import Base.Subst+import Base.TopEnv+import Base.Types++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 (Ord a, SubstType a) => SubstType (Set.Set a) where+  subst sigma = Set.map (subst sigma)++instance SubstType a => SubstType [a] where+  subst sigma = map (subst sigma)++instance SubstType Type where+  subst sigma ty = subst' sigma ty []++subst' :: TypeSubst -> Type -> [Type] -> Type+subst' _     tc@(TypeConstructor   _) = foldl TypeApply tc+subst' sigma (TypeApply      ty1 ty2) = subst' sigma ty1 . (subst sigma ty2 :)+subst' sigma (TypeVariable        tv) = applyType (substVar sigma tv)+subst' sigma (TypeArrow      ty1 ty2) =+  foldl TypeApply (TypeArrow (subst sigma ty1) (subst sigma ty2))+subst' sigma (TypeConstrained tys tv) = case substVar sigma tv of+  TypeVariable tv' -> foldl TypeApply (TypeConstrained tys tv')+  ty               -> foldl TypeApply ty+subst' sigma (TypeForall      tvs ty) =+  applyType (TypeForall tvs (subst sigma ty))++instance SubstType Pred where+  subst sigma (Pred qcls ty) = Pred qcls (subst sigma ty)++instance SubstType PredType where+  subst sigma (PredType ps ty) = PredType (subst sigma ps) (subst sigma ty)++instance SubstType TypeScheme where+  subst sigma (ForAll n ty) =+    ForAll n (subst (foldr unbindSubst sigma [0 .. n-1]) ty)++instance SubstType ValueInfo where+  subst _     dc@(DataConstructor  _ _ _ _) = dc+  subst _     nc@(NewtypeConstructor _ _ _) = nc+  subst theta (Value             v cm a ty) = Value v cm 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++-- The class method 'expandAliasType' expands all occurrences of a+-- type synonym in its second argument.++class ExpandAliasType a where+  expandAliasType :: [Type] -> a -> a++instance ExpandAliasType a => ExpandAliasType [a] where+  expandAliasType tys = map (expandAliasType tys)++instance (Ord a, ExpandAliasType a) => ExpandAliasType (Set.Set a) where+  expandAliasType tys = Set.map (expandAliasType tys)++instance ExpandAliasType Type where+  expandAliasType tys ty = expandAliasType' tys ty []++expandAliasType' :: [Type] -> Type -> [Type] -> Type+expandAliasType' _   tc@(TypeConstructor   _) = applyType tc+expandAliasType' tys (TypeApply      ty1 ty2) =+  expandAliasType' tys ty1 . (expandAliasType tys ty2 :)+expandAliasType' tys tv@(TypeVariable      n)+  | n >= 0    = applyType (tys !! n)+  | otherwise = applyType tv+expandAliasType' _   tc@(TypeConstrained _ _) = applyType tc+expandAliasType' tys (TypeArrow      ty1 ty2) =+  applyType (TypeArrow (expandAliasType tys ty1) (expandAliasType tys ty2))+expandAliasType' tys (TypeForall      tvs ty) =+  applyType (TypeForall tvs (expandAliasType tys ty))++instance ExpandAliasType Pred where+  expandAliasType tys (Pred qcls ty) = Pred qcls (expandAliasType tys ty)++instance ExpandAliasType PredType where+  expandAliasType tys (PredType ps ty) =+    PredType (expandAliasType tys ps) (expandAliasType tys ty)++-- 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'. The function has a threshold parameter that allows+-- preserving the indices of type variables bound on the left hand side+-- of a type declaration and in the head of a type class declaration,+-- respectively.++normalize :: Int -> PredType -> PredType+normalize n ty = expandAliasType [TypeVariable (occur tv) | tv <- [0..]] ty+  where tvs = zip (nub (filter (>= n) (typeVars ty))) [n..]+        occur tv = fromMaybe tv (lookup tv tvs)++-- The function 'instanceType' computes an instance of a polymorphic type by+-- substituting the first type argument for all occurrences of the type+-- variable with index 0 in the second argument. The function carefully+-- assigns new indices to all other type variables of the second argument+-- so that they do not conflict with the type variables of the first argument.++instanceType :: ExpandAliasType a => Type -> a -> a+instanceType ty = expandAliasType (ty : map TypeVariable [n ..])+  where ForAll n _ = polyType ty
+ src/Base/Types.hs view
@@ -0,0 +1,478 @@+{- |+    Module      :  $Header$+    Description :  Internal representation of types+    Copyright   :  (c) 2002 - 2004 Wolfgang Lux+                                   Martin Engelke+                       2015        Jan Tikovsky+                       2016        Finn Teegen+    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 along with some helper functions.+-}++-- TODO: Use MultiParamTypeClasses ?++module Base.Types+  ( -- * Representation of types+    Type (..), applyType, unapplyType, rootOfType+  , isArrowType, arrowArity, arrowArgs, arrowBase, arrowUnapply+  , IsType (..), typeConstrs+  , qualifyType, unqualifyType, qualifyTC+    -- * Representation of predicate, predicate sets and predicated types+  , Pred (..), qualifyPred, unqualifyPred+  , PredSet, emptyPredSet, partitionPredSet, minPredSet, maxPredSet+  , qualifyPredSet, unqualifyPredSet+  , PredType (..), predType, unpredType, qualifyPredType, unqualifyPredType+    -- * Representation of data constructors+  , DataConstr (..), constrIdent, constrTypes, recLabels, recLabelTypes+  , tupleData+    -- * Representation of class methods+  , ClassMethod (..), methodName, methodArity, methodType+    -- * Representation of quantification+  , TypeScheme (..), monoType, polyType, typeScheme+  , rawType+    -- * Predefined types+  , arrowType, unitType, predUnitType, boolType, predBoolType, charType+  , intType, predIntType, floatType, predFloatType, stringType, predStringType+  , listType, consType, ioType, tupleType+  , numTypes, fractionalTypes+  , predefTypes+  ) where++import qualified Data.Set.Extra as Set++import Curry.Base.Ident++import Base.Messages (internalError)++import Env.Class (ClassEnv, allSuperClasses)++-- ---------------------------------------------------------------------------+-- Types+-- ---------------------------------------------------------------------------++-- A type is either a type constructor, a type variable, an application+-- of a type to another type, or an arrow type. Although the latter could+-- be expressed by using 'TypeApply' with the function type constructor,+-- we currently use 'TypeArrow' because arrow types are used so frequently.++-- 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.++-- 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.++-- Note further that the order of constructors is important for the derived+-- 'Ord' instance. In particular, it is essential that the type variable+-- is considered less than the type application (see predicates and predicate+-- sets below for more information).++data Type+  = TypeConstructor QualIdent+  | TypeVariable Int+  | TypeConstrained [Type] Int+  | TypeApply Type Type+  | TypeArrow Type Type+  | TypeForall [Int] Type+  deriving (Eq, Ord, Show)++-- The function 'applyType' applies a type to a list of argument types,+-- whereas applications of the function type constructor to two arguments+-- are converted into an arrow type. The function 'unapplyType' decomposes+-- a type into a root type and a list of argument types.++applyType :: Type -> [Type] -> Type+applyType (TypeConstructor tc) tys+  | tc == qArrowId && length tys == 2 = TypeArrow (tys !! 0) (tys !! 1)+applyType (TypeApply (TypeConstructor tc) ty) tys+  | tc == qArrowId && length tys == 1 = TypeArrow ty (head tys)+applyType ty tys = foldl TypeApply ty tys++unapplyType :: Bool -> Type -> (Type, [Type])+unapplyType dflt ty = unapply ty []+  where+    unapply (TypeConstructor     tc) tys  = (TypeConstructor tc, tys)+    unapply (TypeApply      ty1 ty2) tys  = unapply ty1 (ty2 : tys)+    unapply (TypeVariable        tv) tys  = (TypeVariable tv, tys)+    unapply (TypeArrow      ty1 ty2) tys  =+      (TypeConstructor qArrowId, ty1 : ty2 : tys)+    unapply (TypeConstrained tys tv) tys'+      | dflt      = unapply (head tys) tys'+      | otherwise = (TypeConstrained tys tv, tys')+    unapply (TypeForall     tvs ty') tys  = (TypeForall tvs ty', tys)++-- The function 'rootOfType' returns the name of the type constructor at the+-- root of a type. This function must not be applied to a type whose root is+-- a type variable or a skolem type.++rootOfType :: Type -> QualIdent+rootOfType ty = case fst (unapplyType True ty) of+  TypeConstructor tc -> tc+  _ -> internalError $ "Base.Types.rootOfType: " ++ show ty++-- 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. 'arrowUnapply'+-- combines 'arrowArgs' and 'arrowBase' in one call.++isArrowType :: Type -> Bool+isArrowType (TypeArrow _ _) = True+isArrowType _               = False++arrowArity :: Type -> Int+arrowArity = length. arrowArgs++arrowArgs :: Type -> [Type]+arrowArgs = fst . arrowUnapply++arrowBase :: Type -> Type+arrowBase = snd. arrowUnapply++arrowUnapply :: Type -> ([Type], Type)+arrowUnapply (TypeArrow ty1 ty2) = (ty1 : tys, ty)+  where (tys, ty) = arrowUnapply ty2+arrowUnapply ty                  = ([], ty)++-- The function 'typeConstrs' returns a list of all type constructors+-- occuring in a type t.++typeConstrs :: Type -> [QualIdent]+typeConstrs ty = constrs ty [] where+  constrs (TypeConstructor  tc) tcs = tc : tcs+  constrs (TypeApply   ty1 ty2) tcs = constrs ty1 (constrs ty2 tcs)+  constrs (TypeVariable      _) tcs = tcs+  constrs (TypeConstrained _ _) tcs = tcs+  constrs (TypeArrow   ty1 ty2) tcs = constrs ty1 (constrs ty2 tcs)+  constrs (TypeForall    _ ty') tcs = constrs ty' tcs++-- The method 'typeVars' returns a list of all type variables occurring in a+-- type t. Note that 'TypeConstrained' variables are not included in the set of+-- type variables because they cannot be generalized.++class IsType t where+  typeVars :: t -> [Int]++instance IsType Type where+  typeVars = typeVars'++typeVars' :: Type -> [Int]+typeVars' ty = vars ty [] where+  vars (TypeConstructor   _) tvs = tvs+  vars (TypeApply   ty1 ty2) tvs = vars ty1 (vars ty2 tvs)+  vars (TypeVariable     tv) tvs = tv : tvs+  vars (TypeConstrained _ _) tvs = tvs+  vars (TypeArrow   ty1 ty2) tvs = vars ty1 (vars ty2 tvs)+  vars (TypeForall tvs' ty') tvs = filter (`notElem` tvs') (typeVars' ty') ++ tvs++-- The functions 'qualifyType' and 'unqualifyType' add/remove the+-- qualification with a module identifier for type constructors.++qualifyType :: ModuleIdent -> Type -> Type+qualifyType m (TypeConstructor     tc) = TypeConstructor (qualifyTC m tc)+qualifyType m (TypeApply      ty1 ty2) =+  TypeApply (qualifyType m ty1) (qualifyType m ty2)+qualifyType _ tv@(TypeVariable      _) = tv+qualifyType m (TypeConstrained tys tv) =+  TypeConstrained (map (qualifyType m) tys) tv+qualifyType m (TypeArrow      ty1 ty2) =+  TypeArrow (qualifyType m ty1) (qualifyType m ty2)+qualifyType m (TypeForall      tvs ty) = TypeForall tvs (qualifyType m ty)++unqualifyType :: ModuleIdent -> Type -> Type+unqualifyType m (TypeConstructor     tc) = TypeConstructor (qualUnqualify m tc)+unqualifyType m (TypeApply      ty1 ty2) =+  TypeApply (unqualifyType m ty1) (unqualifyType m ty2)+unqualifyType _ tv@(TypeVariable      _) = tv+unqualifyType m (TypeConstrained tys tv) =+  TypeConstrained (map (unqualifyType m) tys) tv+unqualifyType m (TypeArrow      ty1 ty2) =+  TypeArrow (unqualifyType m ty1) (unqualifyType m ty2)+unqualifyType m (TypeForall      tvs ty) = TypeForall tvs (unqualifyType m ty)++qualifyTC :: ModuleIdent -> QualIdent -> QualIdent+qualifyTC m tc | isPrimTypeId tc = tc+               | otherwise       = qualQualify m tc++-- ---------------------------------------------------------------------------+-- Predicates+-- ---------------------------------------------------------------------------++data Pred = Pred QualIdent Type+  deriving (Eq, Show)++-- We provide a custom 'Ord' instance for predicates here where we consider+-- the type component of the predicate before the class component. This way,+-- we ensure that a class method's implicit class constraint is always the+-- minimum w.r.t. this order, because the type expression for that constraint+-- is a type variable with index 0 and there are no other class constraints+-- in a predicate set that constraint the same type variable as restrictions+-- on class variables are not allowed (see predicate sets below for more+-- information why this order is relevant).++instance Ord Pred where+  Pred qcls1 ty1 `compare` Pred qcls2 ty2 = case ty1 `compare` ty2 of+    LT -> LT+    EQ -> qcls1 `compare` qcls2+    GT -> GT++instance IsType Pred where+  typeVars (Pred _ ty) = typeVars ty++qualifyPred :: ModuleIdent -> Pred -> Pred+qualifyPred m (Pred qcls ty) = Pred (qualQualify m qcls) (qualifyType m ty)++unqualifyPred :: ModuleIdent -> Pred -> Pred+unqualifyPred m (Pred qcls ty) =+  Pred (qualUnqualify m qcls) (unqualifyType m ty)++-- ---------------------------------------------------------------------------+-- Predicate sets+-- ---------------------------------------------------------------------------++-- A predicate set is an ordered set of predicates. This way, we do not+-- have to manually take care of duplicate predicates and have automatically+-- achieved a canonical representation (as only original names for type classes+-- are used). Having the order on types and predicates in mind, we have also+-- ensured that a class method's implicit class constraint is always the minimum+-- element of a method's predicate set, thus making it very easy to remove it.++type PredSet = Set.Set Pred++instance (IsType a, Ord a) => IsType (Set.Set a) where+  typeVars = concat . Set.toList . Set.map typeVars++emptyPredSet :: PredSet+emptyPredSet = Set.empty++partitionPredSet :: PredSet -> (PredSet, PredSet)+partitionPredSet = Set.partition $ \(Pred _ ty) -> isTypeVariable ty+  where+    isTypeVariable (TypeVariable _) = True+    isTypeVariable (TypeApply ty _) = isTypeVariable ty+    isTypeVariable _                = False++-- The function 'minPredSet' transforms a predicate set by removing all+-- predicates from the predicate set which are implied by other predicates+-- according to the super class hierarchy. Inversely, the function 'maxPredSet'+-- adds all predicates to a predicate set which are implied by the predicates+-- in the given predicate set.++minPredSet :: ClassEnv -> PredSet -> PredSet+minPredSet clsEnv ps =+  ps `Set.difference` Set.concatMap implied ps+  where implied (Pred cls ty) = Set.fromList+          [Pred cls' ty | cls' <- tail (allSuperClasses cls clsEnv)]++maxPredSet :: ClassEnv -> PredSet -> PredSet+maxPredSet clsEnv ps = Set.concatMap implied ps+  where implied (Pred cls ty) = Set.fromList+          [Pred cls' ty | cls' <- allSuperClasses cls clsEnv]++qualifyPredSet :: ModuleIdent -> PredSet -> PredSet+qualifyPredSet m = Set.map (qualifyPred m)++unqualifyPredSet :: ModuleIdent -> PredSet -> PredSet+unqualifyPredSet m = Set.map (unqualifyPred m)++-- ---------------------------------------------------------------------------+-- Predicated types+-- ---------------------------------------------------------------------------++data PredType = PredType PredSet Type+  deriving (Eq, Show)++-- When enumarating the type variables and skolems of a predicated type, we+-- consider the type variables occuring in the predicate set after the ones+-- occuring in the type itself.++instance IsType PredType where+  typeVars (PredType ps ty) = typeVars ty ++ typeVars ps++predType :: Type -> PredType+predType = PredType emptyPredSet++unpredType :: PredType -> Type+unpredType (PredType _ ty) = ty++qualifyPredType :: ModuleIdent -> PredType -> PredType+qualifyPredType m (PredType ps ty) =+  PredType (qualifyPredSet m ps) (qualifyType m ty)++unqualifyPredType :: ModuleIdent -> PredType -> PredType+unqualifyPredType m (PredType ps ty) =+  PredType (unqualifyPredSet m ps) (unqualifyType m ty)++-- ---------------------------------------------------------------------------+-- Data constructors+-- ---------------------------------------------------------------------------++-- The type 'DataConstr' is used to represent value or record constructors+-- introduced by data or newtype declarations.++data DataConstr = DataConstr   Ident [Type]+                | RecordConstr Ident [Ident] [Type]+  deriving (Eq, Show)++constrIdent :: DataConstr -> Ident+constrIdent (DataConstr     c _) = c+constrIdent (RecordConstr c _ _) = c++constrTypes :: DataConstr -> [Type]+constrTypes (DataConstr     _ tys) = tys+constrTypes (RecordConstr _ _ tys) = tys++recLabels :: DataConstr -> [Ident]+recLabels (DataConstr      _ _) = []+recLabels (RecordConstr _ ls _) = ls++recLabelTypes :: DataConstr -> [Type]+recLabelTypes (DataConstr       _ _) = []+recLabelTypes (RecordConstr _ _ tys) = tys++tupleData :: [DataConstr]+tupleData = [DataConstr (tupleId n) (take n tvs) | n <- [2 ..]]+  where tvs = map TypeVariable [0 ..]++-- ---------------------------------------------------------------------------+-- Class methods+-- ---------------------------------------------------------------------------++-- The type 'ClassMethod' is used to represent class methods introduced+-- by class declarations. The 'Maybe Int' denotes the arity of the provided+-- default implementation.++data ClassMethod = ClassMethod Ident (Maybe Int) PredType+  deriving (Eq, Show)++methodName :: ClassMethod -> Ident+methodName (ClassMethod f _ _) = f++methodArity :: ClassMethod -> Maybe Int+methodArity (ClassMethod _ a _) = a++methodType :: ClassMethod -> PredType+methodType (ClassMethod _ _ pty) = pty++-- ---------------------------------------------------------------------------+-- Quantification+-- ---------------------------------------------------------------------------++-- We support only universally quantified type schemes+-- (forall alpha . tau(alpha)). 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' constructor.++data TypeScheme = ForAll Int PredType deriving (Eq, Show)++instance IsType TypeScheme where+  typeVars (ForAll _ pty) = [tv | tv <- typeVars pty, tv < 0]++-- 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 = ForAll 0 . predType++polyType :: Type -> TypeScheme+polyType = typeScheme . predType++typeScheme :: PredType -> TypeScheme+typeScheme pty = ForAll (maximum (-1 : typeVars pty) + 1) pty++-- The function 'rawType' strips the quantifier and predicate set from a+-- type scheme.++rawType :: TypeScheme -> Type+rawType (ForAll _ (PredType _ ty)) = ty++-- ---------------------------------------------------------------------------+-- Predefined types+-- ---------------------------------------------------------------------------++primType :: QualIdent -> [Type] -> Type+primType = applyType . TypeConstructor++arrowType :: Type -> Type -> Type+arrowType ty1 ty2 = primType qArrowId [ty1, ty2]++unitType :: Type+unitType = primType qUnitId []++predUnitType :: PredType+predUnitType = predType unitType++boolType :: Type+boolType = primType qBoolId []++predBoolType :: PredType+predBoolType = predType boolType++charType :: Type+charType = primType qCharId []++intType :: Type+intType = primType qIntId []++predIntType :: PredType+predIntType = predType intType++floatType :: Type+floatType = primType qFloatId []++predFloatType :: PredType+predFloatType = predType floatType++stringType :: Type+stringType = listType charType++predStringType :: PredType+predStringType = predType stringType++listType :: Type -> Type+listType ty = primType qListId [ty]++consType :: Type -> Type+consType ty = TypeArrow ty (TypeArrow (listType ty) (listType ty))++ioType :: Type -> Type+ioType ty = primType qIOId [ty]++tupleType :: [Type] -> Type+tupleType tys = primType (qTupleId (length tys)) tys++-- 'numTypes' and 'fractionalTypes' define the eligible types for+-- numeric literals in patterns.++numTypes :: [Type]+numTypes = [intType, floatType]++fractionalTypes :: [Type]+fractionalTypes = drop 1 numTypes++predefTypes :: [(Type, [DataConstr])]+predefTypes =+  [ (arrowType a b, [])+  , (unitType     , [ DataConstr unitId [] ])+  , (listType a   , [ DataConstr nilId  []+                    , DataConstr consId [a, listType a]+                    ])+  ]+  where a = TypeVariable 0+        b = TypeVariable 1
+ src/Base/Typing.hs view
@@ -0,0 +1,190 @@+{- |+    Module      :  $Header$+    Description :  Type computation of Curry expressions+    Copyright   :  (c) 2003 - 2006 Wolfgang Lux+                       2014 - 2015 Jan Tikovsky+                       2016        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    After the compiler has attributed patterns and expressions with type+    information during type inference, it is straightforward to recompute+    the type of every pattern and expression. Since all annotated types+    are monomorphic, there is no need to instantiate any variables or+    perform any (non-trivial) unifications.+-}++module Base.Typing+  ( Typeable (..)+  , withType, matchType+  , bindDecls, bindDecl, bindPatterns, bindPattern, declVars, patternVars+  ) where++import Data.List (nub)+import Data.Maybe (fromMaybe)++import Curry.Base.Ident+import Curry.Syntax++import Base.Messages (internalError)+import Base.Types+import Base.TypeSubst+import Base.Utils (fst3)++import Env.Value++class Typeable a where+  typeOf :: a -> Type++instance Typeable Type where+  typeOf = id++instance Typeable PredType where+  typeOf = unpredType++instance Typeable a => Typeable (Rhs a) where+  typeOf (SimpleRhs  _ _ e _ ) = typeOf e+  typeOf (GuardedRhs _ _ es _) = head [typeOf e | CondExpr _ _ e <- es]++instance Typeable a => Typeable (Pattern a) where+  typeOf (LiteralPattern _ a _) = typeOf a+  typeOf (NegativePattern _ a _) = typeOf a+  typeOf (VariablePattern _ a _) = typeOf a+  typeOf (ConstructorPattern _ a _ _) = typeOf a+  typeOf (InfixPattern _ a _ _ _) = typeOf a+  typeOf (ParenPattern _ t) = typeOf t+  typeOf (RecordPattern _ a _ _) = typeOf a+  typeOf (TuplePattern _ ts) = tupleType $ map typeOf ts+  typeOf (ListPattern _ a _) = typeOf a+  typeOf (AsPattern _ _ t) = typeOf t+  typeOf (LazyPattern _ t) = typeOf t+  typeOf (FunctionPattern _ a _ _) = typeOf a+  typeOf (InfixFuncPattern _ a _ _ _) = typeOf a++instance Typeable a => Typeable (Expression a) where+  typeOf (Literal _ a _) = typeOf a+  typeOf (Variable _ a _) = typeOf a+  typeOf (Constructor _ a _) = typeOf a+  typeOf (Paren _ e) = typeOf e+  typeOf (Typed _ e _) = typeOf e+  typeOf (Record _ a _ _) = typeOf a+  typeOf (RecordUpdate _ e _) = typeOf e+  typeOf (Tuple _ es) = tupleType (map typeOf es)+  typeOf (List _ a _) = typeOf a+  typeOf (ListCompr _ e _) = listType (typeOf e)+  typeOf (EnumFrom _ e) = listType (typeOf e)+  typeOf (EnumFromThen _ e _) = listType (typeOf e)+  typeOf (EnumFromTo _ e _) = listType (typeOf e)+  typeOf (EnumFromThenTo _ e _ _) = listType (typeOf e)+  typeOf (UnaryMinus _ e) = typeOf e+  typeOf (Apply _ e _) = case typeOf e of+    TypeArrow _ ty -> ty+    _ -> internalError "Base.Typing.typeOf: application"+  typeOf (InfixApply _ _ op _) = case typeOf (infixOp op) of+    TypeArrow _ (TypeArrow _ ty) -> ty+    _ -> internalError "Base.Typing.typeOf: infix application"+  typeOf (LeftSection _ _ op) = case typeOf (infixOp op) of+    TypeArrow _ ty -> ty+    _ -> internalError "Base.Typing.typeOf: left section"+  typeOf (RightSection _ op _) = case typeOf (infixOp op) of+    TypeArrow ty1 (TypeArrow _ ty2) -> TypeArrow ty1 ty2+    _ -> internalError "Base.Typing.typeOf: right section"+  typeOf (Lambda _ ts e) = foldr (TypeArrow . typeOf) (typeOf e) ts+  typeOf (Let _ _ _ e) = typeOf e+  typeOf (Do _ _ _ e) = typeOf e+  typeOf (IfThenElse _ _ e _) = typeOf e+  typeOf (Case _ _ _ _ as) = typeOf $ head as++instance Typeable a => Typeable (Alt a) where+  typeOf (Alt _ _ rhs) = typeOf rhs++-- When inlining variable and function definitions, the compiler must+-- eventually update the type annotations of the inlined expression. To+-- that end, the variable or function's annotated type and the type of+-- the inlined expression must be unified. Since the program is type+-- correct, this unification is just a simple one way matching where we+-- only need to match the type variables in the inlined expression's type+-- with the corresponding types in the variable or function's annotated+-- type.++withType :: (Functor f, Typeable (f Type)) => Type -> f Type -> f Type+withType ty e = fmap (subst (matchType (typeOf e) ty idSubst)) e++matchType :: Type -> Type -> TypeSubst -> TypeSubst+matchType ty1 ty2 = fromMaybe noMatch (matchType' ty1 ty2)+  where+    noMatch = internalError $ "Base.Typing.matchType: " +++                                showsPrec 11 ty1 " " ++ showsPrec 11 ty2 ""++matchType' :: Type -> Type -> Maybe (TypeSubst -> TypeSubst)+matchType' (TypeVariable tv) ty+  | ty == TypeVariable tv = Just id+  | otherwise = Just (bindSubst tv ty)+matchType' (TypeConstructor tc1) (TypeConstructor tc2)+  | tc1 == tc2 = Just id+matchType' (TypeConstrained _ tv1) (TypeConstrained _ tv2)+  | tv1 == tv2 = Just id+matchType' (TypeApply ty11 ty12) (TypeApply ty21 ty22) =+  fmap (. matchType ty12 ty22) (matchType' ty11 ty21)+matchType' (TypeArrow ty11 ty12) (TypeArrow ty21 ty22) =+  Just (matchType ty11 ty21 . matchType ty12 ty22)+matchType' (TypeApply ty11 ty12) (TypeArrow ty21 ty22) =+  fmap (. matchType ty12 ty22)+       (matchType' ty11 (TypeApply (TypeConstructor qArrowId) ty21))+matchType' (TypeArrow ty11 ty12) (TypeApply ty21 ty22) =+  fmap (. matchType ty12 ty22)+       (matchType' (TypeApply (TypeConstructor qArrowId) ty11) ty21)+matchType' (TypeForall _ ty1) (TypeForall _ ty2) = matchType' ty1 ty2+matchType' (TypeForall _ ty1) ty2 = matchType' ty1 ty2+matchType' ty1 (TypeForall _ ty2) = matchType' ty1 ty2+matchType' _ _ = Nothing++-- The functions 'bindDecls', 'bindDecl', 'bindPatterns' and 'bindPattern'+-- augment the value environment with the types of the entities defined in+-- local declaration groups and patterns, respectively, using the types from+-- their type annotations.++bindDecls :: (Eq t, Typeable t, ValueType t) => [Decl t] -> ValueEnv -> ValueEnv+bindDecls = flip $ foldr bindDecl++bindDecl :: (Eq t, Typeable t, ValueType t) => Decl t -> ValueEnv -> ValueEnv+bindDecl d vEnv = bindLocalVars (filter unbound $ declVars d) vEnv+  where unbound v = null $ lookupValue (fst3 v) vEnv++bindPatterns :: (Eq t, Typeable t, ValueType t) => [Pattern t] -> ValueEnv+             -> ValueEnv+bindPatterns = flip $ foldr bindPattern++bindPattern :: (Eq t, Typeable t, ValueType t) => Pattern t -> ValueEnv+            -> ValueEnv+bindPattern t vEnv = bindLocalVars (filter unbound $ patternVars t) vEnv+  where unbound v = null $ lookupValue (fst3 v) vEnv++declVars :: (Eq t, Typeable t, ValueType t) => Decl t -> [(Ident, Int, t)]+declVars (InfixDecl        _ _ _ _) = []+declVars (TypeSig            _ _ _) = []+declVars (FunctionDecl  _ ty f eqs) = [(f, eqnArity $ head eqs, ty)]+declVars (PatternDecl        _ t _) = patternVars t+declVars (FreeDecl            _ vs) = [(v, 0, ty) | Var ty v <- vs]+declVars _                          = internalError "Base.Typing.declVars"++patternVars :: (Eq t, Typeable t, ValueType t) => Pattern t -> [(Ident, Int, t)]+patternVars (LiteralPattern         _ _ _) = []+patternVars (NegativePattern        _ _ _) = []+patternVars (VariablePattern       _ ty v) = [(v, 0, ty)]+patternVars (ConstructorPattern  _ _ _ ts) = concatMap patternVars ts+patternVars (InfixPattern     _ _ t1 _ t2) = patternVars t1 ++ patternVars t2+patternVars (ParenPattern             _ t) = patternVars t+patternVars (RecordPattern       _ _ _ fs) =+  concat [patternVars t | Field _ _ t <- fs]+patternVars (TuplePattern            _ ts) = concatMap patternVars ts+patternVars (ListPattern           _ _ ts) = concatMap patternVars ts+patternVars (AsPattern              _ v t) =+  (v, 0, toValueType $ typeOf t) : patternVars t+patternVars (LazyPattern              _ t) = patternVars t+patternVars (FunctionPattern     _ _ _ ts) = nub $ concatMap patternVars ts+patternVars (InfixFuncPattern _ _ t1 _ t2) =+  nub $ patternVars t1 ++ patternVars t2
+ src/Base/Utils.hs view
@@ -0,0 +1,94 @@+{- |+    Module      :  $Header$+    Description :  Auxiliary functions+    Copyright   :  (c) 2001 - 2003 Wolfgang Lux+                       2011 - 2015 Björn Peemöler+                       2016 - 2017 Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  fte@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+  ( fst3, snd3, thd3, curry3, uncurry3+  , (++!), foldr2, mapAccumM, findDouble, findMultiples+  ) where++import Control.Monad (MonadPlus, mzero, mplus)++import Data.List     (partition)++infixr 5 ++!++-- The Prelude does not contain standard functions for triples.+-- We provide projection, (un-)currying, and mapping for triples here.++fst3 :: (a, b, c) -> a+fst3 (x, _, _) = x++snd3 :: (a, b, c) -> b+snd3 (_, y, _) = y++thd3 :: (a, b, c) -> c+thd3 (_, _, z) = z++curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d+curry3 f x y z = f (x,y,z)++uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 f (x, y, z) = f x y z++-- 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)++mapAccumM :: (Monad m, MonadPlus p) => (acc -> x -> m (acc, y)) -> acc -> [x]+          -> m (acc, p y)+mapAccumM _ z [] = return (z, mzero)+mapAccumM f z (x:xs) = do+  (z', y) <- f z x+  (z'', ys) <- mapAccumM f z' xs+  return (z'', return y `mplus` ys)++-- 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
− src/CaseCompletion.hs 
@@ -1,662 +0,0 @@---------------------------------------------------------------------------------------------------------------------------------------------------------------------- CaseCompletion - expands case branches with missing constructors------ The MMC translates case expressions into the intermediate language--- representation (IL) without completing them (i.e. without generating--- case branches for missing contructors). Because they are necessary for--- the PAKCS back end this module expands all case expressions accordingly.------ May 2005,--- Martin Engelke, (men@informatik.uni-kiel.de)--- -module CaseCompletion (completeCase) where--import Data.Maybe--import Curry.Base.Position (SrcRef)-import Curry.Base.Ident-import qualified Curry.Syntax--import Base (ModuleEnv, lookupModule)-import IL.Type-import OldScopeEnv -- as ScopeEnv-import IL.Scope--------------------------------------------------------------------------------------- Completes case expressions by adding branches for missing constructors.--- The module environment 'menv' is needed to compute these constructors.------ Call:---      completeCase <module environment>---                   <IL module>----completeCase :: ModuleEnv -> Module -> Module-completeCase menv mod = let (mod', _) = visitModule menv mod in mod'------------------------------------------------------------------------------------- The following functions run through an IL term searching for--- case expressions-----visitModule :: ModuleEnv -> Module -> (Module, [Message])-visitModule menv (Module mident imports decls)-   = ((Module mident (insertUnique preludeMIdent imports) decls'), msgs')- where-   (decls', msgs') = visitList (visitDecl (Module mident imports decls) menv)-		               insertDeclScope-			       []-			       (getModuleScope (Module mident imports decls))-			       decls------visitDecl :: Module -> ModuleEnv -> [Message] -> ScopeEnv -> Decl-	     -> (Decl, [Message])-visitDecl mod menv msgs senv (DataDecl qident arity cdecls)-   = ((DataDecl qident arity cdecls), msgs)--visitDecl mod menv msgs senv (NewtypeDecl qident arity cdecl)-   = ((NewtypeDecl qident arity cdecl), msgs)--visitDecl mod menv msgs senv (FunctionDecl qident params typeexpr expr)-   = ((FunctionDecl qident params typeexpr expr'), msgs)- where-   (expr', _, _) = visitExpr mod menv msgs (insertExprScope senv expr) expr--visitDecl mod menv msgs senv (ExternalDecl qident cconv name typeexpr)-   = ((ExternalDecl qident cconv name typeexpr), msgs)------visitExpr :: Module -> ModuleEnv -> [Message] -> ScopeEnv -> Expression -	     -> (Expression, [Message],ScopeEnv)-visitExpr mod menv msgs senv (Literal lit) -   = ((Literal lit), msgs, senv)--visitExpr mod menv msgs senv (Variable ident) -   = ((Variable ident), msgs, senv)--visitExpr mod menv msgs senv (Function qident arity) -   = ((Function qident arity), msgs, senv)--visitExpr mod menv msgs senv (Constructor qident arity)-   = ((Constructor qident arity), msgs, senv)--visitExpr mod menv msgs senv (Apply expr1 expr2)-   = ((Apply expr1' expr2'), msgs2, senv2)- where-   (expr1', msgs1, senv1) = visitExpr mod menv msgs (insertExprScope senv expr1) expr1-   (expr2', msgs2, senv2) = visitExpr mod menv msgs1 (insertExprScope senv1 expr2) expr2--visitExpr mod menv msgs senv (Case r evalannot expr alts)-   | null altsR-     = intError "visitExpr" "empty alternative list"-   | evalannot == Flex   -- pattern matching causes flexible case expressions-     = (Case r evalannot expr' altsR, msgs, senv1)-   | isConstrAlt altR-     = (expr2, msgs3, senv3)-   | isLitAlt altR-     = (completeLitAlts r evalannot expr' altsR, msgs3, senv2)-   | isVarAlt altR-     = (completeVarAlts expr' altsR, msgs3, senv2)-   | otherwise -     = intError "visitExpr" "illegal alternative list"- where-   altR           = head altsR-   (expr', _, senv1) = visitExpr mod menv msgs (insertExprScope senv expr) expr-   (alts', _, senv2) = visitListWithEnv (visitAlt mod menv) insertAltScope msgs senv1 alts-   (altsR, msgs3) = removeRedundantAlts msgs alts'-   (expr2, senv3) = completeConsAlts r mod menv senv2 evalannot expr' altsR--visitExpr mod menv msgs senv (Or expr1 expr2)-   = ((Or expr1' expr2'), msgs2, senv3)- where-   (expr1', msgs1, senv2) = visitExpr mod menv msgs (insertExprScope senv expr1) expr1-   (expr2', msgs2, senv3) = visitExpr mod menv msgs1 (insertExprScope senv2 expr2) expr2--visitExpr mod menv msgs senv (Exist ident expr)-   = ((Exist ident expr'), msgs', senv2)- where-   (expr', msgs', senv2) = visitExpr mod menv msgs (insertExprScope senv expr) expr--visitExpr mod menv msgs senv (Let bind expr)-   = ((Let bind' expr'), msgs2, senv3)- where-   (expr', _, senv2) = visitExpr mod menv msgs (insertExprScope senv expr) expr-   (bind', msgs2, senv3) = visitBinding mod menv msgs (insertBindingScope senv2 bind) bind--visitExpr mod menv msgs senv (Letrec binds expr)-   = ((Letrec binds' expr'), msgs2, senv3)- where-   (expr', msgs1, senv2)  = visitExpr mod menv msgs (insertExprScope senv expr) expr-   (binds', msgs2, senv3) = visitListWithEnv (visitBinding mod menv)-		               const-			       msgs1-			       (foldl insertBindingScope senv2 binds)-			       binds------visitAlt :: Module -> ModuleEnv -> [Message] -> ScopeEnv -> Alt -	    -> (Alt, [Message], ScopeEnv)-visitAlt mod menv msgs senv (Alt pattern expr)-   = ((Alt pattern expr'), msgs', senv2)- where-   (expr', msgs', senv2) = visitExpr mod menv msgs (insertExprScope senv expr) expr------visitBinding :: Module -> ModuleEnv -> [Message] -> ScopeEnv -> Binding -	        -> (Binding, [Message], ScopeEnv)-visitBinding mod menv msgs senv (Binding ident expr)-   = ((Binding ident expr'), msgs', senv2)- where-   (expr', msgs', senv2) = visitExpr mod menv msgs (insertExprScope senv expr) expr------visitList :: ([Message] -> ScopeEnv -> a -> (a, [Message]))-	     -> (ScopeEnv -> a -> ScopeEnv)-	     -> [Message] -> ScopeEnv -> [a]-	     -> ([a], [Message])-visitList visitTerm insertScope msgs senv []-   = ([], msgs)-visitList visitTerm insertScope msgs senv (term:terms)-   = ((term':terms'), msgs2)- where-   (term', msgs1)  = visitTerm msgs (insertScope senv term) term-   (terms', msgs2) = visitList visitTerm insertScope msgs1 senv terms--visitListWithEnv :: ([Message] -> ScopeEnv -> a -> (a, [Message], ScopeEnv))-	     -> (ScopeEnv -> a -> ScopeEnv)-	     -> [Message] -> ScopeEnv -> [a]-	     -> ([a], [Message], ScopeEnv)-visitListWithEnv visitTerm insertScope msgs senv []-   = ([], msgs, senv)-visitListWithEnv visitTerm insertScope msgs senv (term:terms)-   = ((term':terms'), msgs2, senv3)- where-   (term', msgs1, senv2)  = visitTerm msgs (insertScope senv term) term-   (terms', msgs2, senv3) = visitListWithEnv visitTerm insertScope msgs1 senv2 terms-------------------------------------------------------------------------------------------------------------------------------------------------------------------- Functions for completing case alternatives---- Completes a case alternative list which branches via constructor patterns--- by adding alternatives of the form------      comp_pattern -> default_expr------ where "comp_pattern" is a complementary constructor pattern and--- "default_expr" is the expression from the first alternative containing--- a variable pattern. If there is no such alternative the defualt expression--- is set to the prelude function 'failed'.------ This funtions uses a scope environment ('ScopeEnv') to generate fresh--- variables for the arguments of the new constructors.----completeConsAlts :: SrcRef -> Module -> ModuleEnv -> ScopeEnv -		    -> Eval -> Expression -> [Alt]-		    -> (Expression, ScopeEnv)-completeConsAlts r mod menv senv evalannot expr alts-   = (Case r evalannot expr (alts1 ++ alts2), senv2)- where-   (Alt varpatt defaultexpr) = getDefaultAlt alts-   (VariablePattern varid)   = varpatt-   alts1       = filter isConstrAlt alts-   constrs     = (map p_getConsAltIdent alts1)-   cconsinfos  = getComplConstrs mod menv constrs-   (cconstrs,senv2) = -                 foldr p_genConstrTerm-                       ([],senv) -                       cconsinfos-   alts2       = map (\cconstr -> -		      (Alt cconstr -		        (replaceVar varid (cterm2expr cconstr) defaultexpr))) -		     cconstrs--   p_getConsAltIdent (Alt (ConstructorPattern qident _) _) = qident--   p_genConstrTerm (qident, arity) (cconstrs,senv3) =-       let args = OldScopeEnv.genIdentList arity "x" senv3-           senv4 = foldr OldScopeEnv.insertIdent senv3 args-       in (ConstructorPattern qident args : cconstrs, senv4)----- If the alternatives branches via literal pattern complementary--- constructor list cannot be generated because it would become infinite.--- So the function 'completeLitAlts' transforms case expressions like---      case <cexpr> of---        <lit_1> -> <expr_1>---        <lit_2> -> <expr_2>---                    :---        <lit_n> -> <expr_n>---       [<var>   -> <default_expr>]--- to ---      case (<cexpr> == <lit_1>) of---        True  -> <expr_1>---        False -> case (<cexpr> == <lit_2>) of---                   True  -> <expr_2>---                   False -> case ...---                                  :---                               -> case (<cexpr> == <lit_n>) of---                                    True  -> <expr_n>---                                    False -> <default_expr>----completeLitAlts :: SrcRef -> Eval -> Expression -> [Alt] -> Expression-completeLitAlts r evalannot expr [] = failedExpr-completeLitAlts r evalannot expr (alt:alts)-   | isLitAlt alt -     = (Case r evalannot -	     (eqExpr expr (p_makeLitExpr alt))-	     [(Alt truePatt  (getAltExpr alt)),-	      (Alt falsePatt (completeLitAlts r evalannot expr alts))])-   | otherwise-     = case alt of-         Alt (VariablePattern v) expr'-	   -> replaceVar v expr expr'-	 _ -> intError "completeLitAlts" "illegal alternative"- where-   p_makeLitExpr alt-      = case (getAltPatt alt) of-	  LiteralPattern lit -> Literal lit-	  _                  -> intError "completeLitAlts" -				         "literal pattern expected"----- For the unusual case of having only one alternative containing a variable--- pattern it is necessary to tranform it to a 'let' term because FlatCurry--- does not support variable patterns in case alternatives. So the--- case expression---      case <ce> of ---        x -> <expr>--- is transformed ot---      let x = <ce> in <expr>-completeVarAlts :: Expression -> [Alt] -> Expression-completeVarAlts expr [] = failedExpr-completeVarAlts expr (alt:_)-   = (Let (Binding (p_getVarIdent alt) expr) (getAltExpr alt))- where-   p_getVarIdent alt-      = case (getAltPatt alt) of-	  VariablePattern ident -> ident-	  _                     -> intError "completeVarAlts" -				            "variable pattern expected"------------------------------------------------------------------------------------- The function 'removeRedundantAlts' removes case branches which are--- either idle (i.e. they will never be reached) or multiply declared.--- Note: unlike the PAKCS frontend MCC does not support warnings. So--- there will be no messages if alternatives have been removed.- -removeRedundantAlts :: [Message] -> [Alt] -> ([Alt], [Message])-removeRedundantAlts msgs alts-   = let-         (alts1, msgs1) = removeIdleAlts msgs alts-	 (alts2, msgs2) = removeMultipleAlts msgs1 alts1-     in-         (alts2, msgs2)----- An alternative is idle if it occurs anywehere behind another alternative --- which contains a variable pattern. Example:---    case x of---      (y:ys) -> e1---      z      -> e2---      []     -> e3--- Here all alternatives behind (z  -> e2) are idle and will be removed.-removeIdleAlts :: [Message] -> [Alt] -> ([Alt], [Message])-removeIdleAlts msgs alts -   | null alts2 = (alts1, msgs)-   | otherwise  = (alts1, msgs)- where-   (alts1, alts2) = splitAfter isVarAlt alts----- An alternative occures multiply if at least two alternatives--- use the same pattern. Example:---    case x of---      []     -> e1---      (y:ys) -> e2---      []     -> e3--- Here the last alternative occures multiply because its pattern is already--- used in the first alternative. All multiple alternatives will be--- removed except for the first occurrence.-removeMultipleAlts :: [Message] -> [Alt] -> ([Alt], [Message])-removeMultipleAlts msgs alts-   = p_remove msgs [] alts- where-   p_remove msgs altsR []     = ((reverse altsR), msgs)-   p_remove msgs altsR (alt:alts)-      | p_containsAlt alt altsR = p_remove msgs altsR alts-      | otherwise               = p_remove msgs (alt:altsR) alts--   p_containsAlt alt alts = any (p_eqAlt alt) alts--   p_eqAlt (Alt (LiteralPattern lit1) _) alt2-      = case alt2 of-	  (Alt (LiteralPattern lit2) _) -> lit1 == lit2-	  _                             -> False-   p_eqAlt (Alt (ConstructorPattern qident1 _) _) alt2-      = case alt2 of-	  (Alt (ConstructorPattern qident2 _) _) -> qident1 == qident2-	  _                                      -> False-   p_eqAlt (Alt (VariablePattern _) _) alt2-      = case alt2 of-	  (Alt (VariablePattern _) _) -> True-	  _                           -> False------------------------------------------------------------------------------------- Some functions for testing and extracting terms from case alternatives-----isVarAlt :: Alt -> Bool-isVarAlt alt = case (getAltPatt alt) of-	         VariablePattern _ -> True-		 _                 -> False-----isConstrAlt :: Alt -> Bool-isConstrAlt alt = case (getAltPatt alt) of-		    ConstructorPattern _ _ -> True-		    _                      -> False-----isLitAlt :: Alt -> Bool-isLitAlt alt = case (getAltPatt alt) of-	         LiteralPattern _ -> True-		 _                -> False------getAltExpr :: Alt -> Expression-getAltExpr (Alt _ expr) = expr------getAltPatt :: Alt -> ConstrTerm-getAltPatt (Alt cterm _) = cterm----- Note: the newly generated variable 'x!' is just a dummy and will never--- occur in the transformed program-getDefaultAlt :: [Alt] -> Alt-getDefaultAlt alts -   = fromMaybe (Alt (VariablePattern (mkIdent "x!")) failedExpr)-               (find isVarAlt alts)------------------------------------------------------------------------------------- This part of the module contains functions for replacing variables--- with expressions. This is necessary in the case of having a default --- alternative like---      v -> <expr>--- where the variable v occurs in the default expression <expr>. When--- building additional alternatives for this default expression the variable--- must be replaced with the newly generated constructors.---- Call:---      replaceVar <variable id>---                 <replace-with expression>---                 <replace-in expression>----replaceVar :: Ident -> Expression -> Expression -> Expression-replaceVar ident expr (Variable ident')-   | ident == ident' = expr-   | otherwise       = Variable ident'-replaceVar ident expr (Apply expr1 expr2)-   = Apply (replaceVar ident expr expr1) (replaceVar ident expr expr2)-replaceVar ident expr (Case r eval expr' alts)-   = Case r eval -          (replaceVar ident expr expr') -	  (map (replaceVarInAlt ident expr) alts)-replaceVar ident expr (Or expr1 expr2)-   = Or (replaceVar ident expr expr1) (replaceVar ident expr expr2)-replaceVar ident expr (Exist ident' expr')-   | ident == ident' = Exist ident' expr'-   | otherwise       = Exist ident' (replaceVar ident expr expr')-replaceVar ident expr (Let binding expr')-   | varOccursInBinding ident binding-     = Let binding expr'-   | otherwise-     = Let (replaceVarInBinding ident expr binding) -	   (replaceVar ident expr expr')-replaceVar ident expr (Letrec bindings expr')-   | any (varOccursInBinding ident) bindings-     = Letrec bindings expr'-   | otherwise-     = Letrec (map (replaceVarInBinding ident expr) bindings)-              (replaceVar ident expr expr')-replaceVar _ _ expr'-   = expr'------replaceVarInAlt :: Ident -> Expression -> Alt -> Alt-replaceVarInAlt ident expr (Alt patt expr')-   | varOccursInPattern ident patt -     = Alt patt expr'-   | otherwise -     = Alt patt (replaceVar ident expr expr')------replaceVarInBinding :: Ident -> Expression -> Binding -> Binding-replaceVarInBinding ident expr (Binding ident' expr')-   | ident == ident' = Binding ident' expr'-   | otherwise       = Binding ident' (replaceVar ident expr expr')------varOccursInPattern :: Ident -> ConstrTerm -> Bool-varOccursInPattern ident (VariablePattern ident')-   = ident == ident'-varOccursInPattern ident (ConstructorPattern _ idents)-   = elem ident idents-varOccursInPattern _ _-   = False------varOccursInBinding :: Ident -> Binding -> Bool-varOccursInBinding ident (Binding ident' _)-   = ident == ident'------------------------------------------------------------------------------------- The following functions generate several IL expressions and patterns-----failedExpr :: Expression-failedExpr = Function (qualifyWith preludeMIdent (mkIdent "failed")) 0-----eqExpr :: Expression -> Expression -> Expression-eqExpr e1 e2 = Apply-	         (Apply -		   (Function (qualifyWith preludeMIdent (mkIdent "==")) 2)-		   e1)-		 e2------truePatt :: ConstrTerm-truePatt = ConstructorPattern qTrueId []-----falsePatt :: ConstrTerm-falsePatt = ConstructorPattern qFalseId []------cterm2expr :: ConstrTerm -> Expression-cterm2expr (LiteralPattern lit) = Literal lit-cterm2expr (ConstructorPattern qident args)-   = p_genApplic (Constructor qident (length args)) args- where-   p_genApplic expr []     = expr-   p_genApplic expr (v:vs) = p_genApplic (Apply expr (Variable v)) vs-cterm2expr (VariablePattern ident) = Variable ident-------------------------------------------------------------------------------------- The folowing functions compute the missing constructors for generating--- new case alternatives---- Computes the complementary constructors for a list of constructors. All--- specified constructors must have the same type.--- This functions uses the module environment 'menv' which contains all known--- constructors, except for those which are declared in the module and--- except for the list constructors.------ Call:---      getComplConstr <IL module>---                     <module environment>---                     <list of (qualified) constructor ids>----getComplConstrs :: Module -> ModuleEnv -> [QualIdent] -> [(QualIdent, Int)]-getComplConstrs (Module mid _ decls) menv constrs-   | null constrs -     = intError "getComplConstrs" "empty constructor list"-   | cons == qNilId || cons == qConsId-     = getCC constrs [(qNilId, 0), (qConsId, 2)]-   | mid' == mid-     = getCCFromDecls mid constrs decls-   | otherwise-     = maybe [] -- error ...-             (getCCFromIDecls mid' constrs) -	     (lookupModule mid' menv)- where-   cons = head constrs--   mid' = fromMaybe mid (qualidMod cons)----- Find complementary constructors within the declarations of the--- current module-getCCFromDecls :: ModuleIdent -> [QualIdent] -> [Decl] -> [(QualIdent, Int)]-getCCFromDecls _ constrs decls-   = let-         cdecls = maybe [] -- error ...-		        p_extractConstrDecls-			(find (p_declaresConstr (head constrs)) decls)-	 cinfos = map p_getConstrDeclInfo cdecls-     in-         getCC constrs cinfos- where-   p_declaresConstr qident decl-      = case decl of-	  DataDecl _ _ cdecls   -> any (p_isConstrDecl qident) cdecls-	  NewtypeDecl _ _ cdecl -> p_isConstrDecl qident cdecl-	  _                     -> False--   p_isConstrDecl qident (ConstrDecl qid _) = qident == qid--   p_extractConstrDecls decl-      = case decl of-	  DataDecl _ _ cdecls   -> cdecls-	  _                     -> []--   p_getConstrDeclInfo (ConstrDecl qident types) = (qident, length types)----- Find complementary constructors within the module environment-getCCFromIDecls :: ModuleIdent -> [QualIdent] -> [Curry.Syntax.IDecl] -		   -> [(QualIdent, Int)]-getCCFromIDecls mident constrs idecls-   = let-         cdecls = maybe [] -- error ...-		        p_extractIConstrDecls-		        (find (p_declaresIConstr (head constrs)) idecls)-	 cinfos = map (p_getIConstrDeclInfo mident) cdecls-     in-         getCC constrs cinfos- where-   p_declaresIConstr qident idecl-      = case idecl of-	  Curry.Syntax.IDataDecl _ _ _ cdecls-	      -> any (p_isIConstrDecl qident) -		     (map fromJust (filter isJust cdecls))-	  Curry.Syntax.INewtypeDecl _ _ _ ncdecl -	      -> p_isINewConstrDecl qident ncdecl-	  _   -> False--   p_isIConstrDecl qident (Curry.Syntax.ConstrDecl _ _ ident _)-      = (unqualify qident) == ident-   p_isIConstrDecl qident (Curry.Syntax.ConOpDecl _ _ _ ident _)-      = (unqualify qident) == ident--   p_isINewConstrDecl qident (Curry.Syntax.NewConstrDecl _ _ ident _)-      = (unqualify qident) == ident--   p_extractIConstrDecls idecl-      = case idecl of-	  Curry.Syntax.IDataDecl _ _ _ cdecls -	      -> map fromJust (filter isJust cdecls)-	  _   -> []--   p_getIConstrDeclInfo mid (Curry.Syntax.ConstrDecl _ _ ident types)-      = (qualifyWith mid ident, length types)-   p_getIConstrDeclInfo mid (Curry.Syntax.ConOpDecl _ _ _ ident _)-      = (qualifyWith mid ident, 2)----- Compute complementary constructors-getCC :: [QualIdent] -> [(QualIdent, Int)] -> [(QualIdent, Int)]-getCC _ [] = []-getCC constrs ((qident,arity):cis)-   | any ((==) qident) constrs = getCC constrs cis-   | otherwise                 = (qident,arity):(getCC constrs cis)------------------------------------------------------------------------------------- Message handling--- Not in use in this version, but intended for further versions--type Message = String------------------------------------------------------------------------------------- Miscellaneous---- Splits a list behind the first element which satify 'cond'-splitAfter :: (a -> Bool) -> [a] -> ([a], [a])-splitAfter cond xs = p_splitAfter cond [] xs- where-   p_splitAfter c fs []     = ((reverse fs),[])-   p_splitAfter c fs (l:ls) | c l       = ((reverse (l:fs)), ls)-			    | otherwise = p_splitAfter c (l:fs) ls----- Returns the first element which satisfy 'cond'. The returned element is--- embedded in a 'Maybe' term-find :: (a -> Bool) -> [a] -> Maybe a-find _    []     = Nothing-find cond (x:xs) | cond x    = Just x-		 | otherwise = find cond xs----- Prefixes an element to a list if it does not already exit within the--- list-insertUnique :: Eq a => a -> [a] -> [a]-insertUnique x xs | elem x xs = xs-		  | otherwise = x:xs----- Raises an internal error-intError :: String -> String -> a-intError fun msg = error ("CaseCompletion." ++ fun ++ " - " ++ msg)------------------------------------------------------------------------------------------------------------------------------------------------------------------
+ src/Checks.hs view
@@ -0,0 +1,161 @@+{- |+    Module      :  $Header$+    Description :  Different checks on a Curry module+    Copyright   :  (c) 2011 - 2013 Björn Peemöller+                       2016 - 2017 Finn Teegen+    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.InstanceCheck     as INC (instanceCheck)+import qualified Checks.InterfaceCheck    as IC  (interfaceCheck)+import qualified Checks.ImportSyntaxCheck as ISC (importCheck)+import qualified Checks.DeriveCheck       as DC  (deriveCheck)+import qualified Checks.ExportCheck       as EC  (exportCheck, expandExports)+import qualified Checks.ExtensionCheck    as EXC (extensionCheck)+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.TypeSyntaxCheck   as TSC (typeSyntaxCheck)+import qualified Checks.WarnCheck         as WC  (warnCheck)++import Curry.Base.Monad+import Curry.Syntax (Module (..), Interface (..), ImportSpec)++import Base.Messages+import Base.Types++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) (classEnv env)+                                 (instEnv 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 for enabled language extensions.+--+-- * Declarations: remain unchanged+-- * Environment:  The enabled language extensions are updated+extensionCheck :: Monad m => Check m (Module a)+extensionCheck opts (env, mdl)+  | null msgs = ok (env { extensions = exts }, mdl)+  | otherwise = failMessages msgs+  where (exts, msgs) = EXC.extensionCheck opts mdl++-- |Check the type syntax of type definitions and signatures.+--+-- * Declarations: Nullary type constructors and type variables are+--                 disambiguated+-- * Environment:  remains unchanged+typeSyntaxCheck :: Monad m => Check m (Module a)+typeSyntaxCheck _ (env, mdl)+  | null msgs = ok (env, mdl')+  | otherwise = failMessages msgs+  where (mdl', msgs) = TSC.typeSyntaxCheck (tyConsEnv env) mdl++-- |Check the kinds of type definitions and signatures.+--+-- * Declarations: remain unchanged+-- * Environment:  The type constructor and class environment are updated+kindCheck :: Monad m => Check m (Module a)+kindCheck _ (env, mdl)+  | null msgs = ok (env { tyConsEnv = tcEnv', classEnv = clsEnv' }, mdl)+  | otherwise = failMessages msgs+  where ((tcEnv', clsEnv'), msgs) = KC.kindCheck (tyConsEnv env) (classEnv 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 _ (env, mdl)+  | null msgs = ok (env { extensions = exts }, mdl')+  | otherwise = failMessages msgs+  where ((mdl', exts), msgs) = SC.syntaxCheck (extensions env) (tyConsEnv env)+                                              (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 a)+precCheck _ (env, Module spi li ps m es is ds)+  | null msgs = ok (env { opPrecEnv = pEnv' }, Module spi li ps m es is ds')+  | otherwise = failMessages msgs+  where (ds', pEnv', msgs) = PC.precCheck (moduleIdent env) (opPrecEnv env) ds++-- |Check the deriving clauses.+--+-- * Declarations: remain unchanged+-- * Environment:  remain unchanged+deriveCheck :: Monad m => Check m (Module a)+deriveCheck _ (env, mdl) = case DC.deriveCheck (tyConsEnv env) mdl of+  msgs | null msgs -> ok (env, mdl)+       | otherwise -> failMessages msgs++-- |Check the instances.+--+-- * Declarations: remain unchanged+-- * Environment:  The instance environment is updated+instanceCheck :: Monad m => Check m (Module a)+instanceCheck _ (env, Module spi li ps m es is ds)+  | null msgs = ok (env { instEnv = inEnv' }, Module spi li ps m es is ds)+  | otherwise = failMessages msgs+  where (inEnv', msgs) = INC.instanceCheck (moduleIdent env) (tyConsEnv env)+                                           (classEnv env) (instEnv env) ds++-- |Apply the correct typing of the module.+--+-- * Declarations: Type annotations are added to all expressions.+-- * Environment:  The value environment is updated.+typeCheck :: Monad m => Options -> CompEnv (Module a)+          -> CYT m (CompEnv (Module PredType))+typeCheck _ (env, Module spi li ps m es is ds)+  | null msgs = ok (env { valueEnv = vEnv' }, Module spi li ps m es is ds')+  | otherwise = failMessages msgs+  where (ds', vEnv', msgs) = TC.typeCheck (moduleIdent env) (tyConsEnv env)+                                          (valueEnv env) (classEnv env)+                                          (instEnv env) ds++-- |Check the export specification+exportCheck :: Monad m => Check m (Module a)+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 a) -> m (CompEnv (Module a))+expandExports _ (env, Module spi li ps m es is ds)+  = return (env, Module spi li 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 a -> [Message]+warnCheck opts env mdl = WC.warnCheck (optWarnOpts opts) (optCaseMode opts)+  (aliasEnv env) (valueEnv env) (tyConsEnv env) (classEnv env) mdl
+ src/Checks/DeriveCheck.hs view
@@ -0,0 +1,111 @@+{- |+    Module      :  $Header$+    Description :  Checks deriving clauses+    Copyright   :  (c)        2016 Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++   Before entering derived instances into the instance environment, the+   compiler has to ensure that it is not asked for other instances than+   those of supported type classes.+-}+module Checks.DeriveCheck (deriveCheck) where++import Curry.Base.Ident+import Curry.Base.Pretty+import Curry.Base.SpanInfo (HasSpanInfo)+import Curry.Syntax++import Base.Messages (Message, spanInfoMessage)++import Env.TypeConstructor++deriveCheck :: TCEnv -> Module a -> [Message]+deriveCheck tcEnv (Module _ _ _ m _ _ ds) = concatMap (checkDecl m tcEnv) ds++-- No instances can be derived for abstract data types as well as for+-- existential data types.++checkDecl :: ModuleIdent -> TCEnv -> Decl a -> [Message]+checkDecl m tcEnv (DataDecl   _ tc _ cs clss)+  | null clss                       = []+  | null cs                         = [errNoAbstractDerive tc]+  | otherwise                       = concatMap (checkDerivable m tcEnv cs) clss+checkDecl m tcEnv (NewtypeDecl _ _ _ nc clss) =+  concatMap (checkDerivable m tcEnv [toConstrDecl nc]) clss+checkDecl _ _     _                           = []++checkDerivable :: ModuleIdent -> TCEnv -> [ConstrDecl] -> QualIdent -> [Message]+checkDerivable m tcEnv cs cls+  | ocls == qEnumId && not (isEnum cs)       = [errNotEnum cls]+  | ocls == qBoundedId && not (isBounded cs) = [errNotBounded cls]+  | ocls `notElem` derivableClasses          = [errNotDerivable cls]+  | ocls == qDataId                          = [errNoDataDerive cls]+  | otherwise                                = []+  where ocls = getOrigName m cls tcEnv++derivableClasses :: [QualIdent]+derivableClasses = [qEqId, qOrdId, qEnumId, qBoundedId, qReadId, qShowId, qDataId]++-- Instances of 'Enum' can be derived only for enumeration types, i.e., types+-- where all data constructors are constants.++isEnum :: [ConstrDecl] -> Bool+isEnum = all ((0 ==) . constrArity)++-- Instances of 'Bounded' can be derived only for enumerations and for single+-- constructor types.++isBounded :: [ConstrDecl] -> Bool+isBounded cs = length cs == 1 || isEnum cs++-- ---------------------------------------------------------------------------+-- Auxiliary functions+-- ---------------------------------------------------------------------------++toConstrDecl :: NewConstrDecl -> ConstrDecl+toConstrDecl (NewConstrDecl p c      ty) = ConstrDecl p c [ty]+toConstrDecl (NewRecordDecl p c (l, ty)) =+  RecordDecl p c [FieldDecl p [l] ty]++constrArity :: ConstrDecl -> Int+constrArity (ConstrDecl  _ _ tys) = length tys+constrArity (ConOpDecl   _ _ _ _) = 2+constrArity c@(RecordDecl  _ _ _) = length $ recordLabels c++-- ---------------------------------------------------------------------------+-- Error messages+-- ---------------------------------------------------------------------------++errNoAbstractDerive :: HasSpanInfo a => a -> Message+errNoAbstractDerive s = spanInfoMessage s $+  text "Instances can only be derived for data types with" <+>+  text "at least one constructor"++errNotDerivable :: QualIdent -> Message+errNotDerivable cls = spanInfoMessage cls $ hsep $ map text+  ["Instances of type class", escQualName cls, "cannot be derived"]++errNoDataDerive :: QualIdent -> Message+errNoDataDerive qcls = spanInfoMessage qcls $ hsep $ map text+  [ "Instances of type class"+  , escQualName qcls+  , "are automatically derived if possible"+  ]++errNotEnum :: QualIdent -> Message+errNotEnum qcls = spanInfoMessage qcls $ hsep $ map text+  [ "Instances of type class"+  , escQualName qcls+  , "can be derived only for enumeration types"+  ]++errNotBounded :: QualIdent -> Message+errNotBounded qcls = spanInfoMessage qcls $ hsep $ map text+  [ "Instances of type class"+  , escQualName qcls+  , "can be derived only for enumeration and single constructor types"+  ]
+ src/Checks/ExportCheck.hs view
@@ -0,0 +1,500 @@+{- |+    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+                       2016        Finn Teegen+    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__ >= 804+import Prelude hiding ((<>))+#endif++#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.SpanInfo+import Curry.Base.Pretty+import Curry.Syntax++import Base.Messages       (Message, internalError, spanInfoMessage)+import Base.TopEnv         (allEntities, origName, localBindings, moduleImports)+import Base.Types          ( Type (..), unapplyType, arrowBase, PredType (..)+                           , DataConstr (..), constrIdent, recLabels+                           , ClassMethod, methodName+                           , TypeScheme (..), rawType, rootOfType )+import Base.Utils          (findMultiples)++import Env.ModuleAlias     (AliasEnv)+import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTypeInfoUnique)+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 (exportSpan spec) es+  where+  exportSpan (Just (Exporting spi _)) = spi+  exportSpan Nothing                  = NoSpanInfo++  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 qualLookupTypeInfoUnique m tc tcEnv of+    []  -> checkThing' tc Nothing+    [t] -> checkThing' tc (Just [ExportTypeWith NoSpanInfo (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  _ _ _ (ForAll _ (PredType _ ty))) = getTc' ty+  getTc (NewtypeConstructor _ _ (ForAll _ (PredType _ ty))) = getTc' ty+  getTc (Label _ _ (ForAll _ (PredType _ (TypeArrow tc' _)))) =+    let (TypeConstructor tc, _) = unapplyType False tc' in 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 qualLookupTypeInfoUnique m tc tcEnv of+    []                   -> report (errUndefinedTypeOrClass tc)+    [DataType _ _ cs]    ->+      mapM_ (checkElement errUndefinedElement (visibleElems cs )) xs'+    [RenamingType _ _ c] ->+      mapM_ (checkElement errUndefinedElement (visibleElems [c])) xs'+    [TypeClass   _ _ ms] ->+      mapM_ (checkElement errUndefinedMethod (visibleMethods ms)) xs'+    [_]                  -> report (errNonDataTypeOrTypeClass tc)+    ts                   -> report (errAmbiguousType tc ts)+  where+  xs' = nub xs+  -- check if given identifier is constructor/label/method of type/class tc+  checkElement err cs' c = unless (c `elem` cs') $ report $ err tc c++-- |Check type constructor with all data constructors and record labels.+checkTypeAll :: QualIdent -> ECM ()+checkTypeAll tc = do+  m     <- getModuleIdent+  tcEnv <- getTyConsEnv+  case qualLookupTypeInfoUnique m tc tcEnv of+    []                   -> report (errUndefinedTypeOrClass tc)+    [DataType     _ _ _] -> ok+    [RenamingType _ _ _] -> ok+    [TypeClass    _ _ _] -> ok+    [_]                  -> report (errNonDataTypeOrTypeClass 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 qualLookupTypeInfoUnique m tc tcEnv of+    []  -> expandThing' tc Nothing+    [t] -> expandThing' tc+             (Just [ExportTypeWith NoSpanInfo (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 NoSpanInfo (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 qualLookupTypeInfoUnique m tc tcEnv of+    [t] -> return [ExportTypeWith NoSpanInfo (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 qualLookupTypeInfoUnique 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 ]+    ++ [ exportLabel l' ty+         | (l, Label l' _ ty)  <- localBindings tyEnv, hasGlobalScope l ]+    ++ [ Export NoSpanInfo f'+         | (f, Value f' _ _ _) <- localBindings tyEnv, hasGlobalScope f ]++-- |Expand a module export+expandImportedModule :: ModuleIdent -> ECM [Export]+expandImportedModule m = do+  tcEnv <- getTyConsEnv+  tyEnv <- getValueEnv+  return $ [exportType t        | (_, t)             <- moduleImports m tcEnv]+        ++ [exportLabel l ty    | (_, Label l _ ty)  <- moduleImports m tyEnv]+        ++ [Export NoSpanInfo f | (_, Value f _ _ _) <- moduleImports m tyEnv]++exportType :: TypeInfo -> Export+exportType t = ExportTypeWith NoSpanInfo tc xs+  where tc = origName t+        xs = elements t++exportLabel :: QualIdent -> TypeScheme -> Export+exportLabel qid ty = case rawType ty of+  TypeArrow a _ -> ExportTypeWith NoSpanInfo (rootOfType a) [qidIdent qid]+  _             -> internalError $ "ExportCheck.exportLabel: " ++ show (qid, ty)++-- -----------------------------------------------------------------------------+-- 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 spi x)             =+  fromMaybe (Export spi x) (Map.lookup x ls)+canonExport _  (ExportTypeWith spi tc xs) = ExportTypeWith spi 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 NoSpanInfo 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 NoSpanInfo tc cs | (tc, cs) <- joinedTypes]+               ++ [Export NoSpanInfo 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    _ _ _ _) = []+elements (TypeClass     _ _ ms) = visibleMethods ms+elements (TypeVar            _) =+  error "Checks.ExportCheck.elements: type variable"++-- get visible constructor and label identifiers for given constructor+visibleElems :: [DataConstr] -> [Ident]+visibleElems cs = map constrIdent cs ++ (nub (concatMap recLabels cs))++-- get class method names+visibleMethods :: [ClassMethod] -> [Ident]+visibleMethods = map methodName++-- ---------------------------------------------------------------------------+-- 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 = spanInfoMessage 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 = spanInfoMessage 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) = spanInfoMessage i $+  text "Multiple exports of" <+> text what <+> text (escName i) <+> text "at:"+  $+$ nest 2 (vcat (map showPos (i:is)))+  where showPos = text . showLine . getPosition++errNonDataTypeOrTypeClass :: QualIdent -> Message+errNonDataTypeOrTypeClass tc = spanInfoMessage tc $ hsep $ map text+  [escQualName tc, "is not a data type or type class"]++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 = spanInfoMessage 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 = spanInfoMessage c $ hsep $ map text+  [ escName c, "is not a constructor or label of type", escQualName tc ]++errUndefinedMethod :: QualIdent -> Ident -> Message+errUndefinedMethod cls f = spanInfoMessage f $ hsep $ map text+  [ escName f, "is not a method of class", escQualName cls ]++errUndefinedName :: QualIdent -> Message+errUndefinedName = errUndefined "name"++errUndefinedTypeOrClass :: QualIdent -> Message+errUndefinedTypeOrClass = errUndefined "type or class"++errUndefined :: String -> QualIdent -> Message+errUndefined what tc = spanInfoMessage tc $ hsep $ map text+  ["Undefined", what, escQualName tc, "in export list"]
+ src/Checks/ExtensionCheck.hs view
@@ -0,0 +1,72 @@+{- |+    Module      :  $Header$+    Description :  Checks extensions+    Copyright   :  (c)        2016 Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++   First of all, the compiler scans a source file for file-header pragmas+   that may activate language extensions.+-}+module Checks.ExtensionCheck (extensionCheck) where++import qualified Control.Monad.State as S (State, execState, modify)++import Curry.Base.SpanInfo+import Curry.Base.Pretty+import Curry.Syntax++import Base.Messages (Message, spanInfoMessage)++import CompilerOpts++extensionCheck :: Options -> Module a -> ([KnownExtension], [Message])+extensionCheck opts mdl = execEXC (checkModule mdl) initState+  where+    initState = EXCState (optExtensions opts) []++type EXCM = S.State EXCState++data EXCState = EXCState+  { extensions :: [KnownExtension]+  , errors     :: [Message]+  }++execEXC :: EXCM a -> EXCState -> ([KnownExtension], [Message])+execEXC ecm s =+  let s' = S.execState ecm s in (extensions s', reverse $ errors s')++enableExtension :: KnownExtension -> EXCM ()+enableExtension e = S.modify $ \s -> s { extensions = e : extensions s }++report :: Message -> EXCM ()+report msg = S.modify $ \s -> s { errors = msg : errors s }++ok :: EXCM ()+ok = return ()++-- The extension check iterates over all given pragmas in the module and+-- gathers all extensions mentioned in a language pragma. An error is reported+-- if an extension is unknown.++checkModule :: Module a -> EXCM ()+checkModule (Module _ _ ps _ _ _ _) = mapM_ checkPragma ps++checkPragma :: ModulePragma -> EXCM ()+checkPragma (LanguagePragma _ exts) = mapM_ checkExtension exts+checkPragma (OptionsPragma  _  _ _) = ok++checkExtension :: Extension -> EXCM ()+checkExtension (KnownExtension   _ e) = enableExtension e+checkExtension (UnknownExtension p e) = report $ errUnknownExtension p e++-- ---------------------------------------------------------------------------+-- Error messages+-- ---------------------------------------------------------------------------++errUnknownExtension :: SpanInfo -> String -> Message+errUnknownExtension p e = spanInfoMessage p $+  text "Unknown language extension:" <+> text e
+ src/Checks/ImportSyntaxCheck.hs view
@@ -0,0 +1,279 @@+{- |+    Module      :  $Header$+    Description :  Checking import specifications+    Copyright   :  (c) 2016       Jan Tikovsky+                       2016       Finn Teegen+    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.Base.SpanInfo+import Curry.Syntax hiding (Var (..))++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+               | Class QualIdent [Ident]+ deriving Show++instance Entity ITypeInfo where+  origName (Data  tc  _) = tc+  origName (Alias tc   ) = tc+  origName (Class cls _) = cls++  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 (Class cls1 ms1) (Class cls2 ms2)+    | cls1 == cls2 && (null ms1 || null ms2 || ms1 == ms2) =+        Just $ Class cls1 (if null ms1 then ms2 else ms1)+  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 (IClassDecl _ _ cls _ _ ms hs) = [Class cls (filter (`notElem` hs) xs)]+  where xs = map imethod ms+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 (IClassDecl _ _ cls _ _ ms hs) = midents cls (map imethod ms) hs+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+                   ]++midents :: QualIdent -> [Ident] -> [Ident] -> [IValueInfo]+midents cls fs hs = [Var (qualifyLike cls f) [] | f <- fs, f `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         spi x    ) =               expandThing    spi x+expandImport (ImportTypeWith spi tc cs) = (:[]) `liftM` expandTypeWith spi tc cs+expandImport (ImportTypeAll  spi tc   ) = (:[]) `liftM` expandTypeAll  spi tc++expandHiding :: Import -> ExpandM [Import]+expandHiding (Import         spi x    ) = expandHide spi x+expandHiding (ImportTypeWith spi tc cs) = (:[]) `liftM` expandTypeWith spi tc cs+expandHiding (ImportTypeAll  spi tc   ) = (:[]) `liftM` expandTypeAll  spi tc++-- try to expand as type constructor+expandThing :: SpanInfo -> Ident -> ExpandM [Import]+expandThing spi tc = do+  tcEnv <- getTyConsEnv+  case Map.lookup tc tcEnv of+    Just _  -> expandThing' spi tc $ Just [ImportTypeWith spi tc []]+    Nothing -> expandThing' spi tc Nothing++-- try to expand as function / data constructor+expandThing' :: SpanInfo -> Ident -> Maybe [Import] -> ExpandM [Import]+expandThing' spi 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 spi e]++  isConstr (Constr _) = True+  isConstr (Var  _ _) = False++-- try to hide as type constructor+expandHide :: SpanInfo -> Ident -> ExpandM [Import]+expandHide spi tc = do+  tcEnv <- getTyConsEnv+  case Map.lookup tc tcEnv of+    Just _  -> expandHide' spi tc $ Just [ImportTypeWith spi tc []]+    Nothing -> expandHide' spi tc Nothing++-- try to hide as function / data constructor+expandHide' :: SpanInfo -> Ident -> Maybe [Import] -> ExpandM [Import]+expandHide' spi f tcImport = do+  m     <- getModuleIdent+  tyEnv <- getValueEnv+  case Map.lookup f tyEnv of+    Just _  -> return $ Import spi f : fromMaybe [] tcImport+    Nothing -> case tcImport of+      Nothing -> report (errUndefinedEntity m f) >> return []+      Just tc -> return tc++expandTypeWith :: SpanInfo -> Ident -> [Ident] -> ExpandM Import+expandTypeWith spi tc cs = do+  m     <- getModuleIdent+  tcEnv <- getTyConsEnv+  ImportTypeWith spi tc `liftM` case Map.lookup tc tcEnv of+    Just (Data  _ xs) -> mapM (checkElement errUndefinedElement xs) cs+    Just (Class _ xs) -> mapM (checkElement errUndefinedMethod  xs) cs+    Just (Alias    _) -> report (errNonDataTypeOrTypeClass tc) >> return []+    Nothing           -> report (errUndefinedEntity      m tc) >> return []+  where+  -- check if given identifier is constructor or label of type tc+  checkElement err cs' c = do+    unless (c `elem` cs') $ report $ err tc c+    return c++expandTypeAll :: SpanInfo -> Ident -> ExpandM Import+expandTypeAll spi tc = do+  m     <- getModuleIdent+  tcEnv <- getTyConsEnv+  ImportTypeWith spi tc `liftM` case Map.lookup tc tcEnv of+    Just (Data _  xs) -> return xs+    Just (Class _ xs) -> return xs+    Just (Alias    _) -> report (errNonDataTypeOrTypeClass tc) >> return []+    Nothing           -> report (errUndefinedEntity      m tc) >> return []++-- error messages++errUndefinedElement :: Ident -> Ident -> Message+errUndefinedElement tc c = spanInfoMessage c $ hsep $ map text+  [ idName c, "is not a constructor or label of type ", idName tc ]++errUndefinedMethod :: Ident -> Ident -> Message+errUndefinedMethod cls f = spanInfoMessage f $ hsep $ map text+  [ idName f, "is not a method of class", idName cls ]++errUndefinedEntity :: ModuleIdent -> Ident -> Message+errUndefinedEntity m x = spanInfoMessage x $ hsep $ map text+  [ "Module", moduleName m, "does not export", idName x ]++errNonDataTypeOrTypeClass :: Ident -> Message+errNonDataTypeOrTypeClass tc = spanInfoMessage tc $ hsep $ map text+  [ idName tc, "is not a data type or type class" ]++errImportDataConstr :: ModuleIdent -> Ident -> Message+errImportDataConstr _ c = spanInfoMessage c $ hsep $ map text+  [ "Explicit import for data constructor", idName c ]
+ src/Checks/InstanceCheck.hs view
@@ -0,0 +1,414 @@+{- |+    Module      :  $Header$+    Description :  Checks instances+    Copyright   :  (c)        2016 Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++   Before type checking, the compiler checks for every instance declaration+   that all necessary super class instances exist. Furthermore, the compiler+   infers the contexts of the implicit instance declarations introduced by+   deriving clauses in data and newtype declarations. The instances declared+   explicitly and automatically derived by the compiler are added to the+   instance environment . It is also checked that there are no duplicate+   instances and that all types specified in a default declaration are+   instances of the Num class.+-}+module Checks.InstanceCheck (instanceCheck) where++import           Control.Monad.Extra        (concatMapM, whileM, unless)+import qualified Control.Monad.State as S   (State, execState, gets, modify)+import           Data.List                  (nub, partition, sortBy)+import qualified Data.Map            as Map+import qualified Data.Set.Extra      as Set++import Curry.Base.Ident+import Curry.Base.Pretty+import Curry.Base.SpanInfo+import Curry.Syntax hiding (impls)+import Curry.Syntax.Pretty++import Base.CurryTypes+import Base.Messages (Message, spanInfoMessage, message, internalError)+import Base.SCC (scc)+import Base.TypeExpansion+import Base.Types+import Base.TypeSubst+import Base.Utils (fst3, snd3, findMultiples)++import Env.Class+import Env.Instance+import Env.TypeConstructor++instanceCheck :: ModuleIdent -> TCEnv -> ClassEnv -> InstEnv -> [Decl a]+              -> (InstEnv, [Message])+instanceCheck m tcEnv clsEnv inEnv ds =+  case findMultiples (local ++ imported) of+    [] -> execINCM (checkDecls tcEnv clsEnv ds) state+    iss -> (inEnv, map (errMultipleInstances tcEnv) iss)+  where+    local = map (flip InstSource m) $ concatMap (genInstIdents m tcEnv) ds+    imported = map (uncurry InstSource . fmap fst3) $ Map.toList inEnv+    state = INCState m inEnv []++-- In order to provide better error messages, we use the following data type+-- to keep track of an instance's source, i.e., the module it was defined in.++data InstSource = InstSource InstIdent ModuleIdent++instance Eq InstSource where+  InstSource i1 _ == InstSource i2 _ = i1 == i2++-- |Instance Check Monad+type INCM = S.State INCState++-- |Internal state of the Instance Check+data INCState = INCState+  { moduleIdent :: ModuleIdent+  , instEnv     :: InstEnv+  , errors      :: [Message]+  }++execINCM :: INCM a -> INCState -> (InstEnv, [Message])+execINCM incm s =+  let s' = S.execState incm s in (instEnv s', reverse $ nub $ errors s')++getModuleIdent :: INCM ModuleIdent+getModuleIdent = S.gets moduleIdent++getInstEnv :: INCM InstEnv+getInstEnv = S.gets instEnv++modifyInstEnv :: (InstEnv -> InstEnv) -> INCM ()+modifyInstEnv f = S.modify $ \s -> s { instEnv = f $ instEnv s }++report :: Message -> INCM ()+report err = S.modify (\s -> s { errors = err : errors s })++ok :: INCM ()+ok = return ()++checkDecls :: TCEnv -> ClassEnv -> [Decl a] -> INCM ()+checkDecls tcEnv clsEnv ds = do+  mapM_ (bindInstance tcEnv clsEnv) ids+  mapM (declDeriveDataInfo tcEnv clsEnv) (filter isDataDecl tds) >>=+    mapM_ (bindDerivedInstances clsEnv) . groupDeriveInfos+  mapM (declDeriveInfo tcEnv clsEnv) (filter hasDerivedInstances tds) >>=+    mapM_ (bindDerivedInstances clsEnv) . groupDeriveInfos+  mapM_ (checkInstance tcEnv clsEnv) ids+  mapM_ (checkDefault tcEnv clsEnv) dds+  where (tds, ods) = partition isTypeDecl ds+        ids = filter isInstanceDecl ods+        dds = filter isDefaultDecl ods+        isDataDecl (DataDecl    _ _ _ _ _) = True+        isDataDecl (NewtypeDecl _ _ _ _ _) = True+        isDataDecl _                       = False++-- First, the compiler adds all explicit instance declarations to the+-- instance environment.++bindInstance :: TCEnv -> ClassEnv -> Decl a -> INCM ()+bindInstance tcEnv clsEnv (InstanceDecl _ _ cx qcls inst ds) = do+  m <- getModuleIdent+  let PredType ps _ = expandPolyType m tcEnv clsEnv $+                        QualTypeExpr NoSpanInfo cx inst+  modifyInstEnv $+    bindInstInfo (genInstIdent m tcEnv qcls inst) (m, ps, impls [] ds)+  where impls is [] = is+        impls is (FunctionDecl _ _ f eqs:ds')+          | f' `elem` map fst is = impls is ds'+          | otherwise            = impls ((f', eqnArity $ head eqs) : is) ds'+          where f' = unRenameIdent f+        impls _ _ = internalError "InstanceCheck.bindInstance.impls"+bindInstance _     _      _                                = ok++-- Next, the compiler sorts the data and newtype declarations with non-empty+-- deriving clauses into minimal binding groups and infers contexts for their+-- instance declarations. In the case of (mutually) recursive data types,+-- inference of the appropriate contexts may require a fixpoint calculation.++hasDerivedInstances :: Decl a -> Bool+hasDerivedInstances (DataDecl    _ _ _ _ clss) = not $ null clss+hasDerivedInstances (NewtypeDecl _ _ _ _ clss) = not $ null clss+hasDerivedInstances _                          = False++-- For the purposes of derived instances, a newtype declaration is treated+-- as a data declaration with a single constructor. The compiler also sorts+-- derived classes with respect to the super class hierarchy so that subclass+-- instances are added to the instance environment after their super classes.++data DeriveInfo = DeriveInfo SpanInfo QualIdent PredType [Type] [QualIdent]++declDeriveInfo :: TCEnv -> ClassEnv -> Decl a -> INCM DeriveInfo+declDeriveInfo tcEnv clsEnv (DataDecl p tc tvs cs clss) =+  mkDeriveInfo tcEnv clsEnv p tc tvs (concat tyss) clss+  where tyss = map constrDeclTypes cs+        constrDeclTypes (ConstrDecl     _ _ tys) = tys+        constrDeclTypes (ConOpDecl  _ ty1 _ ty2) = [ty1, ty2]+        constrDeclTypes (RecordDecl      _ _ fs) = tys+          where tys = [ty | FieldDecl _ ls ty <- fs, _ <- ls]+declDeriveInfo tcEnv clsEnv (NewtypeDecl p tc tvs nc clss) =+  mkDeriveInfo tcEnv clsEnv p tc tvs [nconstrType nc] clss+declDeriveInfo _ _ _ =+  internalError "InstanceCheck.declDeriveInfo: no data or newtype declaration"++declDeriveDataInfo :: TCEnv -> ClassEnv -> Decl a -> INCM DeriveInfo+declDeriveDataInfo tcEnv clsEnv (DataDecl p tc tvs cs _) =+  mkDeriveDataInfo tcEnv clsEnv p tc tvs (concat tyss)+  where tyss = map constrDeclTypes cs+        constrDeclTypes (ConstrDecl     _ _ tys) = tys+        constrDeclTypes (ConOpDecl  _ ty1 _ ty2) = [ty1, ty2]+        constrDeclTypes (RecordDecl      _ _ fs) = tys+          where tys = [ty | FieldDecl _ ls ty <- fs, _ <- ls]+declDeriveDataInfo tcEnv clsEnv (NewtypeDecl p tc tvs nc _) =+  mkDeriveDataInfo tcEnv clsEnv p tc tvs [nconstrType nc]+declDeriveDataInfo _ _ _ = internalError+  "InstanceCheck.declDeriveDataInfo: no data or newtype declaration"++mkDeriveInfo :: TCEnv -> ClassEnv -> SpanInfo -> Ident -> [Ident]+             -> [TypeExpr] -> [QualIdent] -> INCM DeriveInfo+mkDeriveInfo tcEnv clsEnv spi tc tvs tys clss = do+  m <- getModuleIdent+  let otc = qualifyWith m tc+      oclss = map (flip (getOrigName m) tcEnv) clss+      PredType ps ty = expandConstrType m tcEnv clsEnv otc tvs tys+      (tys', ty') = arrowUnapply ty+  return $ DeriveInfo spi otc (PredType ps ty') tys' $ sortClasses clsEnv oclss++mkDeriveDataInfo :: TCEnv -> ClassEnv -> SpanInfo -> Ident -> [Ident]+                 -> [TypeExpr] -> INCM DeriveInfo+mkDeriveDataInfo tcEnv clsEnv spi tc tvs tys = do+  m <- getModuleIdent+  let otc = qualifyWith m tc+      PredType ps ty = expandConstrType m tcEnv clsEnv otc tvs tys+      (tys', ty') = arrowUnapply ty+  return $ DeriveInfo spi otc (PredType ps ty') tys' [qDataId]++sortClasses :: ClassEnv -> [QualIdent] -> [QualIdent]+sortClasses clsEnv clss = map fst $ sortBy compareDepth $ map adjoinDepth clss+  where (_, d1) `compareDepth` (_, d2) = d1 `compare` d2+        adjoinDepth cls = (cls, length $ allSuperClasses cls clsEnv)++groupDeriveInfos :: [DeriveInfo] -> [[DeriveInfo]]+groupDeriveInfos = scc bound free+  where bound (DeriveInfo _ tc _ _ _) = [tc]+        free (DeriveInfo _ _ _ tys _) = concatMap typeConstrs tys++bindDerivedInstances :: ClassEnv -> [DeriveInfo] -> INCM ()+bindDerivedInstances clsEnv dis = unless (any hasDataFunType dis) $ do+  mapM_ (enterInitialPredSet clsEnv) dis+  whileM $ concatMapM (inferPredSets clsEnv) dis >>= updatePredSets+  where+    hasDataFunType (DeriveInfo _ _ _ tys clss) =+      clss == [qDataId] && any isFunType tys++enterInitialPredSet :: ClassEnv -> DeriveInfo -> INCM ()+enterInitialPredSet clsEnv (DeriveInfo spi tc pty _ clss) =+  mapM_ (bindDerivedInstance clsEnv spi tc pty) clss++-- Note: The methods and arities entered into the instance environment have+-- to match methods and arities of the later generated instance declarations.+-- TODO: Add remark about value environment entry++bindDerivedInstance :: HasSpanInfo s => ClassEnv -> s -> QualIdent -> PredType -> QualIdent+                    -> INCM ()+bindDerivedInstance clsEnv p tc pty cls = do+  m <- getModuleIdent+  ((i, ps), _) <- inferPredSet clsEnv p tc pty [] cls+  modifyInstEnv (bindInstInfo i (m, ps, impls))+  where impls | cls == qEqId      = [(eqOpId, 2)]+              | cls == qOrdId     = [(leqOpId, 2)]+              | cls == qEnumId    = [ (succId, 1), (predId, 1), (toEnumId, 1)+                                    , (fromEnumId, 1), (enumFromId, 1)+                                    , (enumFromThenId, 2)+                                    ]+              | cls == qBoundedId = [(maxBoundId, 0), (minBoundId, 0)]+              | cls == qReadId    = [(readsPrecId, 2)]+              | cls == qShowId    = [(showsPrecId, 2)]+              | cls == qDataId    = [(dataEqId, 2), (aValueId, 0)]+              | otherwise         =+                internalError "InstanceCheck.bindDerivedInstance.impls"++inferPredSets :: ClassEnv -> DeriveInfo -> INCM [((InstIdent, PredSet), Bool)]+inferPredSets clsEnv (DeriveInfo spi tc pty tys clss) =+  mapM (inferPredSet clsEnv spi tc pty tys) clss++inferPredSet :: HasSpanInfo s => ClassEnv -> s -> QualIdent -> PredType -> [Type]+             -> QualIdent -> INCM ((InstIdent, PredSet), Bool)+inferPredSet clsEnv p tc (PredType ps inst) tys cls = do+  m <- getModuleIdent+  let doc = ppPred m $ Pred cls inst+      sclss = superClasses cls clsEnv+      ps'   = Set.fromList [Pred cls ty | ty <- tys]+      ps''  = Set.fromList [Pred scls inst | scls <- sclss]+      ps''' = ps `Set.union` ps' `Set.union` ps''+  (ps4, novarps) <-+    reducePredSet (cls == qDataId) p "derived instance" doc clsEnv ps'''+  let ps5 = filter noPolyPred $ Set.toList ps4+  if any (isDataPred m) (Set.toList novarps ++ ps5) && cls == qDataId+    then return    (((cls, tc), ps4), False)+    else mapM_ (reportUndecidable p "derived instance" doc) ps5+         >> return (((cls, tc), ps4), True)+  where+    noPolyPred (Pred _ (TypeVariable _)) = False+    noPolyPred (Pred _ _               ) = True+    isDataPred _ (Pred qid _) = qid == qDataId++updatePredSets :: [((InstIdent, PredSet), Bool)] -> INCM Bool+updatePredSets = fmap or . mapM (uncurry updatePredSet)++updatePredSet :: (InstIdent, PredSet) -> Bool -> INCM Bool+updatePredSet (i, ps) enter = do+  inEnv <- getInstEnv+  case lookupInstInfo i inEnv of+    Just (m, ps', is)+      | not enter -> modifyInstEnv (removeInstInfo i) >> return False+      | ps == ps' -> return False+      | otherwise -> do+        modifyInstEnv $ bindInstInfo i (m, ps, is)+        return True+    Nothing -> internalError "InstanceCheck.updatePredSet"++reportUndecidable :: HasSpanInfo s => s -> String -> Doc -> Pred -> INCM ()+reportUndecidable p what doc predicate@(Pred _ ty) = do+  m <- getModuleIdent+  case ty of+    TypeVariable _ -> return ()+    _ -> report $ errMissingInstance m p what doc predicate++-- Then, the compiler checks the contexts of all explicit instance+-- declarations to detect missing super class instances. For an instance+-- declaration+--+-- instance cx => C (T u_1 ... u_k) where ...+--+-- the compiler ensures that T is an instance of all of C's super classes+-- and also that the contexts of the corresponding instance declarations are+-- satisfied by cx.++checkInstance :: TCEnv -> ClassEnv -> Decl a -> INCM ()+checkInstance tcEnv clsEnv (InstanceDecl _ _ cx cls inst _) = do+  m <- getModuleIdent+  let PredType ps ty = expandPolyType m tcEnv clsEnv $+                         QualTypeExpr NoSpanInfo cx inst+      ocls = getOrigName m cls tcEnv+      ps' = Set.fromList [ Pred scls ty | scls <- superClasses ocls clsEnv ]+      doc = ppPred m $ Pred cls ty+      what = "instance declaration"+  (ps'', _) <- reducePredSet False inst what doc clsEnv ps'+  Set.mapM_ (report . errMissingInstance m inst what doc) $+    ps'' `Set.difference` maxPredSet clsEnv ps+checkInstance _ _ _ = ok++-- All types specified in the optional default declaration of a module+-- must be instances of the Num class. Since these types are used to resolve+-- ambiguous type variables, the predicate sets of the respective instances+-- must be empty.++checkDefault :: TCEnv -> ClassEnv -> Decl a -> INCM ()+checkDefault tcEnv clsEnv (DefaultDecl _ tys) =+  mapM_ (checkDefaultType tcEnv clsEnv) tys+checkDefault _ _ _ = ok++checkDefaultType :: TCEnv -> ClassEnv -> TypeExpr -> INCM ()+checkDefaultType tcEnv clsEnv ty = do+  m <- getModuleIdent+  let PredType _ ty' = expandPolyType m tcEnv clsEnv $+                         QualTypeExpr NoSpanInfo [] ty+  (ps, _) <- reducePredSet False ty what empty clsEnv+    (Set.singleton $ Pred qNumId ty')+  Set.mapM_ (report . errMissingInstance m ty what empty) ps+  where what = "default declaration"++-- The function 'reducePredSet' simplifies a predicate set of the form+-- (C_1 tau_1,..,C_n tau_n) where the tau_i are arbitrary types into a+-- predicate set where all predicates are of the form C u with u being+-- a type variable. An error is reported if the predicate set cannot+-- be transformed into this form. In addition, we remove all predicates+-- that are implied by others within the same set.+-- When the flag is set, all missing Data preds are ignored++reducePredSet :: HasSpanInfo s => Bool -> s -> String -> Doc -> ClassEnv -> PredSet+              -> INCM (PredSet, PredSet)+reducePredSet b p what doc clsEnv ps = do+  m <- getModuleIdent+  inEnv <- getInstEnv+  let (ps1, ps2) = partitionPredSet $ minPredSet clsEnv $ reducePreds inEnv ps+      ps2' = if b then Set.filter (isNotDataPred m) ps2 else ps2+  Set.mapM_ (reportMissing m) ps2' >> return (ps1, ps2)+  where+    isNotDataPred _ (Pred qid _) = qid /= qDataId+    reportMissing m pr@(Pred _ _) =+      report $ errMissingInstance m p what doc pr+    reducePreds inEnv = Set.concatMap $ reducePred inEnv+    reducePred inEnv predicate = maybe (Set.singleton predicate)+                                       (reducePreds inEnv)+                                       (instPredSet inEnv predicate)++instPredSet :: InstEnv -> Pred -> Maybe PredSet+instPredSet inEnv (Pred qcls ty) =+  case unapplyType False ty of+    (TypeConstructor tc, tys) ->+      fmap (expandAliasType tys . snd3) (lookupInstInfo (qcls, tc) inEnv)+    _ -> Nothing++-- ---------------------------------------------------------------------------+-- Auxiliary definitions+-- ---------------------------------------------------------------------------++genInstIdents :: ModuleIdent -> TCEnv -> Decl a -> [InstIdent]+genInstIdents m tcEnv (DataDecl    _ tc _ _ qclss) =+  map (flip (genInstIdent m tcEnv) $ ConstructorType NoSpanInfo $ qualify tc)+      qclss+genInstIdents m tcEnv (NewtypeDecl _ tc _ _ qclss) =+  map (flip (genInstIdent m tcEnv) $ ConstructorType NoSpanInfo $ qualify tc)+      qclss+genInstIdents m tcEnv (InstanceDecl _ _ _ qcls ty _) =+  [genInstIdent m tcEnv qcls ty]+genInstIdents _ _     _                            = []++genInstIdent :: ModuleIdent -> TCEnv -> QualIdent -> TypeExpr -> InstIdent+genInstIdent m tcEnv qcls = qualInstIdent m tcEnv . (,) qcls . typeConstr++-- When qualifiying an instance identifier, we replace both the class and+-- type constructor with their original names as found in the type constructor+-- environment.++qualInstIdent :: ModuleIdent -> TCEnv -> InstIdent -> InstIdent+qualInstIdent m tcEnv (cls, tc) = (qual cls, qual tc)+  where+    qual = flip (getOrigName m) tcEnv++unqualInstIdent :: TCEnv -> InstIdent -> InstIdent+unqualInstIdent tcEnv (qcls, tc) = (unqual qcls, unqual tc)+  where+    unqual = head . flip reverseLookupByOrigName tcEnv++isFunType :: Type -> Bool+isFunType (TypeArrow         _ _) = True+isFunType (TypeApply       t1 t2) = isFunType t1 || isFunType t2+isFunType (TypeForall      _  ty) = isFunType ty+isFunType (TypeConstrained tys _) = any isFunType tys+isFunType _                       = False++-- ---------------------------------------------------------------------------+-- Error messages+-- ---------------------------------------------------------------------------++errMultipleInstances :: TCEnv -> [InstSource] -> Message+errMultipleInstances tcEnv iss = message $+  text "Multiple instances for the same class and type" $+$+    nest 2 (vcat (map ppInstSource iss))+  where+    ppInstSource (InstSource i m) = ppInstIdent (unqualInstIdent tcEnv i) <+>+      parens (text "defined in" <+> ppMIdent m)++errMissingInstance :: HasSpanInfo s => ModuleIdent -> s -> String -> Doc -> Pred+                   -> Message+errMissingInstance m p what doc predicate = spanInfoMessage (getSpanInfo p) $ vcat+  [ text "Missing instance for" <+> ppPred m predicate+  , text "in" <+> text what <+> doc+  ]
+ src/Checks/InterfaceCheck.hs view
@@ -0,0 +1,321 @@+{- |+    Module      :  $Header$+    Description :  Checks consistency of interface files+    Copyright   :  (c) 2000 - 2007 Wolfgang Lux+                       2015        Jan Tikovsky+                       2016        Finn Teegen+    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.List                (sort)+import           Data.Maybe               (fromMaybe, isJust, isNothing)++import Curry.Base.Ident+import Curry.Base.SpanInfo+import Curry.Base.Pretty+import Curry.Syntax++import Base.CurryKinds (toKind')+import Base.CurryTypes+import Base.Messages (Message, spanInfoMessage, internalError)+import Base.TopEnv+import Base.Types++import Env.Class+import Env.Instance+import Env.OpPrec+import Env.TypeConstructor+import Env.Value++data ICState = ICState+  { moduleIdent :: ModuleIdent+  , precEnv     :: OpPrecEnv+  , tyConsEnv   :: TCEnv+  , classEnv    :: ClassEnv+  , instEnv     :: InstEnv+  , valueEnv    :: ValueEnv+  , errors      :: [Message]+  }++type IC = S.State ICState++getModuleIdent :: IC ModuleIdent+getModuleIdent = S.gets moduleIdent++getPrecEnv :: IC OpPrecEnv+getPrecEnv = S.gets precEnv++getTyConsEnv :: IC TCEnv+getTyConsEnv = S.gets tyConsEnv++getClassEnv :: IC ClassEnv+getClassEnv = S.gets classEnv++getInstEnv :: IC InstEnv+getInstEnv = S.gets instEnv++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 -> ClassEnv -> InstEnv -> ValueEnv+               -> Interface -> [Message]+interfaceCheck pEnv tcEnv clsEnv inEnv tyEnv (Interface m _ ds) =+  reverse (errors s)+  where s = S.execState (mapM_ checkImport ds) initState+        initState = ICState m pEnv tcEnv clsEnv inEnv tyEnv []++checkImport :: IDecl -> IC ()+checkImport (IInfixDecl _ fix pr op) = checkPrecInfo check op op+  where check (PrecInfo op' (OpPrec fix' pr')) =+          op == op' && fix == fix' && pr == pr'+checkImport (HidingDataDecl _ tc k tvs) =+  checkTypeInfo "hidden data type" check tc tc+  where check (DataType     tc' k' _)+          | tc == tc' && toKind' k (length tvs) == k' = Just ok+        check (RenamingType tc' k' _)+          | tc == tc' && toKind' k (length tvs) == k' = Just ok+        check _ = Nothing+checkImport (IDataDecl _ tc k tvs cs _) = checkTypeInfo "data type" check tc tc+  where check (DataType     tc' k' cs')+          | tc == tc' && toKind' k (length tvs) == k' &&+            (null cs || map constrId cs == map constrIdent cs')+          = Just (mapM_ (checkConstrImport tc tvs) cs)+        check (RenamingType tc' k'   _)+          | tc == tc' && toKind' k (length tvs) == k' && null cs+          = Just ok+        check _ = Nothing+checkImport (INewtypeDecl _ tc k tvs nc _) = checkTypeInfo "newtype" check tc tc+  where check (RenamingType tc' k' nc')+          | tc == tc' && toKind' k (length tvs) == k' &&+            nconstrId nc == constrIdent nc'+          = Just (checkNewConstrImport tc tvs nc)+        check _ = Nothing+checkImport (ITypeDecl _ tc k tvs ty) = do+  m <- getModuleIdent+  let check (AliasType tc' k' n' ty')+        | tc == tc' && toKind' k (length tvs) == k' &&+          length tvs == n' && toQualType m tvs ty == ty'+        = Just ok+      check _ = Nothing+  checkTypeInfo "synonym type" check tc tc+checkImport (IFunctionDecl _ f (Just tv) n ty) = do+  m <- getModuleIdent+  let check (Value f' cm' n' (ForAll _ ty')) =+        f == f' && isJust cm' && n' == n &&+        toQualPredType m [tv] ty == ty'+      check _ = False+  checkValueInfo "method" check f f+checkImport (IFunctionDecl _ f Nothing n ty) = do+  m <- getModuleIdent+  let check (Value f' cm' n' (ForAll _ ty')) =+        f == f' && isNothing cm' && n' == n &&+        toQualPredType m [] ty == ty'+      check _ = False+  checkValueInfo "function" check f f+checkImport (HidingClassDecl _ cx cls k _) = do+  clsEnv <- getClassEnv+  let check (TypeClass cls' k' _)+        | cls == cls' && toKind' k 0 == k' &&+          [cls'' | Constraint _ cls'' _ <- cx] == superClasses cls' clsEnv+        = Just ok+      check _ = Nothing+  checkTypeInfo "hidden type class" check cls cls+checkImport (IClassDecl _ cx cls k clsvar ms _) = do+  clsEnv <- getClassEnv+  let check (TypeClass cls' k' fs)+        | cls == cls' && toKind' k 0 == k' &&+          [cls'' | Constraint _ cls'' _ <- cx] == superClasses cls' clsEnv &&+          map (\m -> (imethod m, imethodArity m)) ms ==+            map (\f -> (methodName f, methodArity f)) fs+        = Just $ mapM_ (checkMethodImport cls clsvar) ms+      check _ = Nothing+  checkTypeInfo "type class" check cls cls+checkImport (IInstanceDecl _ cx cls ty is m) =+  checkInstInfo check cls (cls, typeConstr ty) m+  where PredType ps _ = toPredType [] $ QualTypeExpr NoSpanInfo cx ty+        check ps' is' = ps == ps' && sort is == sort is'++checkConstrImport :: QualIdent -> [Ident] -> ConstrDecl -> IC ()+checkConstrImport tc tvs (ConstrDecl _ c tys) = do+  m <- getModuleIdent+  let qc = qualifyLike tc c+      check (DataConstructor c' _ _ (ForAll uqvs pty)) =+        qc == c' && length tvs == uqvs &&+        qualifyPredType m (toConstrType tc tvs tys) == pty+      check _ = False+  checkValueInfo "data constructor" check c qc+checkConstrImport tc tvs (ConOpDecl _ ty1 op ty2) = do+  m <- getModuleIdent+  let qc = qualifyLike tc op+      check (DataConstructor c' _ _ (ForAll uqvs pty)) =+        qc == c' && length tvs == uqvs &&+        qualifyPredType m (toConstrType tc tvs [ty1, ty2]) == pty+      check _ = False+  checkValueInfo "data constructor" check op qc+checkConstrImport tc tvs (RecordDecl _ c fs) = do+  m <- getModuleIdent+  let qc = qualifyLike tc c+      (ls, tys) = unzip [(l, ty) | FieldDecl _ labels ty <- fs, l <- labels]+      check (DataConstructor c' _ ls' (ForAll uqvs pty)) =+        qc == c' && length tvs == uqvs && ls == ls' &&+        qualifyPredType m (toConstrType tc tvs tys) == pty+      check _ = False+  checkValueInfo "data constructor" check c qc++checkNewConstrImport :: QualIdent -> [Ident] -> NewConstrDecl -> IC ()+checkNewConstrImport tc tvs (NewConstrDecl _ c ty) = do+  m <- getModuleIdent+  let qc = qualifyLike tc c+      check (NewtypeConstructor c' _ (ForAll uqvs (PredType _ ty'))) =+        qc == c' && length tvs == uqvs && toQualType m tvs ty == head (arrowArgs ty')+      check _ = False+  checkValueInfo "newtype constructor" check c qc+checkNewConstrImport tc tvs (NewRecordDecl _ c (l, ty)) = do+  m <- getModuleIdent+  let qc = qualifyLike tc c+      check (NewtypeConstructor c' l' (ForAll uqvs (PredType _ ty'))) =+        qc == c' && length tvs == uqvs && l == l' &&+        toQualType m tvs ty == head (arrowArgs ty')+      check _ = False+  checkValueInfo "newtype constructor" check c qc++checkMethodImport :: QualIdent -> Ident -> IMethodDecl -> IC ()+checkMethodImport qcls clsvar (IMethodDecl _ f _ qty) =+  checkValueInfo "method" check f qf+  where qf = qualifyLike qcls f+        check (Value f' cm' _ (ForAll _ pty)) =+          qf == f' && isJust cm' &&+          toMethodType qcls clsvar qty == pty+        check _ = False++checkPrecInfo :: HasSpanInfo s => (PrecInfo -> Bool) -> s -> 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 :: HasSpanInfo s => String -> (TypeInfo -> Maybe (IC ())) -> s+              -> QualIdent -> IC ()+checkTypeInfo what check p tc = do+  tcEnv <- getTyConsEnv+  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++checkInstInfo :: HasSpanInfo s => (PredSet -> [(Ident, Int)] -> Bool) -> s -> InstIdent+              -> Maybe ModuleIdent -> IC ()+checkInstInfo check p i mm = do+  inEnv <- getInstEnv+  let checkInfo m _ = case lookupInstInfo i inEnv of+        Just (m', ps, is)+          | m /= m'   -> report $ errNoInstance p m i+          | otherwise ->+            unless (check ps is) $ report $ errInstanceConflict p m i+        Nothing -> report $ errNoInstance p m i+  checkImported checkInfo (maybe qualify qualifyWith mm anonId)++checkValueInfo :: HasSpanInfo a => String -> (ValueInfo -> Bool) -> a+               -> 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+  where p' = getSpanInfo p++checkImported :: (ModuleIdent -> Ident -> IC ()) -> QualIdent -> IC ()+checkImported _ (QualIdent _ Nothing  _) = ok+checkImported f (QualIdent _ (Just m) x) = f m x++-- ---------------------------------------------------------------------------+-- Error messages+-- ---------------------------------------------------------------------------++errNotExported :: HasSpanInfo s => s -> String -> ModuleIdent -> Ident -> Message+errNotExported p what m x = spanInfoMessage p $+  text "Inconsistent module interfaces"+  $+$ text "Module" <+> text (moduleName m)+  <+> text "does not export"<+> text what <+> text (escName x)++errNoPrecedence :: HasSpanInfo s => s -> ModuleIdent -> Ident -> Message+errNoPrecedence p m x = spanInfoMessage p $+  text "Inconsistent module interfaces"+  $+$ text "Module" <+> text (moduleName m)+  <+> text "does not define a precedence for" <+> text (escName x)++errNoInstance :: HasSpanInfo s => s -> ModuleIdent -> InstIdent -> Message+errNoInstance p m i = spanInfoMessage p $+  text "Inconsistent module interfaces"+  $+$ text "Module" <+> text (moduleName m)+  <+> text "does not define an instance for" <+> ppInstIdent i++errImportConflict :: HasSpanInfo s => s -> String -> ModuleIdent -> Ident -> Message+errImportConflict p what m x = spanInfoMessage p $+  text "Inconsistent module interfaces"+  $+$ text "Declaration of" <+> text what <+> text (escName x)+  <+> text "does not match its definition in module" <+> text (moduleName m)++errInstanceConflict :: HasSpanInfo s => s -> ModuleIdent -> InstIdent -> Message+errInstanceConflict p m i = spanInfoMessage p $+  text "Inconsistent module interfaces"+  $+$ text "Declaration of instance" <+> ppInstIdent i+  <+> text "does not match its definition in module" <+> text (moduleName m)
+ src/Checks/InterfaceSyntaxCheck.hs view
@@ -0,0 +1,346 @@+{- |+    Module      :  $Header$+    Description :  Checks interface declarations+    Copyright   :  (c) 2000 - 2007 Wolfgang Lux+                       2011 - 2015 Björn Peemöller+                       2015        Jan Tikovsky+                       2016        Finn Teegen+    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, unless, when)+import qualified Control.Monad.State as S+import           Data.List                (nub, partition)+import           Data.Maybe               (isNothing)++import Base.Expr+import Base.Messages (Message, spanInfoMessage, internalError)+import Base.TopEnv+import Base.Utils    (findMultiples, findDouble)++import Env.TypeConstructor+import Env.Type++import Curry.Base.Ident+import Curry.Base.SpanInfo+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 toTypeKind 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+bindType (HidingClassDecl  _ _ cls _ _) = qualBindTopEnv cls (Class cls [])+bindType (IClassDecl _ _ cls _ _ ms hs) =+  qualBindTopEnv cls (Class cls (filter (`notElem` hs) (map imethod ms)))+bindType (IInstanceDecl    _ _ _ _ _ _) = 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 k tvs) = do+  checkTypeLhs tvs+  return (HidingDataDecl p tc k tvs)+checkIDecl (IDataDecl p tc k tvs cs hs) = do+  checkTypeLhs tvs+  checkHiddenType tc (cons ++ labels) hs+  cs' <- mapM (checkConstrDecl tvs) cs+  return $ IDataDecl p tc k tvs cs' hs+  where cons   = map constrId cs+        labels = nub $ concatMap recordLabels cs+checkIDecl (INewtypeDecl p tc k tvs nc hs) = do+  checkTypeLhs tvs+  checkHiddenType tc (con : labels) hs+  nc' <- checkNewConstrDecl tvs nc+  return $ INewtypeDecl p tc k tvs nc' hs+  where con    = nconstrId nc+        labels = nrecordLabels nc+checkIDecl (ITypeDecl p tc k tvs ty) = do+  checkTypeLhs tvs+  liftM (ITypeDecl p tc k tvs) (checkClosedType tvs ty)+checkIDecl (IFunctionDecl p f cm n qty) =+  liftM (IFunctionDecl p f cm n) (checkQualType qty)+checkIDecl (HidingClassDecl p cx qcls k clsvar) = do+  checkTypeVars "hiding class declaration" [clsvar]+  cx' <- checkClosedContext [clsvar] cx+  checkSimpleContext cx'+  return $ HidingClassDecl p cx' qcls k clsvar+checkIDecl (IClassDecl p cx qcls k clsvar ms hs) = do+  checkTypeVars "class declaration" [clsvar]+  cx' <- checkClosedContext [clsvar] cx+  checkSimpleContext cx'+  ms' <- mapM (checkIMethodDecl clsvar) ms+  checkHidden (errNoElement "method" "class") qcls (map imethod ms') hs+  return $ IClassDecl p cx' qcls k clsvar ms' hs+checkIDecl (IInstanceDecl p cx qcls inst is m) = do+  checkClass qcls+  QualTypeExpr _ cx' inst' <- checkQualType $ QualTypeExpr NoSpanInfo cx inst+  checkSimpleContext cx'+  checkInstanceType inst'+  mapM_ (report . errMultipleImplementation . head) $ findMultiples $ map fst is+  return $ IInstanceDecl p cx' qcls inst' is m++checkHiddenType :: QualIdent -> [Ident] -> [Ident] -> ISC ()+checkHiddenType = checkHidden $ errNoElement "constructor or label" "type"++checkHidden :: (QualIdent -> Ident -> Message) -> QualIdent -> [Ident]+            -> [Ident] -> ISC ()+checkHidden err tc csls hs =+  mapM_ (report . err tc) $ nub $ filter (`notElem` csls) hs++checkTypeLhs :: [Ident] -> ISC ()+checkTypeLhs = checkTypeVars "left hand side of type declaration"++checkTypeVars :: String -> [Ident] -> ISC ()+checkTypeVars what tvs = do+  tyEnv <- getTypeEnv+  let (tcs, tvs') = partition isTypeConstrOrClass tvs+      isTypeConstrOrClass tv = not (null (lookupTypeKind tv tyEnv))+  mapM_ (report . flip errNoVariable what)       (nub tcs)+  mapM_ (report . flip errNonLinear what . head) (findMultiples tvs')++checkConstrDecl :: [Ident] -> ConstrDecl -> ISC ConstrDecl+checkConstrDecl tvs (ConstrDecl p c tys) = do+  liftM (ConstrDecl p c) (mapM (checkClosedType tvs) tys)+checkConstrDecl tvs (ConOpDecl p ty1 op ty2) = do+  liftM2 (\t1 t2 -> ConOpDecl p t1 op t2)+         (checkClosedType tvs ty1)+         (checkClosedType tvs ty2)+checkConstrDecl tvs (RecordDecl p c fs) = do+  liftM (RecordDecl p c) (mapM (checkFieldDecl tvs) fs)++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 c ty) =+  liftM (NewConstrDecl p c) (checkClosedType tvs ty)+checkNewConstrDecl tvs (NewRecordDecl p c (l, ty)) = do+  ty' <- checkClosedType tvs ty+  return $ NewRecordDecl p c (l, ty')++checkSimpleContext :: Context -> ISC ()+checkSimpleContext = mapM_ checkSimpleConstraint++checkSimpleConstraint :: Constraint -> ISC ()+checkSimpleConstraint c@(Constraint _ _ ty) =+  unless (isVariableType ty) $ report $ errIllegalSimpleConstraint c++checkIMethodDecl :: Ident -> IMethodDecl -> ISC IMethodDecl+checkIMethodDecl tv (IMethodDecl p f a qty) = do+  qty' <- checkQualType qty+  unless (tv `elem` fv qty') $ report $ errAmbiguousType f tv+  let QualTypeExpr _ cx _ = qty'+  when (tv `elem` fv cx) $ report $ errConstrainedClassVariable f tv+  return $ IMethodDecl p f a qty'++checkInstanceType :: InstanceType -> ISC ()+checkInstanceType inst = do+  tEnv <- getTypeEnv+  unless (isSimpleType inst &&+    not (isTypeSyn (typeConstr inst) tEnv) &&+    null (filter isAnonId $ typeVars inst) &&+    isNothing (findDouble $ fv inst)) $+      report $ errIllegalInstanceType inst inst++checkQualType :: QualTypeExpr -> ISC QualTypeExpr+checkQualType (QualTypeExpr spi cx ty) = do+  ty' <- checkType ty+  cx' <- checkClosedContext (fv ty') cx+  return $ QualTypeExpr spi cx' ty'++checkClosedContext :: [Ident] -> Context -> ISC Context+checkClosedContext tvs cx = do+  cx' <- checkContext cx+  mapM_ (\(Constraint _ _ ty) -> checkClosed tvs ty) cx'+  return cx'++checkContext :: Context -> ISC Context+checkContext = mapM checkConstraint++checkConstraint :: Constraint -> ISC Constraint+checkConstraint (Constraint spi qcls ty) = do+  checkClass qcls+  Constraint spi qcls `liftM` checkType ty++checkClass :: QualIdent -> ISC ()+checkClass qcls = do+  tEnv <- getTypeEnv+  case qualLookupTypeKind qcls tEnv of+    [] -> report $ errUndefinedClass qcls+    [Class _ _] -> return ()+    [_] -> report $ errUndefinedClass qcls+    _ -> internalError $ "Checks.InterfaceSyntaxCheck.checkClass: " +++           "ambiguous identifier " ++ show qcls++checkClosedType :: [Ident] -> TypeExpr -> ISC TypeExpr+checkClosedType tvs ty = do+  ty' <- checkType ty+  checkClosed tvs ty'+  return ty'++checkType :: TypeExpr -> ISC TypeExpr+checkType (ConstructorType spi tc) = checkTypeConstructor spi tc+checkType (ApplyType  spi ty1 ty2) =+  liftM2 (ApplyType spi) (checkType ty1) (checkType ty2)+checkType (VariableType    spi tv) =+  checkType $ ConstructorType spi (qualify tv)+checkType (TupleType      spi tys) = liftM (TupleType spi) (mapM checkType tys)+checkType (ListType        spi ty) = liftM (ListType spi) (checkType ty)+checkType (ArrowType  spi ty1 ty2) =+  liftM2 (ArrowType spi) (checkType ty1) (checkType ty2)+checkType (ParenType      spi  ty) = liftM (ParenType spi) (checkType ty)+checkType (ForallType   spi vs ty) = liftM (ForallType spi vs) (checkType ty)++checkClosed :: [Ident] -> TypeExpr -> ISC ()+checkClosed _   (ConstructorType _ _) = return ()+checkClosed tvs (ApplyType _ ty1 ty2) = mapM_ (checkClosed tvs) [ty1, ty2]+checkClosed tvs (VariableType   _ tv) =+  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+checkClosed tvs (ForallType  _ vs ty) = checkClosed (tvs ++ vs) ty++checkTypeConstructor :: SpanInfo -> QualIdent -> ISC TypeExpr+checkTypeConstructor spi tc = do+  tyEnv <- getTypeEnv+  case qualLookupTypeKind tc tyEnv of+    [] | not (isQualified tc) -> return $ VariableType spi $ unqualify tc+       | otherwise            -> do+          report $ errUndefinedType tc+          return $ ConstructorType spi tc+    [Data _ _] -> return $ ConstructorType spi tc+    [Alias  _] -> do+                  report $ errBadTypeSynonym tc+                  return $ ConstructorType spi tc+    _          ->+      internalError "Checks.InterfaceSyntaxCheck.checkTypeConstructor"++-- ---------------------------------------------------------------------------+-- Auxiliary definitions+-- ---------------------------------------------------------------------------++typeVars :: TypeExpr -> [Ident]+typeVars (ConstructorType      _ _) = []+typeVars (ApplyType      _ ty1 ty2) = typeVars ty1 ++ typeVars ty2+typeVars (VariableType        _ tv) = [tv]+typeVars (TupleType          _ tys) = concatMap typeVars tys+typeVars (ListType            _ ty) = typeVars ty+typeVars (ArrowType      _ ty1 ty2) = typeVars ty1 ++ typeVars ty2+typeVars (ParenType           _ ty) = typeVars ty+typeVars (ForallType       _ vs ty) = vs ++ typeVars ty++isTypeSyn :: QualIdent -> TypeEnv -> Bool+isTypeSyn tc tEnv = case qualLookupTypeKind tc tEnv of+  [Alias _] -> True+  _ -> False++-- ---------------------------------------------------------------------------+-- Error messages+-- ---------------------------------------------------------------------------++errUndefined :: String -> QualIdent -> Message+errUndefined what qident = spanInfoMessage qident $ hsep $ map text+  ["Undefined", what, qualName qident]++errUndefinedClass :: QualIdent -> Message+errUndefinedClass = errUndefined "class"++errUndefinedType :: QualIdent -> Message+errUndefinedType = errUndefined "type"++errMultipleImplementation :: Ident -> Message+errMultipleImplementation f = spanInfoMessage f $ hsep $ map text+  ["Arity information for method", idName f, "occurs more than once"]++errAmbiguousType :: HasSpanInfo s => s -> Ident -> Message+errAmbiguousType p ident = spanInfoMessage p $ hsep $ map text+  [ "Method type does not mention class variable", idName ident ]++errConstrainedClassVariable :: HasSpanInfo s => s -> Ident -> Message+errConstrainedClassVariable p ident = spanInfoMessage p $ hsep $ map text+  [ "Method context must not constrain class variable", idName ident ]++errNonLinear :: Ident -> String -> Message+errNonLinear tv what = spanInfoMessage tv $ hsep $ map text+  [ "Type variable", escName tv, "occurs more than once in", what ]++errNoVariable :: Ident -> String -> Message+errNoVariable tv what = spanInfoMessage tv $ hsep $ map text+  [ "Type constructor or type class identifier", escName tv, "used in", what ]++errUnboundVariable :: Ident -> Message+errUnboundVariable tv = spanInfoMessage tv $+  text "Undefined type variable" <+> text (escName tv)++errBadTypeSynonym :: QualIdent -> Message+errBadTypeSynonym tc = spanInfoMessage tc $ text "Synonym type"+                    <+> text (qualName tc) <+> text "in interface"++errNoElement :: String -> String -> QualIdent -> Ident -> Message+errNoElement what for tc x = spanInfoMessage x $ hsep $ map text+  [ "Hidden", what, escName x, "is not defined for", for, qualName tc ]++errIllegalSimpleConstraint :: Constraint -> Message+errIllegalSimpleConstraint c@(Constraint _ qcls _) = spanInfoMessage qcls $ vcat+  [ text "Illegal class constraint" <+> pPrint c+  , text "Constraints in class and instance declarations must be of"+  , text "the form C u, where C is a type class and u is a type variable."+  ]++errIllegalInstanceType :: HasSpanInfo s => s -> InstanceType -> Message+errIllegalInstanceType p inst = spanInfoMessage p $ vcat+  [ text "Illegal instance type" <+> pPrint inst+  , text "The instance type must be of the form (T u_1 ... u_n),"+  , text "where T is not a type synonym and u_1, ..., u_n are"+  , text "mutually distinct, non-anonymous type variables."+  ]
+ src/Checks/KindCheck.hs view
@@ -0,0 +1,762 @@+{- |+    Module      :  $Header$+    Description :  Checks type kinds+    Copyright   :  (c) 2016 - 2017 Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++   After the type syntax has been checked und nullary type constructors and+   type variables have been disambiguated, the compiler infers kinds for all+   type constructors and type classes defined in the current module and+   performs kind checking on all type definitions and type signatures.+-}+{-# LANGUAGE CPP #-}+module Checks.KindCheck (kindCheck) where++#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative      ((<$>), (<*>))+#endif+import           Control.Monad            (when, foldM)+import           Control.Monad.Fix        (mfix)+import qualified Control.Monad.State as S (State, runState, gets, modify)+import           Data.List                (partition, nub)++import Curry.Base.Ident+import Curry.Base.Position+import Curry.Base.SpanInfo+import Curry.Base.Pretty+import Curry.Syntax+import Curry.Syntax.Pretty++import Base.CurryKinds+import Base.Expr+import Base.Kinds+import Base.KindSubst+import Base.Messages (Message, spanInfoMessage, internalError)+import Base.SCC+import Base.TopEnv+import Base.Types+import Base.TypeExpansion++import Env.Class+import Env.TypeConstructor++-- In order to infer kinds for type constructors and type classes, the+-- compiler sorts the module's type and class declarations into minimal+-- recursive binding groups and then applies kind inference to each+-- declaration group. Besides inferring kinds for the type constructors+-- and type classes of a group, the compiler also checks that there are+-- no mutually recursive type synonym definitions and that the super class+-- hierarchy is acyclic. The former allows entering fully expanded type+-- synonyms into the type constructor environment.++kindCheck :: TCEnv -> ClassEnv -> Module a -> ((TCEnv, ClassEnv), [Message])+kindCheck tcEnv clsEnv (Module _ _ _ m _ _ ds) = runKCM check initState+  where+    check = do+      checkNonRecursiveTypes tds &&> checkAcyclicSuperClasses cds+      errs <- S.gets errors+      if null errs+         then checkDecls+         else return (tcEnv, clsEnv)+    checkDecls = do+      (tcEnv', clsEnv') <- kcDecls tcEnv clsEnv tcds+      mapM_ (kcDecl tcEnv') ods+      return (tcEnv', clsEnv')+    tds = filter isTypeDecl tcds+    cds = filter isClassDecl tcds+    (tcds, ods) = partition isTypeOrClassDecl ds+    initState  = KCState m idSubst 0 []++-- Kind Check Monad+type KCM = S.State KCState++-- |Internal state of the Kind Check+data KCState = KCState+  { moduleIdent :: ModuleIdent -- read only+  , kindSubst   :: KindSubst+  , nextId      :: Int         -- automatic counter+  , errors      :: [Message]+  }++(&&>) :: KCM () -> KCM () -> KCM ()+pre &&> suf = do+  errs <- pre >> S.gets errors+  when (null errs) suf++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++getKindSubst :: KCM KindSubst+getKindSubst = S.gets kindSubst++modifyKindSubst :: (KindSubst -> KindSubst) -> KCM ()+modifyKindSubst f = S.modify $ \s -> s { kindSubst = f $ kindSubst s }++getNextId :: KCM Int+getNextId = do+  nid <- S.gets nextId+  S.modify $ \s -> s { nextId = succ nid }+  return nid++report :: Message -> KCM ()+report err = S.modify (\s -> s { errors = err : errors s })++ok :: KCM ()+ok = return ()++-- Minimal recursive declaration groups are computed using the sets of bound+-- and free type constructor and type class identifiers of the declarations.++bt :: Decl a -> [Ident]+bt (DataDecl     _ tc _ _ _) = [tc]+bt (ExternalDataDecl _ tc _) = [tc]+bt (NewtypeDecl  _ tc _ _ _) = [tc]+bt (TypeDecl       _ tc _ _) = [tc]+bt (ClassDecl _ _ _ cls _ _) = [cls]+bt _                         = []++ft :: ModuleIdent -> Decl a -> [Ident]+ft m d = fts m d []++class HasType a where+  fts :: ModuleIdent -> a -> [Ident] -> [Ident]++instance HasType a => HasType [a] where+  fts m = flip $ foldr $ fts m++instance HasType a => HasType (Maybe a) where+  fts m = maybe id $ fts m++instance HasType (Decl a) where+  fts _ (InfixDecl               _ _ _ _) = id+  fts m (DataDecl          _ _ _ cs clss) = fts m cs . fts m clss+  fts _ (ExternalDataDecl          _ _ _) = id+  fts m (NewtypeDecl       _ _ _ nc clss) = fts m nc . fts m clss+  fts m (TypeDecl               _ _ _ ty) = fts m ty+  fts m (TypeSig                  _ _ ty) = fts m ty+  fts m (FunctionDecl          _ _ _ eqs) = fts m eqs+  fts _ (ExternalDecl                _ _) = id+  fts m (PatternDecl             _ _ rhs) = fts m rhs+  fts _ (FreeDecl                    _ _) = id+  fts m (DefaultDecl               _ tys) = fts m tys+  fts m (ClassDecl         _ _ cx _ _ ds) = fts m cx . fts m ds+  fts m (InstanceDecl _ _ cx cls inst ds) =+    fts m cx . fts m cls . fts m inst . fts m ds++instance HasType ConstrDecl where+  fts m (ConstrDecl     _ _ tys) = fts m tys+  fts m (ConOpDecl  _ ty1 _ ty2) = fts m ty1 . fts m ty2+  fts m (RecordDecl      _ _ fs) = fts m fs++instance HasType FieldDecl where+  fts m (FieldDecl _ _ ty) = fts m ty++instance HasType NewConstrDecl where+  fts m (NewConstrDecl      _ _ ty) = fts m ty+  fts m (NewRecordDecl _ _ (_, ty)) = fts m ty++instance HasType Constraint where+  fts m (Constraint _ qcls _) = fts m qcls++instance HasType QualTypeExpr where+  fts m (QualTypeExpr _ cx ty) = fts m cx . fts m ty++instance HasType TypeExpr where+  fts m (ConstructorType     _ tc) = fts m tc+  fts m (ApplyType      _ ty1 ty2) = fts m ty1 . fts m ty2+  fts _ (VariableType         _ _) = id+  fts m (TupleType          _ tys) = (tupleId (length tys) :) . fts m tys+  fts m (ListType            _ ty) = (listId :) . fts m ty+  fts m (ArrowType      _ ty1 ty2) = (arrowId :) . fts m ty1 . fts m ty2+  fts m (ParenType           _ ty) = fts m ty+  fts m (ForallType        _ _ ty) = fts m ty++instance HasType (Equation a) where+  fts m (Equation _ _ rhs) = fts m rhs++instance HasType (Rhs a) where+  fts m (SimpleRhs  _ _ e  ds) = fts m e . fts m ds+  fts m (GuardedRhs _ _ es ds) = fts m es . fts m ds++instance HasType (CondExpr a) where+  fts m (CondExpr _ g e) = fts m g . fts m e++instance HasType (Expression a) where+  fts _ (Literal             _ _ _) = id+  fts _ (Variable            _ _ _) = id+  fts _ (Constructor         _ _ _) = id+  fts m (Paren                 _ e) = fts m e+  fts m (Typed              _ e ty) = fts m e . fts m ty+  fts m (Record           _ _ _ fs) = fts m fs+  fts m (RecordUpdate       _ e fs) = fts m e . fts m fs+  fts m (Tuple                _ es) = fts m es+  fts m (List               _ _ es) = fts m es+  fts m (ListCompr        _ e stms) = fts m e . fts m stms+  fts m (EnumFrom              _ e) = fts m e+  fts m (EnumFromThen      _ e1 e2) = fts m e1 . fts m e2+  fts m (EnumFromTo        _ e1 e2) = fts m e1 . fts m e2+  fts m (EnumFromThenTo _ e1 e2 e3) = fts m e1 . fts m e2 . fts m e3+  fts m (UnaryMinus            _ e) = fts m e+  fts m (Apply             _ e1 e2) = fts m e1 . fts m e2+  fts m (InfixApply      _ e1 _ e2) = fts m e1 . fts m e2+  fts m (LeftSection         _ e _) = fts m e+  fts m (RightSection        _ _ e) = fts m e+  fts m (Lambda              _ _ e) = fts m e+  fts m (Let              _ _ ds e) = fts m ds . fts m e+  fts m (Do             _ _ stms e) = fts m stms . fts m e+  fts m (IfThenElse     _ e1 e2 e3) = fts m e1 . fts m e2 . fts m e3+  fts m (Case           _ _ _ e as) = fts m e . fts m as++instance HasType (Statement a) where+  fts m (StmtExpr _    e) = fts m e+  fts m (StmtDecl _ _ ds) = fts m ds+  fts m (StmtBind _ _  e) = fts m e++instance HasType (Alt a) where+  fts m (Alt _ _ rhs) = fts m rhs++instance HasType a => HasType (Field a) where+  fts m (Field _ _ x) = fts m x++instance HasType QualIdent where+  fts m qident = maybe id (:) (localIdent m qident)++-- When types are entered into the type constructor environment, all type+-- synonyms occuring in the definitions are fully expanded (except for+-- record types) and all type constructors and type classes 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 or+-- newtypes, which is checked in the function 'checkNonRecursiveTypes' below.++ft' :: ModuleIdent -> Decl a -> [Ident]+ft' _ (DataDecl     _ _ _ _ _) = []+ft' _ (ExternalDataDecl _ _ _) = []+ft' m (NewtypeDecl _ _ _ nc _) = fts m nc []+ft' m (TypeDecl      _ _ _ ty) = fts m ty []+ft' _ _                        = []++checkNonRecursiveTypes :: [Decl a] -> KCM ()+checkNonRecursiveTypes ds = do+  m <- getModuleIdent+  mapM_ checkTypeAndNewtypeDecls $ scc bt (ft' m) ds++checkTypeAndNewtypeDecls :: [Decl a] -> KCM ()+checkTypeAndNewtypeDecls [] =+  internalError "Checks.KindCheck.checkTypeAndNewtypeDecls: empty list"+checkTypeAndNewtypeDecls [DataDecl _ _ _ _ _] = ok+checkTypeAndNewtypeDecls [ExternalDataDecl _ _ _] = ok+checkTypeAndNewtypeDecls [d] | isTypeOrNewtypeDecl d = do+  m <- getModuleIdent+  let tc = typeConstructor d+  when (tc `elem` ft m d) $ report $ errRecursiveTypes [tc]+checkTypeAndNewtypeDecls (d:ds) | isTypeOrNewtypeDecl d =+  report $ errRecursiveTypes $+    typeConstructor d : [typeConstructor d' | d' <- ds, isTypeOrNewtypeDecl d']+checkTypeAndNewtypeDecls _ = internalError+  "Checks.KindCheck.checkTypeAndNewtypeDecls: no type or newtype declarations"++-- The function 'checkAcyclicSuperClasses' checks that the super class+-- hierarchy is acyclic.++fc :: ModuleIdent -> Context -> [Ident]+fc m = foldr fc' []+  where+    fc' (Constraint _ qcls _) = maybe id (:) (localIdent m qcls)++checkAcyclicSuperClasses :: [Decl a] -> KCM ()+checkAcyclicSuperClasses ds = do+  m <- getModuleIdent+  mapM_ checkClassDecl $ scc bt (\(ClassDecl _ _ cx _ _ _) -> fc m cx) ds++checkClassDecl :: [Decl a] -> KCM ()+checkClassDecl [] =+  internalError "Checks.KindCheck.checkClassDecl: empty list"+checkClassDecl [ClassDecl _ _ cx cls _ _] = do+  m <- getModuleIdent+  when (cls `elem` fc m cx) $ report $ errRecursiveClasses [cls]+checkClassDecl (ClassDecl _ _ _ cls _ _ : ds) =+  report $ errRecursiveClasses $ cls : [cls' | ClassDecl _ _ _ cls' _ _ <- ds]+checkClassDecl _ =+  internalError "Checks.KindCheck.checkClassDecl: no class declaration"++-- For each declaration group, the kind checker first enters new+-- assumptions into the type constructor environment. For a type+-- constructor with arity n, we enter kind k_1 -> ... -> k_n -> k,+-- where k_i are fresh kind variables and k is * for data and newtype+-- type constructors and a fresh kind variable for type synonym type+-- constructors. For a type class we enter kind k, where k is a fresh+-- kind variable. We also add a type class to the class environment.+-- Next, the kind checker checks the declarations of the group within+-- the extended environment, and finally the kind checker instantiates+-- all remaining free kind variables to *.++-- As noted above, type synonyms are fully expanded while types are+-- entered into the type constructor environment. Furthermore, we uses+-- original names for classes and super classes in the class environment.+-- Unfortunately, both of this requires either sorting type declarations+-- properly or using the final type constructor environment for the expansion+-- and original names. We have chosen the latter option here, which requires+-- recursive monadic bindings which are supported using the 'mfix' method+-- from the 'MonadFix' type class.++bindKind :: ModuleIdent -> TCEnv -> ClassEnv -> TCEnv -> Decl a -> KCM TCEnv+bindKind m tcEnv' clsEnv tcEnv (DataDecl _ tc tvs cs _) =+  bindTypeConstructor DataType tc tvs (Just KindStar) (map mkData cs) tcEnv+  where+    mkData (ConstrDecl _     c  tys) = mkData' c  tys+    mkData (ConOpDecl  _ ty1 op ty2) = mkData' op [ty1, ty2]+    mkData (RecordDecl _     c   fs) =+      let (labels, tys) = unzip [(l, ty) | FieldDecl _ ls ty <- fs, l <- ls]+      in  mkRec c labels tys+    mkData' c tys = DataConstr c tys'+      where qtc = qualifyWith m tc+            PredType _ ty = expandConstrType m tcEnv' clsEnv qtc tvs tys+            tys' = arrowArgs ty+    mkRec c ls tys =+      RecordConstr c ls tys'+      where qtc = qualifyWith m tc+            PredType _ ty = expandConstrType m tcEnv' clsEnv qtc tvs tys+            tys' = arrowArgs ty+bindKind _ _     _       tcEnv (ExternalDataDecl _ tc tvs) =+  bindTypeConstructor DataType tc tvs (Just KindStar) [] tcEnv+bindKind m tcEnv' _      tcEnv (NewtypeDecl _ tc tvs nc _) =+  bindTypeConstructor RenamingType tc tvs (Just KindStar) (mkData nc) tcEnv+  where+    mkData (NewConstrDecl _ c      ty) = DataConstr c [ty']+      where ty'  = expandMonoType m tcEnv' tvs ty+    mkData (NewRecordDecl _ c (l, ty)) = RecordConstr c [l] [ty']+      where ty'  = expandMonoType m tcEnv' tvs ty+bindKind m tcEnv' _      tcEnv (TypeDecl _ tc tvs ty) =+  bindTypeConstructor aliasType tc tvs Nothing ty' tcEnv+  where+    aliasType tc' k = AliasType tc' k $ length tvs+    ty' = expandMonoType m tcEnv' tvs ty+bindKind m tcEnv' clsEnv tcEnv (ClassDecl _ _ _ cls tv ds) =+  bindTypeClass cls (concatMap mkMethods ds) tcEnv+  where+    mkMethods (TypeSig _ fs qty) = map (mkMethod qty) fs+    mkMethods _                  = []+    mkMethod qty f = ClassMethod f (findArity f ds) $+                       expandMethodType m tcEnv' clsEnv (qualify cls) tv qty+    findArity _ []                                    = Nothing+    findArity f (FunctionDecl _ _ f' eqs:_) | f == f' =+      Just $ eqnArity $ head eqs+    findArity f (_:ds')                               = findArity f ds'+bindKind _ _      _      tcEnv _                          = return tcEnv++bindTypeConstructor :: (QualIdent -> Kind -> a -> TypeInfo) -> Ident+                    -> [Ident] -> Maybe Kind -> a -> TCEnv -> KCM TCEnv+bindTypeConstructor f tc tvs k x tcEnv = do+  m <- getModuleIdent+  k' <- maybe freshKindVar return k+  ks <- mapM (const freshKindVar) tvs+  let qtc = qualifyWith m tc+      ti = f qtc (foldr KindArrow k' ks) x+  return $ bindTypeInfo m tc ti tcEnv++bindTypeClass :: Ident -> [ClassMethod] -> TCEnv -> KCM TCEnv+bindTypeClass cls ms tcEnv = do+  m <- getModuleIdent+  k <- freshKindVar+  let qcls = qualifyWith m cls+      ti = TypeClass qcls k ms+  return $ bindTypeInfo m cls ti tcEnv++bindFreshKind :: TCEnv -> Ident -> KCM TCEnv+bindFreshKind tcEnv tv = do+  k <- freshKindVar+  return $ bindTypeVar tv k tcEnv++bindTypeVars :: Ident -> [Ident] -> TCEnv -> KCM (Kind, TCEnv)+bindTypeVars tc tvs tcEnv = do+  m <- getModuleIdent+  return $ foldl (\(KindArrow k1 k2, tcEnv') tv ->+                   (k2, bindTypeVar tv k1 tcEnv'))+                 (tcKind m (qualifyWith m tc) tcEnv, tcEnv)+                 tvs++bindTypeVar :: Ident -> Kind -> TCEnv -> TCEnv+bindTypeVar ident k = bindTopEnv ident (TypeVar k)++bindClass :: ModuleIdent -> TCEnv -> ClassEnv -> Decl a -> ClassEnv+bindClass m tcEnv clsEnv (ClassDecl _ _ cx cls _ ds) =+  bindClassInfo qcls (sclss, ms) clsEnv+  where qcls = qualifyWith m cls+        ms = map (\f -> (f, f `elem` fs)) $ concatMap methods ds+        fs = concatMap impls ds+        sclss = nub $ map (\(Constraint _ cls' _) -> getOrigName m cls' tcEnv) cx+bindClass _ _ clsEnv _ = clsEnv++instantiateWithDefaultKind :: TypeInfo -> TypeInfo+instantiateWithDefaultKind (DataType tc k cs) =+  DataType tc (defaultKind k) cs+instantiateWithDefaultKind (RenamingType tc k nc) =+  RenamingType tc (defaultKind k) nc+instantiateWithDefaultKind (AliasType tc k n ty) =+  AliasType tc (defaultKind k) n ty+instantiateWithDefaultKind (TypeClass cls k ms) =+  TypeClass cls (defaultKind k) ms+instantiateWithDefaultKind (TypeVar _) =+  internalError "Checks.KindCheck.instantiateWithDefaultKind: type variable"++kcDecls :: TCEnv -> ClassEnv -> [Decl a] -> KCM (TCEnv, ClassEnv)+kcDecls tcEnv clsEnv ds = do+  m <- getModuleIdent+  foldM (uncurry kcDeclGroup) (tcEnv, clsEnv) $ scc bt (ft m) ds++kcDeclGroup :: TCEnv -> ClassEnv -> [Decl a] -> KCM (TCEnv, ClassEnv)+kcDeclGroup tcEnv clsEnv ds = do+  m <- getModuleIdent+  (tcEnv', clsEnv') <- mfix (\ ~(tcEnv', clsEnv') ->+    flip (,) (foldl (bindClass m tcEnv') clsEnv ds) <$>+      foldM (bindKind m tcEnv' clsEnv') tcEnv ds)+  mapM_ (kcDecl tcEnv') ds+  theta <- getKindSubst+  return (fmap (instantiateWithDefaultKind . subst theta) tcEnv', clsEnv')++-- After adding new assumptions to the environment, kind inference is+-- applied to all declarations. The type environment may be extended+-- temporarily with bindings for type variables occurring in the left+-- hand side of type declarations and free type variables of type+-- signatures. While the kinds of the former are determined already by+-- the kinds of their type constructors and type classes, respectively,+-- fresh kind variables are added for the latter.++kcDecl :: TCEnv -> Decl a -> KCM ()+kcDecl _     (InfixDecl _ _ _ _) = ok+kcDecl tcEnv (DataDecl _ tc tvs cs _) = do+  (_, tcEnv') <- bindTypeVars tc tvs tcEnv+  mapM_ (kcConstrDecl tcEnv') cs+kcDecl _     (ExternalDataDecl _ _ _) = ok+kcDecl tcEnv (NewtypeDecl _ tc tvs nc _) = do+  (_, tcEnv') <- bindTypeVars tc tvs tcEnv+  kcNewConstrDecl tcEnv' nc+kcDecl tcEnv t@(TypeDecl _ tc tvs ty) = do+  (k, tcEnv') <- bindTypeVars tc tvs tcEnv+  kcType tcEnv' "type declaration" (pPrint t) k ty+kcDecl tcEnv (TypeSig _ _ qty) = kcTypeSig tcEnv qty+kcDecl tcEnv (FunctionDecl _ _ _ eqs) = mapM_ (kcEquation tcEnv) eqs+kcDecl _     (ExternalDecl _ _) = ok+kcDecl tcEnv (PatternDecl _ _ rhs) = kcRhs tcEnv rhs+kcDecl _     (FreeDecl _ _) = ok+kcDecl tcEnv (DefaultDecl _ tys) = do+  tcEnv' <- foldM bindFreshKind tcEnv $ nub $ fv tys+  mapM_ (kcValueType tcEnv' "default declaration" empty) tys+kcDecl tcEnv (ClassDecl _ _ cx cls tv ds) = do+  m <- getModuleIdent+  let tcEnv' = bindTypeVar tv (clsKind m (qualifyWith m cls) tcEnv) tcEnv+  kcContext tcEnv' cx+  mapM_ (kcDecl tcEnv') ds+kcDecl tcEnv (InstanceDecl p _ cx qcls inst ds) = do+  m <- getModuleIdent+  tcEnv' <- foldM bindFreshKind tcEnv $ fv inst+  kcContext tcEnv' cx+  kcType tcEnv' what doc (clsKind m qcls tcEnv) inst+  mapM_ (kcDecl tcEnv') ds+    where+      what = "instance declaration"+      doc = pPrint (InstanceDecl p WhitespaceLayout cx qcls inst [])++kcConstrDecl :: TCEnv -> ConstrDecl -> KCM ()+kcConstrDecl tcEnv d@(ConstrDecl _ _ tys) = do+  mapM_ (kcValueType tcEnv what doc) tys+    where+      what = "data constructor declaration"+      doc = pPrint d+kcConstrDecl tcEnv d@(ConOpDecl _ ty1 _ ty2) = do+  kcValueType tcEnv what doc ty1+  kcValueType tcEnv what doc ty2+    where+      what = "data constructor declaration"+      doc = pPrint d+kcConstrDecl tcEnv (RecordDecl _ _ fs) = do+  mapM_ (kcFieldDecl tcEnv) fs++kcFieldDecl :: TCEnv -> FieldDecl -> KCM ()+kcFieldDecl tcEnv d@(FieldDecl _ _ ty) =+  kcValueType tcEnv "field declaration" (pPrint d) ty++kcNewConstrDecl :: TCEnv -> NewConstrDecl -> KCM ()+kcNewConstrDecl tcEnv d@(NewConstrDecl _ _ ty) =+  kcValueType tcEnv "newtype constructor declaration" (pPrint d) ty+kcNewConstrDecl tcEnv (NewRecordDecl p _ (l, ty)) =+  kcFieldDecl tcEnv (FieldDecl p [l] ty)++kcEquation :: TCEnv -> Equation a -> KCM ()+kcEquation tcEnv (Equation _ _ rhs) = kcRhs tcEnv rhs++kcRhs :: TCEnv -> Rhs a -> KCM ()+kcRhs tcEnv (SimpleRhs _ _ e ds) = do+  kcExpr tcEnv e+  mapM_ (kcDecl tcEnv) ds+kcRhs tcEnv (GuardedRhs _ _ es ds) = do+  mapM_ (kcCondExpr tcEnv) es+  mapM_ (kcDecl tcEnv) ds++kcCondExpr :: TCEnv -> CondExpr a -> KCM ()+kcCondExpr tcEnv (CondExpr _ g e) = kcExpr tcEnv g >> kcExpr tcEnv e++kcExpr :: TCEnv -> Expression a -> KCM ()+kcExpr _     (Literal _ _ _) = ok+kcExpr _     (Variable _ _ _) = ok+kcExpr _     (Constructor _ _ _) = ok+kcExpr tcEnv (Paren _ e) = kcExpr tcEnv e+kcExpr tcEnv (Typed _ e qty) = do+  kcExpr tcEnv e+  kcTypeSig tcEnv qty+kcExpr tcEnv (Record _ _ _ fs) = mapM_ (kcField tcEnv) fs+kcExpr tcEnv (RecordUpdate _ e fs) = do+  kcExpr tcEnv e+  mapM_ (kcField tcEnv) fs+kcExpr tcEnv (Tuple _ es) = mapM_ (kcExpr tcEnv) es+kcExpr tcEnv (List _ _ es) = mapM_ (kcExpr tcEnv) es+kcExpr tcEnv (ListCompr _ e stms) = do+  kcExpr tcEnv e+  mapM_ (kcStmt tcEnv) stms+kcExpr tcEnv (EnumFrom _ e) = kcExpr tcEnv e+kcExpr tcEnv (EnumFromThen _ e1 e2) = do+  kcExpr tcEnv e1+  kcExpr tcEnv e2+kcExpr tcEnv (EnumFromTo _ e1 e2) = do+  kcExpr tcEnv e1+  kcExpr tcEnv e2+kcExpr tcEnv (EnumFromThenTo _ e1 e2 e3) = do+  kcExpr tcEnv e1+  kcExpr tcEnv e2+  kcExpr tcEnv e3+kcExpr tcEnv (UnaryMinus _ e) = kcExpr tcEnv e+kcExpr tcEnv (Apply _ e1 e2) = do+  kcExpr tcEnv e1+  kcExpr tcEnv e2+kcExpr tcEnv (InfixApply _ e1 _ e2) = do+  kcExpr tcEnv e1+  kcExpr tcEnv e2+kcExpr tcEnv (LeftSection _ e _) = kcExpr tcEnv e+kcExpr tcEnv (RightSection _ _ e) = kcExpr tcEnv e+kcExpr tcEnv (Lambda _ _ e) = kcExpr tcEnv e+kcExpr tcEnv (Let _ _ ds e) = do+  mapM_ (kcDecl tcEnv) ds+  kcExpr tcEnv e+kcExpr tcEnv (Do _ _ stms e) = do+  mapM_ (kcStmt tcEnv) stms+  kcExpr tcEnv e+kcExpr tcEnv (IfThenElse _ e1 e2 e3) = do+  kcExpr tcEnv e1+  kcExpr tcEnv e2+  kcExpr tcEnv e3+kcExpr tcEnv (Case _ _ _ e alts) = do+  kcExpr tcEnv e+  mapM_ (kcAlt tcEnv) alts++kcStmt :: TCEnv -> Statement a -> KCM ()+kcStmt tcEnv (StmtExpr _ e) = kcExpr tcEnv e+kcStmt tcEnv (StmtDecl _ _ ds) = mapM_ (kcDecl tcEnv) ds+kcStmt tcEnv (StmtBind _ _ e) = kcExpr tcEnv e++kcAlt :: TCEnv -> Alt a -> KCM ()+kcAlt tcEnv (Alt _ _ rhs) = kcRhs tcEnv rhs++kcField :: TCEnv -> Field (Expression a) -> KCM ()+kcField tcEnv (Field _ _ e) = kcExpr tcEnv e++kcContext :: TCEnv -> Context -> KCM ()+kcContext tcEnv = mapM_ (kcConstraint tcEnv)++kcConstraint :: TCEnv -> Constraint -> KCM ()+kcConstraint tcEnv sc@(Constraint _ qcls ty) = do+  m <- getModuleIdent+  kcType tcEnv "class constraint" doc (clsKind m qcls tcEnv) ty+  where+    doc = pPrint sc++kcTypeSig :: TCEnv -> QualTypeExpr -> KCM ()+kcTypeSig tcEnv (QualTypeExpr _ cx ty) = do+  tcEnv' <- foldM bindFreshKind tcEnv free+  kcContext tcEnv' cx+  kcValueType tcEnv' "type signature" doc ty+  where+    free = filter (null . flip lookupTypeInfo tcEnv) $ nub $ fv ty+    doc = pPrintPrec 0 ty++kcValueType :: TCEnv -> String -> Doc -> TypeExpr -> KCM ()+kcValueType tcEnv what doc = kcType tcEnv what doc KindStar++kcType :: TCEnv -> String -> Doc -> Kind -> TypeExpr -> KCM ()+kcType tcEnv what doc k ty = do+  k' <- kcTypeExpr tcEnv "type expression" doc' 0 ty+  unify ty what (doc $-$ text "Type:" <+> doc') k k'+  where+    doc' = pPrintPrec 0 ty++kcTypeExpr :: TCEnv -> String -> Doc -> Int -> TypeExpr -> KCM Kind+kcTypeExpr tcEnv _ _ n (ConstructorType p tc) = do+  m <- getModuleIdent+  case qualLookupTypeInfo tc tcEnv of+    [AliasType _ _ n' _] -> case n >= n' of+      True -> return $ tcKind m tc tcEnv+      False -> do+        report $ errPartialAlias p tc n' n+        freshKindVar+    _ -> return $ tcKind m tc tcEnv+kcTypeExpr tcEnv what doc n (ApplyType p ty1 ty2) = do+  (alpha, beta) <- kcTypeExpr tcEnv what doc (n + 1) ty1 >>=+    kcArrow p what (doc $-$ text "Type:" <+> pPrintPrec 0 ty1)+  kcTypeExpr tcEnv what doc 0 ty2 >>=+    unify p what (doc $-$ text "Type:" <+> pPrintPrec 0 ty2) alpha+  return beta+kcTypeExpr tcEnv _ _ _      (VariableType _ tv) = return (varKind tv tcEnv)+kcTypeExpr tcEnv what doc _ (TupleType _ tys) = do+  mapM_ (kcValueType tcEnv what doc) tys+  return KindStar+kcTypeExpr tcEnv what doc _ (ListType _ ty) = do+  kcValueType tcEnv what doc ty+  return KindStar+kcTypeExpr tcEnv what doc _ (ArrowType _ ty1 ty2) = do+  kcValueType tcEnv what doc ty1+  kcValueType tcEnv what doc ty2+  return KindStar+kcTypeExpr tcEnv what doc n (ParenType _ ty) = kcTypeExpr tcEnv what doc n ty+kcTypeExpr tcEnv what doc n (ForallType _ vs ty) = do+  tcEnv' <- foldM bindFreshKind tcEnv vs+  kcTypeExpr tcEnv' what doc n ty++kcArrow :: HasSpanInfo p => p -> String -> Doc -> Kind -> KCM (Kind, Kind)+kcArrow p what doc k = do+  theta <- getKindSubst+  case subst theta k of+    KindStar -> do+      report $ errNonArrowKind p what doc KindStar+      (,) <$> freshKindVar <*> freshKindVar+    KindVariable kv -> do+      alpha <- freshKindVar+      beta <- freshKindVar+      modifyKindSubst $ bindVar kv $ KindArrow alpha beta+      return (alpha, beta)+    KindArrow k1 k2 -> return (k1, k2)++-- ---------------------------------------------------------------------------+-- Unification+-- ---------------------------------------------------------------------------++-- The unification uses Robinson's algorithm.+unify :: HasSpanInfo p => p -> String -> Doc -> Kind -> Kind -> KCM ()+unify p what doc k1 k2 = do+  theta <- getKindSubst+  let k1' = subst theta k1+  let k2' = subst theta k2+  case unifyKinds k1' k2' of+    Nothing -> report $ errKindMismatch p what doc k1' k2'+    Just sigma -> modifyKindSubst (compose sigma)++unifyKinds :: Kind -> Kind -> Maybe KindSubst+unifyKinds KindStar KindStar = Just idSubst+unifyKinds (KindVariable kv1) (KindVariable kv2)+  | kv1 == kv2 = Just idSubst+  | otherwise  = Just (singleSubst kv1 (KindVariable kv2))+unifyKinds (KindVariable kv) k+  | kv `elem` kindVars k = Nothing+  | otherwise            = Just (singleSubst kv k)+unifyKinds k (KindVariable kv)+  | kv `elem` kindVars k = Nothing+  | otherwise            = Just (singleSubst kv k)+unifyKinds (KindArrow k11 k12) (KindArrow k21 k22) = do+  theta <- unifyKinds k11 k21+  theta' <- unifyKinds (subst theta k12) (subst theta k22)+  Just (compose theta' theta)+unifyKinds _ _ = Nothing++-- ---------------------------------------------------------------------------+-- Fresh variables+-- ---------------------------------------------------------------------------++fresh :: (Int -> a) -> KCM a+fresh f = f <$> getNextId++freshKindVar :: KCM Kind+freshKindVar = fresh KindVariable++-- ---------------------------------------------------------------------------+-- Auxiliary definitions+-- ---------------------------------------------------------------------------++typeConstructor :: Decl a -> Ident+typeConstructor (DataDecl     _ tc _ _ _) = tc+typeConstructor (ExternalDataDecl _ tc _) = tc+typeConstructor (NewtypeDecl  _ tc _ _ _) = tc+typeConstructor (TypeDecl     _ tc _ _  ) = tc+typeConstructor _                        =+  internalError "Checks.KindCheck.typeConstructor: no type declaration"++isTypeOrNewtypeDecl :: Decl a -> Bool+isTypeOrNewtypeDecl (NewtypeDecl _ _ _ _ _) = True+isTypeOrNewtypeDecl (TypeDecl      _ _ _ _) = True+isTypeOrNewtypeDecl _                       = False++-- ---------------------------------------------------------------------------+-- Error messages+-- ---------------------------------------------------------------------------++errRecursiveTypes :: [Ident] -> Message+errRecursiveTypes []       = internalError+  "KindCheck.errRecursiveTypes: empty list"+errRecursiveTypes [tc]     = spanInfoMessage tc $ hsep $ map text+  ["Recursive synonym or renaming type", idName tc]+errRecursiveTypes (tc:tcs) = spanInfoMessage tc $+  text "Mutually recursive synonym and/or renaming types" <+>+    text (idName tc) <> types empty tcs+  where+    types _   []         = empty+    types del [tc']      = del <> space <> text "and" <+> typePos tc'+    types _   (tc':tcs') = comma <+> typePos tc' <> types comma tcs'+    typePos tc' =+      text (idName tc') <+> parens (text $ showLine $ getPosition tc')++errRecursiveClasses :: [Ident] -> Message+errRecursiveClasses []         = internalError+  "KindCheck.errRecursiveClasses: empty list"+errRecursiveClasses [cls]      = spanInfoMessage cls $ hsep $ map text+  ["Recursive type class", idName cls]+errRecursiveClasses (cls:clss) = spanInfoMessage cls $+  text "Mutually recursive type classes" <+> text (idName cls) <>+    classes empty clss+  where+    classes _   []           = empty+    classes del [cls']       = del <> space <> text "and" <+> classPos cls'+    classes _   (cls':clss') = comma <+> classPos cls' <> classes comma clss'+    classPos cls' =+      text (idName cls') <+> parens (text $ showLine $ getPosition cls')++errNonArrowKind :: HasSpanInfo p => p -> String -> Doc -> Kind -> Message+errNonArrowKind p what doc k = spanInfoMessage p $ vcat+  [ text "Kind error in" <+> text what, doc+  , text "Kind:" <+> ppKind k+  , text "Cannot be applied"+  ]++errPartialAlias :: HasSpanInfo p => p -> QualIdent -> Int -> Int -> Message+errPartialAlias p tc arity argc = spanInfoMessage p $ hsep+  [ text "Type synonym", ppQIdent tc+  , text "requires at least"+  , int arity, text (plural arity "argument") <> comma+  , text "but is applied to only", int argc+  ]+  where+    plural n x = if n == 1 then x else x ++ "s"++errKindMismatch :: HasSpanInfo p => p -> String -> Doc -> Kind -> Kind -> Message+errKindMismatch p what doc k1 k2 = spanInfoMessage p $ vcat+  [ text "Kind error in"  <+> text what, doc+  , text "Inferred kind:" <+> ppKind k2+  , text "Expected kind:" <+> ppKind k1+  ]
+ src/Checks/PrecCheck.hs view
@@ -0,0 +1,515 @@+{- |+    Module      :  $Header$+    Description :  Checks precedences of infix operators+    Copyright   :  (c) 2001 - 2004 Wolfgang Lux+                                   Martin Engelke+                                   Björn Peemöller+                       2015        Jan Tikovsky+                       2016        Finn Teegen+    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.SpanInfo+import Curry.Base.Span+import Curry.Base.Pretty+import Curry.Syntax++import Base.Expr+import Base.Messages (Message, spanInfoMessage, internalError)+import Base.Utils    (findMultiples)++import Env.OpPrec (OpPrecEnv, OpPrec (..), PrecInfo (..), defaultP, bindP+  , mkPrec, qualLookupP)++precCheck :: ModuleIdent -> OpPrecEnv -> [Decl a] -> ([Decl a], 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 a] -> PCM ()+bindPrecs ds0 = 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 ds0+    innerDs           = [ d | ClassDecl _ _ _ _ _ ds <- ds0, d <- ds ]+    opFixDecls        = [ op | InfixDecl _ _ _ ops <- fixDs, op <- ops ]+    -- Unrenaming is necessary for inner class declarations, because operators+    -- within class declarations have been renamed during syntax checking.+    bvs               = concatMap boundValues nonFixDs +++                          map unRenameIdent (concatMap boundValues innerDs)++bindPrec :: ModuleIdent -> Decl a -> 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 a -> [Ident]+boundValues (DataDecl     _ _ _ cs _) = [ v | c <- cs+                                            , v <- constrId c : recordLabels c]+boundValues (NewtypeDecl  _ _ _ nc _) = nconstrId nc : nrecordLabels nc+boundValues (TypeSig          _ fs _) = fs+boundValues (FunctionDecl    _ _ f _) = [f]+boundValues (ExternalDecl       _ vs) = bv vs+boundValues (PatternDecl       _ t _) = bv t+boundValues (FreeDecl           _ vs) = bv 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 a] -> PCM [Decl a]+checkDecls decls = bindPrecs decls >> mapM checkDecl decls++checkDecl :: Decl a -> PCM (Decl a)+checkDecl (FunctionDecl p a f           eqs) =+  FunctionDecl p a f <$> mapM checkEquation eqs+checkDecl (PatternDecl  p t             rhs) =+  PatternDecl p <$> checkPattern t <*> checkRhs rhs+checkDecl (ClassDecl p li cx cls    tv   ds) =+  ClassDecl p li cx cls tv <$> mapM checkDecl ds+checkDecl (InstanceDecl p li cx qcls   inst ds) =+  InstanceDecl p li cx qcls inst <$> mapM checkDecl ds+checkDecl d                                  = return d++checkEquation :: Equation a -> PCM (Equation a)+checkEquation (Equation p lhs rhs) =+  Equation p <$> checkLhs lhs <*> checkRhs rhs++checkLhs :: Lhs a -> PCM (Lhs a)+checkLhs (FunLhs spi     f ts) = FunLhs spi f <$> mapM checkPattern ts+checkLhs (OpLhs  spi t1 op t2) =+  flip (OpLhs spi) op <$> (checkPattern t1 >>= checkOpL op)+                      <*> (checkPattern t2 >>= checkOpR op)+checkLhs (ApLhs  spi   lhs ts) =+  ApLhs spi <$> checkLhs lhs <*> mapM checkPattern ts++checkPattern :: Pattern a -> PCM (Pattern a)+checkPattern l@(LiteralPattern        _ _ _) = return l+checkPattern n@(NegativePattern       _ _ _) = return n+checkPattern v@(VariablePattern       _ _ _) = return v+checkPattern (ConstructorPattern spi a c ts) =+  ConstructorPattern spi a c <$> mapM checkPattern ts+checkPattern (InfixPattern   _ a t1 op t2) = do+  t1' <- checkPattern t1+  t2' <- checkPattern t2+  fixPrecT mkInfixPattern t1' op t2'+  where mkInfixPattern t1'' op'' t2'' =+          InfixPattern (t1'' @+@ t2'') a t1'' op'' t2''+checkPattern (ParenPattern              spi t) =+  ParenPattern spi <$> checkPattern t+checkPattern (TuplePattern             spi ts) =+  TuplePattern spi <$> mapM checkPattern ts+checkPattern (ListPattern            spi a ts) =+  ListPattern spi a <$> mapM checkPattern ts+checkPattern (AsPattern               spi v t) =+  AsPattern spi v <$> checkPattern t+checkPattern (LazyPattern               spi t) =+  LazyPattern spi <$> checkPattern t+checkPattern (FunctionPattern      spi a f ts) =+  FunctionPattern spi a f <$> mapM checkPattern ts+checkPattern (InfixFuncPattern _ a t1 op t2) = do+  t1' <- checkPattern t1+  t2' <- checkPattern t2+  fixPrecT mkInfixFuncPattern t1' op t2'+  where mkInfixFuncPattern t1'' op'' t2'' =+          InfixFuncPattern (t1'' @+@ t2'') a t1'' op'' t2''+checkPattern (RecordPattern       spi a c fs) =+  RecordPattern spi a c <$> mapM (checkField checkPattern) fs++checkRhs :: Rhs a -> PCM (Rhs a)+checkRhs (SimpleRhs spi li e ds) = withLocalPrecEnv $+  flip (SimpleRhs spi li) <$> checkDecls ds <*> checkExpr e+checkRhs (GuardedRhs spi li es ds) = withLocalPrecEnv $+  flip (GuardedRhs spi li) <$> checkDecls ds <*> mapM checkCondExpr es++checkCondExpr :: CondExpr a -> PCM (CondExpr a)+checkCondExpr (CondExpr p g e) = CondExpr p <$> checkExpr g <*> checkExpr e++checkExpr :: Expression a -> PCM (Expression a)+checkExpr l@(Literal          _ _ _) = return l+checkExpr v@(Variable         _ _ _) = return v+checkExpr c@(Constructor      _ _ _) = return c+checkExpr (Paren              spi e) = Paren spi <$> checkExpr e+checkExpr (Typed           spi e ty) = flip (Typed spi) ty <$> checkExpr e+checkExpr (Record        spi a c fs) = Record spi a c <$> mapM (checkField checkExpr) fs+checkExpr (RecordUpdate    spi e fs) = RecordUpdate spi <$> checkExpr e+                                                       <*> mapM (checkField checkExpr) fs+checkExpr (Tuple            spi es) = Tuple spi <$> mapM checkExpr es+checkExpr (List           spi a es) = List spi a <$> mapM checkExpr es+checkExpr (ListCompr      spi e qs) = withLocalPrecEnv $+  flip (ListCompr spi) <$> mapM checkStmt qs <*> checkExpr e+checkExpr (EnumFrom              spi e) = EnumFrom spi <$> checkExpr e+checkExpr (EnumFromThen      spi e1 e2) =+  EnumFromThen spi <$> checkExpr e1 <*> checkExpr e2+checkExpr (EnumFromTo        spi e1 e2) =+  EnumFromTo spi <$> checkExpr e1 <*> checkExpr e2+checkExpr (EnumFromThenTo spi e1 e2 e3) =+  EnumFromThenTo spi <$> checkExpr e1 <*> checkExpr e2 <*> checkExpr e3+checkExpr (UnaryMinus            spi e) = UnaryMinus spi <$> checkExpr e+checkExpr (Apply spi e1 e2) =+  Apply spi <$> checkExpr e1 <*> checkExpr e2+checkExpr (InfixApply spi e1 op e2) = do+  e1' <- checkExpr e1+  e2' <- checkExpr e2+  fixPrec spi e1' op e2'+checkExpr (LeftSection    spi   e op) = checkExpr e >>= checkLSection spi op+checkExpr (RightSection   spi   op e) = checkExpr e >>= checkRSection spi op+checkExpr (Lambda         spi   ts e) =+  Lambda spi <$> mapM checkPattern ts <*> checkExpr e+checkExpr (Let           spi li ds e) = withLocalPrecEnv $+  Let spi li <$> checkDecls ds <*> checkExpr e+checkExpr (Do           spi li sts e) = withLocalPrecEnv $+  Do spi li <$>  mapM checkStmt sts <*> checkExpr e+checkExpr (IfThenElse   spi e1 e2 e3) =+  IfThenElse spi <$> checkExpr e1 <*> checkExpr e2 <*> checkExpr e3+checkExpr (Case     spi li ct e alts) =+  Case spi li ct <$> checkExpr e <*> mapM checkAlt alts++checkStmt :: Statement a -> PCM (Statement a)+checkStmt (StmtExpr spi     e) =+  StmtExpr spi    <$> checkExpr e+checkStmt (StmtDecl spi li ds) =+  StmtDecl spi li <$> checkDecls ds+checkStmt (StmtBind spi   t e) =+  StmtBind spi    <$> checkPattern t <*> checkExpr e++checkAlt :: Alt a -> PCM (Alt a)+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 :: SpanInfo -> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)+fixPrec spi (UnaryMinus spi' e1) op e2 = do+  OpPrec fix pr <- getOpPrec op+  if pr < 6 || pr == 6 && fix == InfixL+    then fixRPrec spi (UnaryMinus spi' e1) op e2+    else if pr > 6+      then fixUPrec spi' e1 op e2+      else do+        report $ errAmbiguousParse "unary" (qualify minusId) (opName op)+        return $ InfixApply spi (UnaryMinus spi' e1) op e2+fixPrec spi e1 op e2 = fixRPrec spi e1 op e2++fixUPrec :: SpanInfo -> Expression a -> InfixOp a -> Expression a+         -> PCM (Expression a)+fixUPrec spi e1 op e2@(UnaryMinus spi' _) = do+  report $ errAmbiguousParse "operator" (opName op) (qualify minusId)+  return $ UnaryMinus spi' (InfixApply spi e1 op e2)+fixUPrec spi e1 op1 e'@(InfixApply spi' e2 op2 e3) = do+  OpPrec fix2 pr2 <- getOpPrec op2+  if pr2 < 6 || pr2 == 6 && fix2 == InfixL+    then do+      left <- fixUPrec spi e1 op1 e2+      return $ InfixApply (left @+@ e3) left op2 e3+    else if pr2 > 6+      then do+        op <- fixRPrec spi e1 op1 $ InfixApply spi' e2 op2 e3+        return $ updateEndPos $ UnaryMinus spi' op+      else do+        report $ errAmbiguousParse "unary" (qualify minusId) (opName op2)+        let left = updateEndPos (UnaryMinus spi' e1)+        return $ InfixApply (left @+@ e') left op1 e'+fixUPrec spi e1 op e2 = return $ updateEndPos $ UnaryMinus spi+  (InfixApply (e1 @+@ e2) e1 op e2)++fixRPrec :: SpanInfo -> Expression a -> InfixOp a -> Expression a+         -> PCM (Expression a)+fixRPrec spi e1 op (UnaryMinus spi' e2) = do+  OpPrec _ pr <- getOpPrec op+  unless (pr < 6) $ report $ errAmbiguousParse "operator" (opName op) (qualify minusId)+  return $ InfixApply spi e1 op $ UnaryMinus spi' e2+fixRPrec spi e1 op1 (InfixApply spi' 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 spi e1 op1 $ InfixApply spi' e2 op2 e3+     else if pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL+       then do+          left <- fixPrec (e1 @+@ e2) e1 op1 e2+          return $ InfixApply (left @+@ e3) left op2 e3+       else do+         report $ errAmbiguousParse "operator" (opName op1) (opName op2)+         return $ InfixApply spi e1 op1 $ InfixApply spi' e2 op2 e3+fixRPrec spi e1 op e2 = return $ InfixApply spi 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 :: SpanInfo -> InfixOp a -> Expression a -> PCM (Expression a)+checkLSection spi op e@(UnaryMinus _ _) = do+  OpPrec fix pr <- getOpPrec op+  unless (pr < 6 || pr == 6 && fix == InfixL) $+    report $ errAmbiguousParse "unary" (qualify minusId) (opName op)+  return $ LeftSection spi e op+checkLSection spi 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 spi e op1+checkLSection spi op e = return $ LeftSection spi e op++checkRSection :: SpanInfo -> InfixOp a -> Expression a -> PCM (Expression a)+checkRSection spi op e@(UnaryMinus _ _) = do+  OpPrec _ pr <- getOpPrec op+  unless (pr < 6) $ report $ errAmbiguousParse "unary" (qualify minusId) (opName op)+  return $ RightSection spi op e+checkRSection spi 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 spi op1 e+checkRSection spi op e = return $ RightSection spi 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 a -> QualIdent -> Pattern a -> Pattern a)+         -> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)+fixPrecT infixpatt t1@(NegativePattern _ _ _) op t2 = do+  OpPrec fix pr <- prec op <$> getPrecEnv+  unless (pr < 6 || pr == 6 && fix == InfixL) $+    report $ errInvalidParse "unary operator" minusId op+  fixRPrecT infixpatt t1 op t2+fixPrecT infixpatt t1 op t2 = fixRPrecT infixpatt t1 op t2++fixRPrecT :: (Pattern a -> QualIdent -> Pattern a -> Pattern a)+          -> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)+fixRPrecT infixpatt t1 op t2@(NegativePattern _ _ _) = do+  OpPrec _ pr <- prec op <$> getPrecEnv+  unless (pr < 6) $ report $ errInvalidParse "unary operator" minusId op+  return $ infixpatt t1 op t2+fixRPrecT infixpatt t1 op1 (InfixPattern spi a 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 spi a t2 op2 t3)+    else if pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL+      then do+        left <- fixPrecT infixpatt t1 op1 t2+        return $ InfixPattern (left @+@ t3) a left op2 t3+      else do+        report $ errAmbiguousParse "operator" op1 op2+        return $ infixpatt t1 op1 (InfixPattern spi a t2 op2 t3)+fixRPrecT infixpatt t1 op1 (InfixFuncPattern spi a 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 spi a t2 op2 t3)+    else if pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL+      then do+        left <- fixPrecT infixpatt t1 op1 t2+        return $ InfixFuncPattern (left @+@ t3) a left op2 t3+      else do+        report $ errAmbiguousParse "operator" op1 op2+        return $ infixpatt t1 op1 (InfixFuncPattern spi a 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 a -> PCM (Pattern a)+checkOpL op t@(NegativePattern _ _ _) = do+  OpPrec fix pr <- prec (qualify op) <$> getPrecEnv+  unless (pr < 6 || pr == 6 && fix == InfixL) $+    report $ errInvalidParse "unary operator" minusId (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 a -> PCM (Pattern a)+checkOpR op t@(NegativePattern _ _ _) = do+  OpPrec _ pr <- prec (qualify op)  <$> getPrecEnv+  when (pr >= 6) $ report $ errInvalidParse "unary operator" minusId (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 ambiguoeus identifiers here.+-- This may happen while checking the root of an operator definition that+-- shadows an imported definition.++getOpPrec :: InfixOp a -> PCM OpPrec+getOpPrec op = opPrec op <$> getPrecEnv++opPrec :: InfixOp a -> OpPrecEnv -> OpPrec+opPrec op = prec (opName op)++prec :: QualIdent -> OpPrecEnv -> OpPrec+prec op env = case qualLookupP op env of+  [] -> defaultP+  PrecInfo _ p : _ -> p+++-- Combine two entities with SpanInfo to a new SpanInfo (discarding info points)+(@+@) :: (HasSpanInfo a, HasSpanInfo b) => a -> b -> SpanInfo+a @+@ b = fromSrcSpan (combineSpans (getSrcSpan a) (getSrcSpan b))++-- ---------------------------------------------------------------------------+-- Error messages+-- ---------------------------------------------------------------------------++errUndefinedOperator :: Ident -> Message+errUndefinedOperator op = spanInfoMessage op $ hsep $ map text+  ["No definition for", escName op, "in this scope"]++errMultiplePrecedence :: [Ident] -> Message+errMultiplePrecedence []       = internalError+  "PrecCheck.errMultiplePrecedence: empty list"+errMultiplePrecedence (op:ops) = spanInfoMessage 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 = spanInfoMessage op1 $ hsep $ map text+  [ "Invalid use of", what, escName op1, "with", escQualName op2, "in"+  , showLine $ getPosition op2]++-- FIXME: Messages may have missing positions for minus operators+-- TODO: Is this still true after span update for parser?++errAmbiguousParse :: String -> QualIdent -> QualIdent -> Message+errAmbiguousParse what op1 op2 = spanInfoMessage op1 $ hsep $ map text+  ["Ambiguous use of", what, escQualName op1, "with", escQualName op2, "in"+  , showLine $ getPosition op2]
+ src/Checks/SyntaxCheck.hs view
@@ -0,0 +1,1430 @@+{- |+    Module      :  $Header$+    Description :  Syntax checks+    Copyright   :  (c) 1999 - 2004 Wolfgang Lux+                                   Martin Engelke+                                   Björn Peemöller+                       2015        Jan Tikovsky+                       2016        Finn Teegen+    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__ >= 804+import Prelude hiding ((<>))+#endif++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative        ((<$>), (<*>))+#endif++import           Control.Monad       (unless, when)+import qualified Control.Monad.State as S (State, gets, modify, runState,+                                           withState)+import           Data.Function       (on)+import           Data.List           (insertBy, intersect, nub, nubBy)+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, toList, union)++import           Curry.Base.Ident+import           Curry.Base.Position+import           Curry.Base.Pretty+import           Curry.Base.Span+import           Curry.Base.SpanInfo+import           Curry.Syntax++import           Base.Expr+import           Base.Messages       (Message, internalError,+                                      spanInfoMessage)+import           Base.NestEnv+import           Base.SCC            (scc)+import           Base.Utils          (findDouble, findMultiples, (++!))++import           Env.TypeConstructor (TCEnv, clsMethods, getOrigName)+import           Env.Value           (ValueEnv, ValueInfo (..),+                                      qualLookupValueUnique)+++-- 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. If a record+-- identifier is already assigned to a constructor, then an error will be+-- generated. Class methods defined in the current module are entered into+-- the environment, too. Finally, all declarations are checked within the+-- resulting environment. In addition, this process will also rename the+-- local variables.++-- TODO: use SpanInfos for errors and then stop passing down SpanInfo from the decls to the checks++syntaxCheck :: [KnownExtension] -> TCEnv -> ValueEnv -> Module ()+            -> ((Module (), [KnownExtension]), [Message])+syntaxCheck exts tcEnv vEnv mdl@(Module _ _ _ m _ _ ds) =+  case findMultiples cons of+    []  -> case findMultiples (ls ++ fs ++ cons ++ cs) 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+    cds   = filter isClassDecl ds+    cons  = concatMap constrs tds+    ls    = nub $ concatMap recLabels tds+    fs    = nub $ concatMap vars vds+    cs    = concatMap (concatMap methods) [ds' | ClassDecl _ _ _ _ _ ds' <- cds]+    rEnv  = globalEnv $ fmap renameInfo vEnv+    state = initState exts m tcEnv rEnv vEnv++-- 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+  , tyConsEnv        :: TCEnv+  , renameEnv        :: RenameEnv        -- ^ Information store+  , valueEnv         :: ValueEnv         -- ^ To check instance method visibility+  , scopeId          :: Integer          -- ^ Identifier for the current scope+  , nextId           :: Integer          -- ^ Next fresh identifier+  , funcDeps         :: FuncDeps         -- ^ Stores data about functions dependencies+  , typeClassesCheck :: Bool+  , errors           :: [Message]        -- ^ Syntactic errors in the module+  }++-- |Initial syntax check state+initState :: [KnownExtension] -> ModuleIdent -> TCEnv -> RenameEnv -> ValueEnv+          -> SCState+initState exts m tcEnv rEnv vEnv =+  SCState exts m tcEnv rEnv vEnv globalScopeId 1 noFuncDeps False []++-- |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 'TCEnv'+getTyConsEnv :: SCM TCEnv+getTyConsEnv = S.gets tyConsEnv++-- |Retrieve the 'RenameEnv'+getRenameEnv :: SCM RenameEnv+getRenameEnv = S.gets renameEnv++-- |Retrieve the 'ValueEnv'+getValueEnv :: SCM ValueEnv+getValueEnv = S.gets valueEnv++-- |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++-- |Checks whether a type classes check is running+isTypeClassesCheck :: SCM Bool+isTypeClassesCheck = S.gets typeClassesCheck++-- |Performs a type classes check in a nested scope+performTypeClassesCheck :: SCM a -> SCM a+performTypeClassesCheck = inNestedScope .+  S.withState (\s -> s { typeClassesCheck = True })++-- |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 :: Bool -> ModuleIdent -> Ident -> RenameInfo -> RenameEnv+           -> RenameEnv+bindGlobal tcc m c r+  | not tcc   = bindNestEnv c r . qualBindNestEnv (qualifyWith m c) r+  | otherwise = id++bindLocal :: Ident -> RenameInfo -> RenameEnv -> RenameEnv+bindLocal = bindNestEnv++-- ------------------------------------------------------------------------------++-- |Bind type constructor information and record label information+bindTypeDecl :: Decl a -> SCM ()+bindTypeDecl (DataDecl    _ _ _ cs _) =+  mapM_ bindConstr cs >> bindRecordLabels cs+bindTypeDecl (NewtypeDecl _ _ _ nc _) = bindNewConstr nc+bindTypeDecl _                        = ok++bindConstr :: ConstrDecl -> SCM ()+bindConstr (ConstrDecl _ c tys) = do+  m <- getModuleIdent+  modifyRenameEnv $ bindGlobal False m c (Constr (qualifyWith m c) $ length tys)+bindConstr (ConOpDecl _ _ op _) = do+  m <- getModuleIdent+  modifyRenameEnv $ bindGlobal False m op (Constr (qualifyWith m op) 2)+bindConstr (RecordDecl _ c fs)  = do+  m <- getModuleIdent+  modifyRenameEnv $ bindGlobal False 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 False m c (Constr (qualifyWith m c) 1)+bindNewConstr (NewRecordDecl _ c (l, _)) = do+  m <- getModuleIdent+  bindRecordLabel (l, [c])+  modifyRenameEnv $ bindGlobal False 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 False m l $+    RecordLabel (qualifyWith m l) (map (qualifyWith m) cs)++-- ------------------------------------------------------------------------------++-- |Bind a global function declaration in the 'RenameEnv'+bindFuncDecl :: Bool -> ModuleIdent -> Decl a -> RenameEnv -> RenameEnv+bindFuncDecl _   _ (FunctionDecl _ _ _ []) _+  = internalError "SyntaxCheck.bindFuncDecl: no equations"+bindFuncDecl tcc m (FunctionDecl _ _ f (eq:_)) env+  = let arty = length $ snd $ getFlatLhs eq+    in  bindGlobal tcc m f (GlobalVar (qualifyWith m f) arty) env+bindFuncDecl tcc m (TypeSig _ fs (QualTypeExpr _ _ ty)) env+  = foldr (bindTS . qualifyWith m) env fs+  where+    bindTS qf env'+      | null $ qualLookupVar qf env'+        = bindGlobal tcc m (unqualify qf) (GlobalVar qf (typeArity ty)) env'+      | otherwise = env'+bindFuncDecl _   _ _ env = env++-- ------------------------------------------------------------------------------++-- |Bind type class information, i.e. class methods+bindClassDecl :: Decl a -> SCM ()+bindClassDecl (ClassDecl _ _ _ _ _ ds) = mapM_ bindClassMethod ds+bindClassDecl _                        = ok++bindClassMethod :: Decl a -> SCM ()+bindClassMethod ts@(TypeSig _ _ _) = do+  m <- getModuleIdent+  modifyRenameEnv $ bindFuncDecl False m ts+bindClassMethod _ = ok++-- ------------------------------------------------------------------------------++-- |Bind a local declaration (function, variables) in the 'RenameEnv'+bindVarDecl :: Decl a -> 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 . varIdent) 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. Class and instance declarations define their own scope,+-- thus defined functions will be renamed as well. For class and instance+-- declarations several checks have to be disabled (for instance, type+-- signatures without corresponding function declaration are allowed in class+-- declarations), while some have to be performed extra (for instance, no+-- other functions than specified by the type signatures within a class+-- declaration are allowed to be declared).++checkModule :: Module () -> SCM (Module (), [KnownExtension])+checkModule (Module spi li ps m es is ds) = do+  mapM_ bindTypeDecl tds+  mapM_ bindClassDecl cds+  ds' <- checkTopDecls ds+  cds' <- mapM (performTypeClassesCheck . checkClassDecl) cds+  ids' <- mapM (performTypeClassesCheck . checkInstanceDecl) ids+  let ds'' = updateClassAndInstanceDecls cds' ids' ds'+  checkFuncPatDeps+  exts <- getExtensions+  return (Module spi li ps m es is ds'', exts)+  where tds = filter isTypeDecl ds+        cds = filter isClassDecl ds+        ids = filter isInstanceDecl ds++-- |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+  tcc <- isTypeClassesCheck+  checkDeclGroup (bindFuncDecl tcc m) ds++checkClassDecl :: Decl () -> SCM (Decl ())+checkClassDecl (ClassDecl p li cx cls tv ds) = do+  checkMethods (qualify cls) (concatMap methods ds) ds+  ClassDecl p li cx cls tv <$> checkTopDecls ds+checkClassDecl _ =+  internalError "SyntaxCheck.checkClassDecl: no class declaration"++checkInstanceDecl :: Decl () -> SCM (Decl ())+checkInstanceDecl (InstanceDecl p li cx qcls ty ds) = do+  m <- getModuleIdent+  vEnv <- getValueEnv+  tcEnv <- getTyConsEnv+  let clsMthds = clsMethods m qcls tcEnv+  let orig = getOrigName m qcls tcEnv+  let mthds =+        if isLocalIdent m orig+          then clsMthds+          else filter (isFromCls orig m vEnv) clsMthds+  checkMethods qcls mthds ds+  mapM_ checkAmbiguousMethod ds+  InstanceDecl p li cx qcls ty <$> checkTopDecls ds+  where+    isFromCls orig m vEnv f = case qualLookupValueUnique m (qualify f) vEnv of+      [Value _ (Just cls) _ _]+        | cls == orig -> True+      _               -> False++checkInstanceDecl _ =+  internalError "SyntaxCheck.checkInstanceDecl: no instance declaration"++checkAmbiguousMethod :: Decl a -> SCM ()+checkAmbiguousMethod (FunctionDecl _ _ f _) = do+  m <- getModuleIdent+  rename <- getRenameEnv+  case lookupVar f rename of+    rs1@(_:_:_) -> case qualLookupVar (qualifyWith m f) rename of+      []          -> report $ errAmbiguousIdent rs1 (qualify f)+      rs2@(_:_:_) -> report $ errAmbiguousIdent rs2 (qualify f)+      _           -> return ()+    _           -> return ()+checkAmbiguousMethod _ =+  internalError "SyntaxCheck.checkAmbiguousMethod: no function declaration"++checkMethods :: QualIdent -> [Ident] -> [Decl a] -> SCM ()+checkMethods qcls ms ds =+  mapM_ (report . errUndefinedMethod qcls) $ filter (`notElem` ms) fs+  where fs = [f | FunctionDecl _ _ f _ <- ds]++updateClassAndInstanceDecls :: [Decl a] -> [Decl a] -> [Decl a] -> [Decl a]+updateClassAndInstanceDecls [] [] ds = ds+updateClassAndInstanceDecls (c:cs) is (ClassDecl _ _ _ _ _ _:ds) =+  c : updateClassAndInstanceDecls cs is ds+updateClassAndInstanceDecls cs (i:is) (InstanceDecl _ _ _ _ _ _:ds) =+  i : updateClassAndInstanceDecls cs is ds+updateClassAndInstanceDecls cs is (d:ds) =+  d : updateClassAndInstanceDecls cs is ds+updateClassAndInstanceDecls _ _ _ =+  internalError "SyntaxCheck.updateClassAndInstanceDecls"++-- 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 (ExternalDecl          p vs) =+  ExternalDecl p <$> mapM (checkVar' "external declaration") vs+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 :: SpanInfo -> 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 -> Var a -> SCM (Var a)+checkVar' what (Var a v) = Var a <$> checkVar what v++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 :: SpanInfo -> [Equation ()] -> SCM (Decl ())+checkEquationsLhs p [Equation p' lhs rhs] = do+  lhs' <- checkEqLhs p' lhs+  case lhs' of+    Left  l -> return $ funDecl' l+    Right r -> checkDeclLhs (PatternDecl p' r rhs)+  where funDecl' (f, lhs') = FunctionDecl p () f [Equation p' lhs' rhs]+checkEquationsLhs _ _ = internalError "SyntaxCheck.checkEquationsLhs"++checkEqLhs :: SpanInfo -> Lhs () -> SCM (Either (Ident, Lhs ()) (Pattern ()))+checkEqLhs pspi toplhs = do+  m   <- getModuleIdent+  k   <- getScopeId+  env <- getRenameEnv+  case toplhs of+    FunLhs spi f ts+      | not $ isDataConstr f env -> return left+      | k /= globalScopeId       -> return right+      | null infos               -> return left+      | otherwise                -> do report $ errToplevelPattern pspi+                                       return right+      where f'    = renameIdent f k+            infos = qualLookupVar (qualifyWith m f) env+            left  = Left  (f', FunLhs spi f' ts)+            right = Right $  -- use start from the parsed FunLhs and compute end+              updateEndPos $ ConstructorPattern spi () (qualify f) ts+    OpLhs spi t1 op t2+      | not $ isDataConstr op env -> return left+      | k /= globalScopeId        -> return right+      | null infos                -> return left+      | otherwise                 -> do report $ errToplevelPattern pspi+                                        return right+      where op'   = renameIdent op k+            infos = qualLookupVar (qualifyWith m op) env+            left  = Left (op', OpLhs spi t1 op' t2)+            right = checkOpLhs k env (infixPattern t1 (qualify op)) t2+            infixPattern (InfixPattern _ a' t1' op1 t2') op2 t3 =+              let t2'' = infixPattern t2' op2 t3+                  sp = combineSpans (getSrcSpan t1') (getSrcSpan t2'')+              in InfixPattern (fromSrcSpan sp) a' t1' op1 t2''+            infixPattern t1' op1 t2' =+              let sp = combineSpans (getSrcSpan t1') (getSrcSpan t2')+              in InfixPattern (fromSrcSpan sp) () t1' op1 t2'+    ApLhs spi lhs ts -> do+      checked <- checkEqLhs pspi lhs+      case checked of+        Left (f', lhs') -> return $ Left (f', updateEndPos $ ApLhs spi lhs' ts)+        r               -> do report $ errNonVariable "curried definition" f+                              return $ r+        where (f, _) = flatLhs lhs++checkOpLhs :: Integer -> RenameEnv -> (Pattern a -> Pattern a)+           -> Pattern a -> Either (Ident, Lhs a) (Pattern a)+checkOpLhs k env f (InfixPattern spi a t1 op t2)+  | isJust m || isDataConstr op' env+  = checkOpLhs k env (f . InfixPattern spi a t1 op) t2+  | otherwise+  = Left (op'', OpLhs (getSpanInfo t1') t1' op'' t2)+  where (m,op') = (qidModule op, qidIdent op)+        op''    = renameIdent op' k+        t1'     = f t1+checkOpLhs _ _ f t = Right (f t)++-- -- ---------------------------------------------------------------------------++joinEquations :: [Decl a] -> SCM [Decl a]+joinEquations [] = return []+joinEquations (FunctionDecl a p f eqs : FunctionDecl _ _ f' [eq] : ds)+  | f == f' = do+    when (getArity (head eqs) /= getArity eq) $ report $ errDifferentArity [f, f']+    joinEquations (updateEndPos (FunctionDecl a 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 = [v | ExternalDecl _ vs <- ds, Var _ v <- vs, v `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 ok++-- -- ---------------------------------------------------------------------------++checkDeclRhs :: [Ident] -> Decl () -> SCM (Decl ())+checkDeclRhs _   (DataDecl   p tc tvs cs clss) =+  flip (DataDecl p tc tvs) clss <$> mapM checkDeclLabels cs+checkDeclRhs bvs (TypeSig        p vs ty) =+  (\vs' -> TypeSig p vs' ty) <$> mapM (checkLocalVar bvs) vs+checkDeclRhs _   (FunctionDecl a p f eqs) =+  FunctionDecl a 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 ok+    labels = [l | FieldDecl _ ls _ <- fs, l <- ls]+checkDeclLabels d = return d++checkLocalVar :: [Ident] -> Ident -> SCM Ident+checkLocalVar bvs v = do+  tcc <- isTypeClassesCheck+  when (v `notElem` bvs && not tcc) $ 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 :: SpanInfo -> Lhs () -> SCM (Lhs ())+checkLhs p (FunLhs    spi f ts) = FunLhs spi f <$> mapM (checkPattern p) ts+checkLhs p (OpLhs spi t1 op t2) = do+  let wrongCalls = concatMap (checkParenPattern (Just $ qualify op)) [t1,t2]+  unless (null wrongCalls) $ report $ errInfixWithoutParens+    spi wrongCalls+  flip (OpLhs spi) op <$> checkPattern p t1 <*> checkPattern p t2+checkLhs p (ApLhs   spi lhs ts) =+  ApLhs spi <$> checkLhs p lhs <*> mapM (checkPattern p) ts++-- checkParen+-- @param Aufrufende InfixFunktion+-- @param Pattern+-- @return Liste mit fehlerhaften Funktionsaufrufen++checkParenPattern :: Maybe QualIdent -> Pattern a -> [(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 :: SpanInfo -> Pattern () -> SCM (Pattern ())+checkPattern _ (LiteralPattern        spi a l) =+  return $ LiteralPattern spi a l+checkPattern _ (NegativePattern       spi a l) =+  return $ NegativePattern spi a l+checkPattern p (VariablePattern       spi a v)+  | isAnonId v = VariablePattern spi a . renameIdent v <$> newId+  | otherwise  = checkConstructorPattern p spi (qualify v) []+checkPattern p (ConstructorPattern spi _ c ts) =+  checkConstructorPattern p spi c ts+checkPattern p (InfixPattern   spi _ t1 op t2) =+  checkInfixPattern p spi t1 op t2+checkPattern p (ParenPattern            spi t) =+  ParenPattern spi <$> checkPattern p t+checkPattern p (RecordPattern      spi _ c fs) =+  checkRecordPattern p spi c fs+checkPattern p (TuplePattern           spi ts) =+  TuplePattern spi <$> mapM (checkPattern p) ts+checkPattern p (ListPattern          spi a ts) =+  ListPattern spi a <$> mapM (checkPattern p) ts+checkPattern p (AsPattern             spi v t) =+  AsPattern spi <$> checkVar "@ pattern" v <*> checkPattern p t+checkPattern p (LazyPattern             spi t) = do+  t' <- checkPattern p t+  banFPTerm "lazy pattern" p t'+  return (LazyPattern spi t')+checkPattern _ (FunctionPattern     _ _ _ _) = internalError+  "SyntaxCheck.checkPattern: function pattern not defined"+checkPattern _ (InfixFuncPattern  _ _ _ _ _) = internalError+  "SyntaxCheck.checkPattern: infix function pattern not defined"++checkConstructorPattern :: SpanInfo -> SpanInfo -> QualIdent -> [Pattern ()]+                        -> SCM (Pattern ())+checkConstructorPattern p spi 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 spi () $ renameIdent (unqualify c) k+        | null rs -> do+            ts' <- mapM (checkPattern p) ts+            report $ errUndefinedData c+            return $ ConstructorPattern spi () c ts'+      _ -> do ts' <- mapM (checkPattern p) ts+              report $ errAmbiguousData rs c+              return $ ConstructorPattern spi () c ts'+  where+  n' = length ts+  processCons qc n = do+    when (n /= n') $ report $ errWrongArity c n n'+    ConstructorPattern spi () qc <$> mapM (checkPattern p) ts+  processVarFun r k+    | null ts && not (isQualified c)+    = return $ VariablePattern spi () $ renameIdent (unqualify c) k -- (varIdent r) k+    | otherwise = do+      checkFuncPatsExtension p+      checkFuncPatCall r c+      ts' <- mapM (checkPattern p) ts+      mapM_ (checkFPTerm p) ts'+      return $ FunctionPattern spi () (qualVarIdent r) ts'++checkInfixPattern :: SpanInfo -> SpanInfo -> Pattern () -> QualIdent -> Pattern ()+                  -> SCM (Pattern ())+checkInfixPattern p spi 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 spi ()) op <$> checkPattern p t1+                                                  <*> checkPattern p t2+  where+  infixPattern qop n = do+    when (n /= 2) $ report $ errWrongArity op n 2+    flip (InfixPattern spi ()) qop <$> checkPattern p t1 <*> checkPattern p t2+  funcPattern r qop = do+    checkFuncPatsExtension p+    checkFuncPatCall r qop+    ts' <- mapM (checkPattern p) [t1,t2]+    let [t1',t2'] = ts'+    mapM_ (checkFPTerm p) ts'+    return $ InfixFuncPattern spi () t1' qop t2'++checkRecordPattern :: SpanInfo -> SpanInfo -> QualIdent -> [Field (Pattern ())]+                   -> SCM (Pattern ())+checkRecordPattern p spi 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 spi () 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 spi li e ds) = inNestedScope $+  flip (SimpleRhs spi li) <$>+    checkDeclGroup bindVarDecl ds <*>+    checkExpr spi e+checkRhs (GuardedRhs spi li es ds) = inNestedScope $+  flip (GuardedRhs spi li) <$>+    checkDeclGroup bindVarDecl ds <*>+    mapM checkCondExpr es++checkCondExpr :: CondExpr () -> SCM (CondExpr ())+checkCondExpr (CondExpr spi g e) =  CondExpr spi <$> checkExpr spi g <*> checkExpr spi e++checkExpr :: SpanInfo -> Expression () -> SCM (Expression ())+checkExpr _ (Literal       spi a l) = return $ Literal spi a l+checkExpr _ (Variable      spi a v) = checkVariable spi a v+checkExpr _ (Constructor   spi a c) = checkVariable spi a c+checkExpr p (Paren         spi   e) = Paren spi           <$> checkExpr p e+checkExpr p (Typed        spi e ty) = flip (Typed spi) ty <$> checkExpr p e+checkExpr p (Record     spi _ c fs) = checkRecordExpr p spi c fs+checkExpr p (RecordUpdate spi e fs) = checkRecordUpdExpr p spi e fs+checkExpr p (Tuple        spi   es) = Tuple spi <$> mapM (checkExpr p) es+checkExpr p (List         spi a es) = List spi a <$> mapM (checkExpr p) es+checkExpr p (ListCompr    spi e qs) = withLocalEnv $ flip (ListCompr spi) <$>+  -- Note: must be flipped to insert qs into RenameEnv first+  mapM (checkStatement "list comprehension" p) qs <*> checkExpr p e+checkExpr p (EnumFrom              spi e) = EnumFrom spi <$> checkExpr p e+checkExpr p (EnumFromThen      spi e1 e2) =+  EnumFromThen spi <$> checkExpr p e1 <*> checkExpr p e2+checkExpr p (EnumFromTo        spi e1 e2) =+  EnumFromTo spi <$> checkExpr p e1 <*> checkExpr p e2+checkExpr p (EnumFromThenTo spi e1 e2 e3) =+  EnumFromThenTo spi <$> checkExpr p e1 <*> checkExpr p e2 <*> checkExpr p e3+checkExpr p (UnaryMinus            spi e) = UnaryMinus spi <$> checkExpr p e+checkExpr p (Apply             spi e1 e2) =+  Apply spi <$> checkExpr p e1 <*> checkExpr p e2+checkExpr p (InfixApply     spi e1 op e2) =+  InfixApply spi <$> checkExpr p e1 <*> checkOp op <*> checkExpr p e2+checkExpr p (LeftSection        spi e op) =+  LeftSection spi <$> checkExpr p e <*> checkOp op+checkExpr p (RightSection       spi op e) =+  RightSection spi <$> checkOp op <*> checkExpr p e+checkExpr p (Lambda             spi ts e) = inNestedScope $ checkLambda p spi ts e+checkExpr p (Let             spi li ds e) = inNestedScope $+  Let spi li <$> checkDeclGroup bindVarDecl ds <*> checkExpr p e+checkExpr p (Do             spi li sts e) = withLocalEnv $+  Do spi li <$> mapM (checkStatement "do sequence" p) sts <*> checkExpr p e+checkExpr p (IfThenElse     spi e1 e2 e3) =+  IfThenElse spi <$> checkExpr p e1 <*> checkExpr p e2 <*> checkExpr p e3+checkExpr p (Case       spi li ct e alts) =+  Case spi li ct <$> checkExpr p e <*> mapM checkAlt alts++checkLambda :: SpanInfo -> SpanInfo -> [Pattern ()] -> Expression ()+            -> SCM (Expression ())+checkLambda p spi ts e = case findMultiples (bvNoAnon ts) of+  []      -> do+    ts' <- mapM (bindPattern "lambda expression" p) ts+    Lambda spi 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 spi ts <$> checkExpr p e+  where+    bvNoAnon t = filter (not . isAnonId) $ bv t++checkVariable :: SpanInfo -> a -> QualIdent -> SCM (Expression a)+checkVariable spi a v+    -- anonymous free variable+  | isAnonId (unqualify v) = do+    checkAnonFreeVarsExtension $ getSpanInfo v+    (\n -> Variable spi a $ updQualIdent id (`renameIdent` n) v) <$> newId+    -- return $ Variable v+    -- normal variable+  | otherwise             = do+    env <- getRenameEnv+    case qualLookupVar v env of+      []              -> do report $ errUndefinedVariable v+                            return $ Variable spi a v+      [Constr    _ _]   -> return $ Constructor spi a v+      [GlobalVar f _]   -> addGlobalDep f >> return (Variable spi a v)+      [LocalVar v' _]   -> return $ Variable spi a+                                  $ qualify+                                  $ spanInfoLike v' (qidIdent v)+      [RecordLabel _ _] -> return $ Variable spi a v+      rs -> do+        m <- getModuleIdent+        case qualLookupVar (qualQualify m v) env of+          []              -> do report $ errAmbiguousIdent rs v+                                return $ Variable spi a v+          [Constr    _ _]   -> return $ Constructor spi a v+          [GlobalVar f _]   -> addGlobalDep f >> return (Variable spi a v)+          [LocalVar v' _]   -> return $ Variable spi a+                                      $ qualify+                                      $ spanInfoLike v' (qidIdent v)+          [RecordLabel _ _] -> return $ Variable spi a v+          rs'               -> do report $ errAmbiguousIdent rs' v+                                  return $ Variable spi a v++checkRecordExpr :: SpanInfo -> SpanInfo -> QualIdent -> [Field (Expression ())]+                -> SCM (Expression ())+checkRecordExpr _ spi c [] = do+  m   <- getModuleIdent+  env <- getRenameEnv+  case qualLookupVar c env of+    [Constr _ _] -> return $ Record spi () c []+    rs           -> case qualLookupVar (qualQualify m c) env of+      [Constr _ _] -> return $ Record spi () c []+      rs'          -> if null rs && null rs'+                         then do report $ errUndefinedData c+                                 return $ Record spi () c []+                         else do report $ errAmbiguousData rs c+                                 return $ Record spi () c []+checkRecordExpr p spi c fs =+  checkExpr p (RecordUpdate spi (Constructor (getSpanInfo c) () c)+                fs)++checkRecordUpdExpr :: SpanInfo -> SpanInfo -> Expression ()+                   -> [Field (Expression ())] -> SCM (Expression ())+checkRecordUpdExpr p spi e fs = do+  e'  <- checkExpr p e+  fs' <- mapM (checkField (checkExpr p)) fs+  case e' of+    Constructor _ a c -> do checkFieldLabels "construction" p (Just c) fs'+                            return $ Record spi a c fs'+    _                 -> do checkFieldLabels "update" p Nothing fs'+                            return $ RecordUpdate spi 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 -> SpanInfo -> Statement () -> SCM (Statement ())+checkStatement _ p (StmtExpr spi     e) = StmtExpr spi <$> checkExpr p e+checkStatement s p (StmtBind spi   t e) =+  flip (StmtBind spi) <$> checkExpr p e <*> (incNesting >> bindPattern s p t)+checkStatement _ _ (StmtDecl spi li ds) =+  StmtDecl spi li <$> (incNesting >> checkDeclGroup bindVarDecl ds)++bindPattern :: String -> SpanInfo -> Pattern () -> SCM (Pattern ())+bindPattern s p t = do+  t' <- checkPattern p t+  banFPTerm s p t'+  addBoundVariables True t'++banFPTerm :: String -> SpanInfo -> Pattern a -> 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 a -> SCM (InfixOp a)+checkOp op = do+  env <- getRenameEnv+  case qualLookupVar v env of+    []              -> report (errUndefinedVariable v) >> return op+    [Constr _ _]    -> return $ InfixConstr a v+    [GlobalVar f _] -> addGlobalDep f >> return (InfixOp a v)+    [LocalVar v' _] -> return $ InfixOp a $ qualify v'+    rs              -> do+      m <- getModuleIdent+      case qualLookupVar (qualQualify m v) env of+        []              -> report (errAmbiguousIdent rs v) >> return op+        [Constr _ _]    -> return $ InfixConstr a v+        [GlobalVar f _] -> addGlobalDep f >> return (InfixOp a v)+        [LocalVar v' _] -> return $ InfixOp a $ qualify v'+        rs'             -> report (errAmbiguousIdent rs' v) >> return op+  where v = opName op+        a = opAnnotation op++checkAlt :: Alt () -> SCM (Alt ())+checkAlt (Alt spi t rhs) = inNestedScope $+  Alt spi <$> bindPattern "case expression" spi 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 -> SpanInfo -> 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 ok++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 :: SpanInfo -> 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+  | not (null (foldr1 intersect css)) ||+    any null css = ok+  | otherwise    = 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 a -> [Ident]+constrs (DataDecl    _ _ _ cs _) = map constrId cs+constrs (NewtypeDecl _ _ _ nc _) = [nconstrId nc]+constrs _                        = []++vars :: Decl a -> [Ident]+vars (TypeSig          _ fs _) = fs+vars (FunctionDecl    _ _ f _) = [f]+vars (ExternalDecl       _ vs) = bv vs+vars (PatternDecl       _ t _) = bv t+vars (FreeDecl           _ vs) = bv vs+vars _                         = []++recLabels :: Decl a -> [Ident]+recLabels (DataDecl    _ _ _ cs _) = concatMap recordLabels cs+recLabels (NewtypeDecl _ _ _ nc _) = nrecordLabels nc+recLabels _                        = []++-- Since the compiler expects all rules of the same function to be together,+-- it is necessary to sort the list of declarations.++sortFuncDecls :: [Decl a] -> [Decl a]+sortFuncDecls = sortFD Set.empty []+ 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 a -> Decl a -> 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"++checkFPTerm :: SpanInfo -> Pattern a -> 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 :: SpanInfo -> SCM ()+checkFuncPatsExtension spi = checkUsedExtension spi+  "Functional Patterns" FunctionalPatterns++checkAnonFreeVarsExtension :: SpanInfo -> SCM ()+checkAnonFreeVarsExtension spi = checkUsedExtension spi+  "Anonymous free variables" AnonFreeVars++checkUsedExtension :: SpanInfo -> String -> KnownExtension -> SCM ()+checkUsedExtension spi msg ext = do+  enabled <- hasExtension ext+  unless enabled $ do+    report $ errMissingLanguageExtension spi msg ext+    enableExtension ext -- to avoid multiple warnings++typeArity :: TypeExpr -> Int+typeArity (ArrowType _ _ t2) = 1 + typeArity t2+typeArity _                  = 0++getFlatLhs :: Equation a -> (Ident, [Pattern a])+getFlatLhs (Equation  _ lhs _) = flatLhs lhs++opAnnotation :: InfixOp a -> a+opAnnotation (InfixOp     a _) = a+opAnnotation (InfixConstr a _) = a++-- ---------------------------------------------------------------------------+-- Error messages+-- ---------------------------------------------------------------------------++errUnsupportedFPTerm :: String -> SpanInfo -> Pattern a -> Message+errUnsupportedFPTerm s spi pat = spanInfoMessage spi $ text s+  <+> text "patterns are not supported inside a functional pattern."+  $+$ pPrintPrec 0 pat++errUnsupportedFuncPattern :: String -> SpanInfo -> Pattern a -> Message+errUnsupportedFuncPattern s spi pat = spanInfoMessage spi $+  text "Functional patterns are not supported inside a" <+> text s <> dot+  $+$ pPrintPrec 0 pat++errFuncPatNotGlobal :: QualIdent -> Message+errFuncPatNotGlobal f = spanInfoMessage f $ hsep $ map text+  ["Function", escQualName f, "in functional pattern is not global"]++errFuncPatCyclic :: QualIdent -> QualIdent -> Message+errFuncPatCyclic fp f = spanInfoMessage fp $ hsep $ map text+  [ "Function", escName $ unqualify fp, "used in functional pattern depends on"+  , escName $ unqualify f, " causing a cyclic dependency"]++errPrecedenceOutOfRange :: SpanInfo -> Integer -> Message+errPrecedenceOutOfRange spi i = spanInfoMessage spi $ hsep $ map text+  ["Precedence out of range:", show i]++errUndefinedVariable :: QualIdent -> Message+errUndefinedVariable v = spanInfoMessage v $ hsep $ map text+  [escQualName v, "is undefined"]++errUndefinedData :: QualIdent -> Message+errUndefinedData c = spanInfoMessage c $ hsep $ map text+  ["Undefined data constructor", escQualName c]++errUndefinedLabel :: QualIdent -> Message+errUndefinedLabel l = spanInfoMessage l $  hsep $ map text+  ["Undefined record label", escQualName l]++errUndefinedMethod :: QualIdent -> Ident -> Message+errUndefinedMethod qcls f = spanInfoMessage f $ hsep $ map text+  [escName f, "is not a (visible) method of class", escQualName qcls]++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 = spanInfoMessage qn+  $   text "Ambiguous" <+> text what <+> text (escQualName qn)+  $+$ text "It could refer to:"+  $+$ nest 2 (vcat (map ppRenameInfo rs))++errDuplicateDefinition :: Ident -> Message+errDuplicateDefinition v = spanInfoMessage v $ hsep $ map text+  ["More than one definition for", escName v]++errDuplicateVariables :: [Ident] -> Message+errDuplicateVariables [] = internalError+  "SyntaxCheck.errDuplicateVariables: empty list"+errDuplicateVariables (v:vs) = spanInfoMessage 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) = spanInfoMessage 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) = spanInfoMessage 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) = spanInfoMessage 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 = spanInfoMessage l $ hsep $ map text+  ["Field label", escQualName l, "occurs more than once in record", what]++errNonVariable :: String -> Ident -> Message+errNonVariable what c = spanInfoMessage c $ hsep $ map text+  ["Data constructor", escName c, "in left hand side of", what]++errNoBody :: Ident -> Message+errNoBody v = spanInfoMessage v $  hsep $ map text ["No body for", escName v]++errNoCommonCons :: SpanInfo -> [QualIdent] -> Message+errNoCommonCons spi ls = spanInfoMessage spi $+  text "No constructor has all of these fields:"+  $+$ nest 2 (vcat (map (text . escQualName) ls))++errNoLabel :: QualIdent -> QualIdent -> Message+errNoLabel c l = spanInfoMessage l $ hsep $ map text+  [escQualName l, "is not a field label of constructor", escQualName c]++errNoTypeSig :: Ident -> Message+errNoTypeSig f = spanInfoMessage f $ hsep $ map text+  ["No type signature for external function", escName f]++errToplevelPattern :: SpanInfo -> Message+errToplevelPattern spi = spanInfoMessage spi $ text+  "Pattern declaration not allowed at top-level"++errDifferentArity :: [Ident] -> Message+errDifferentArity [] = internalError+  "SyntaxCheck.errDifferentArity: empty list"+errDifferentArity (i:is) = spanInfoMessage 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 = spanInfoMessage 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"++errMissingLanguageExtension :: SpanInfo -> String -> KnownExtension -> Message+errMissingLanguageExtension spi what ext = spanInfoMessage spi $+  text what <+> text "are not supported in standard Curry." $+$+  nest 2 (text "Use flag or -X" <+> text (show ext)+          <+> text "to enable this extension.")++errInfixWithoutParens :: SpanInfo -> [(QualIdent, QualIdent)] -> Message+errInfixWithoutParens spi calls = spanInfoMessage spi $+  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 $ getPosition q)
+ src/Checks/TypeCheck.hs view
@@ -0,0 +1,1874 @@+{- |+    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+                       2016 - 2017 Finn Teegen+    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 and kind checking has been applied to all type+   expressions. Local variables have been renamed already. Thus the+   compiler can maintain a flat type environment. 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.++   The result of type checking is a (flat) top-level environment+   containing the types of all constructors, variables, and functions+   defined at the top level of a module. In addition, a type annotated+   source module is returned. Note that type annotations on the+   left hand side of a declaration hold the function or variable's+   generalized type with the type scheme's universal quantifier left+   implicit. Type annotations on the right hand side of a declaration+   hold the particular instance at which a polymorphic function or+   variable is used.+-}+{-# LANGUAGE CPP #-}+module Checks.TypeCheck (typeCheck) where++#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative        ((<$>), (<*>))+#endif+import           Control.Monad.Trans (lift)+import           Control.Monad.Extra (allM, filterM, foldM, liftM, (&&^),+                                      notM, replicateM, when, unless, unlessM)+import qualified Control.Monad.State as S+                                     (State, StateT, get, gets, put, modify,+                                      runState, evalStateT)+import           Data.Function       (on)+import           Data.List           (nub, nubBy, partition, sortBy, (\\))+import qualified Data.Map            as Map (Map, empty, insert, lookup)+import           Data.Maybe                 (fromJust, fromMaybe, isJust)+import qualified Data.Set.Extra      as Set ( Set, concatMap, deleteMin, empty+                                            , fromList, insert, member+                                            , notMember, partition, singleton+                                            , toList, union, unions )++import Curry.Base.Ident+import Curry.Base.Pretty+import Curry.Base.SpanInfo+import Curry.Syntax+import Curry.Syntax.Pretty++import Base.CurryTypes+import Base.Expr+import Base.Kinds+import Base.Messages (Message, spanInfoMessage, internalError)+import Base.SCC+import Base.TopEnv+import Base.TypeExpansion+import Base.Types+import Base.TypeSubst+import Base.Utils (foldr2, fst3, snd3, thd3, uncurry3, mapAccumM)++import Env.Class+import Env.Instance+import Env.TypeConstructor+import Env.Value++-- Type checking proceeds as follows. First, the types of all data+-- constructors, field labels and class methods are entered into the+-- value environment and then a type inference for all function and+-- value definitions is performed.++typeCheck :: ModuleIdent -> TCEnv -> ValueEnv -> ClassEnv -> InstEnv -> [Decl a]+          -> ([Decl PredType], ValueEnv, [Message])+typeCheck m tcEnv vEnv clsEnv inEnv ds = runTCM (checkDecls ds) initState+  where initState = TcState m tcEnv vEnv clsEnv (inEnv, Map.empty)+                            [intType, floatType] idSubst emptySigEnv 1 []++checkDecls :: [Decl a] -> TCM [Decl PredType]+checkDecls ds = do+  bindConstrs+  mapM_ checkFieldLabel (filter isTypeDecl ds) &&> bindLabels+  bindClassMethods+  mapM_ setDefaults $ filter isDefaultDecl ds+  (_, bpds') <- tcPDecls bpds+  tpds' <- mapM tcTopPDecl tpds+  theta <- getTypeSubst+  return $ map (fmap $ subst theta) $ fromPDecls $ tpds' ++ bpds'+  where (bpds, tpds) = partition (isBlockDecl . snd) $ toPDecls ds++-- The type checker makes use of a state monad in order to maintain the value+-- environment, the current substitution, and a counter which is used for+-- generating fresh type variables.++-- Additionally, an extended instance environment is used in order to handle+-- the introduction of local instances when matching a data constructor with a+-- non-empty context. This extended instance environment is composed of the+-- static top-level environment and a dynamic environment that maps each class+-- on the instances which are in scope for it. The rationale behind using this+-- representation is that it makes it easy to apply the current substitution to+-- the dynamic part of the environment.++type TCM = S.State TcState++type InstEnv' = (InstEnv, Map.Map QualIdent [Type])++data TcState = TcState+  { moduleIdent  :: ModuleIdent -- read only+  , tyConsEnv    :: TCEnv+  , valueEnv     :: ValueEnv+  , classEnv     :: ClassEnv+  , instEnv      :: InstEnv'    -- instances (static and dynamic)+  , defaultTypes :: [Type]+  , typeSubst    :: TypeSubst+  , sigEnv       :: SigEnv+  , nextId       :: Int         -- automatic counter+  , errors       :: [Message]+  }++(&&>) :: TCM () -> TCM () -> TCM ()+pre &&> suf = do+  errs <- pre >> S.gets errors+  when (null errs) suf++(>>-) :: Monad m => m (a, b, c) -> (a -> b -> m a) -> m (a, c)+m >>- f = do+  (u, v, w) <- m+  u' <- f u v+  return (u', w)++(>>=-) :: TCM (a, b, d) -> (b -> TCM c) -> TCM (a, c, d)+m >>=- f = do+  (u, v, x) <- m+  w <- f v+  return (u, w, x)++runTCM :: TCM a -> TcState -> (a, ValueEnv, [Message])+runTCM tcm ts = let (a, s') = S.runState tcm ts+               in  (a, typeSubst s' `subst` valueEnv s', reverse $ errors s')++getModuleIdent :: TCM ModuleIdent+getModuleIdent = S.gets moduleIdent++getTyConsEnv :: TCM TCEnv+getTyConsEnv = S.gets tyConsEnv++getValueEnv :: TCM ValueEnv+getValueEnv = S.gets valueEnv++modifyValueEnv :: (ValueEnv -> ValueEnv) -> TCM ()+modifyValueEnv f = S.modify $ \s -> s { valueEnv = f $ valueEnv s }++withLocalValueEnv :: TCM a -> TCM a+withLocalValueEnv act = do+  oldEnv <- getValueEnv+  res <- act+  modifyValueEnv $ const oldEnv+  return res++getClassEnv :: TCM ClassEnv+getClassEnv = S.gets classEnv++getInstEnv :: TCM InstEnv'+getInstEnv = S.gets instEnv++modifyInstEnv :: (InstEnv' -> InstEnv') -> TCM ()+modifyInstEnv f = S.modify $ \s -> s { instEnv = f $ instEnv s }++getDefaultTypes :: TCM [Type]+getDefaultTypes = S.gets defaultTypes++setDefaultTypes :: [Type] -> TCM ()+setDefaultTypes tys = S.modify $ \s -> s { defaultTypes = tys }++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++setSigEnv :: SigEnv -> TCM ()+setSigEnv sigs = S.modify $ \s -> s { sigEnv = sigs }++withLocalSigEnv :: TCM a -> TCM a+withLocalSigEnv act = do+  oldSigs <- getSigEnv+  res <- act+  setSigEnv oldSigs+  return res++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 }++ok :: TCM ()+ok = return ()++-- Because the type check may mess up the order of the declarations, we+-- associate each declaration with a number. At the end of the type check,+-- we can use these numbers to restore the original declaration order.++type PDecl a = (Int, Decl a)++toPDecls :: [Decl a] -> [PDecl a]+toPDecls = zip [0 ..]++fromPDecls :: [PDecl a] -> [Decl a]+fromPDecls = map snd . sortBy (compare `on` fst)++-- During the type check we also have to convert the type of declarations+-- without annotations which is done by the function 'untyped' below.++untyped :: PDecl a -> PDecl b+untyped = fmap $ fmap $ internalError "TypeCheck.untyped"++-- Defining Data Constructors:+-- In the next step, the types of all data constructors are entered into+-- the value environment using the information entered into the type constructor+-- environment before.++bindConstrs :: TCM ()+bindConstrs = do+  m <- getModuleIdent+  tcEnv <- getTyConsEnv+  modifyValueEnv $ bindConstrs' m tcEnv++bindConstrs' :: ModuleIdent -> TCEnv -> ValueEnv -> ValueEnv+bindConstrs' m tcEnv vEnv = foldr (bindData . snd) vEnv $ localBindings tcEnv+  where+    bindData (DataType tc k cs) vEnv' =+      let n = kindArity k in foldr (bindConstr m n (constrType' tc n)) vEnv' cs+    bindData (RenamingType tc k c) vEnv' =+      let n = kindArity k in bindNewConstr m n (constrType' tc n) c vEnv'+    bindData _ vEnv' = vEnv'++bindConstr :: ModuleIdent -> Int -> Type -> DataConstr -> ValueEnv -> ValueEnv+bindConstr m n ty (DataConstr c tys) =+  bindGlobalInfo (\qc tyScheme -> DataConstructor qc arity ls tyScheme) m c+                 (ForAll n (PredType emptyPredSet (foldr TypeArrow ty tys)))+  where arity = length tys+        ls    = replicate arity anonId+bindConstr m n ty (RecordConstr c ls tys) =+  bindGlobalInfo (\qc tyScheme -> DataConstructor qc arity ls tyScheme) m c+                 (ForAll n (PredType emptyPredSet (foldr TypeArrow ty tys)))+  where arity = length tys++bindNewConstr :: ModuleIdent -> Int -> Type -> DataConstr -> ValueEnv+              -> ValueEnv+bindNewConstr m n cty (DataConstr c [lty]) =+  bindGlobalInfo (\qc tyScheme -> NewtypeConstructor qc anonId tyScheme) m c+                 (ForAll n (predType (TypeArrow lty cty)))+bindNewConstr m n cty (RecordConstr c [l] [lty]) =+  bindGlobalInfo (\qc tyScheme -> NewtypeConstructor qc l tyScheme) m c+                 (ForAll n (predType (TypeArrow lty cty)))+bindNewConstr _ _ _ _ = internalError+  "TypeCheck.bindConstrs'.bindNewConstr: newtype with illegal constructors"++constrType' :: QualIdent -> Int -> Type+constrType' tc n =+  applyType (TypeConstructor tc) $ map TypeVariable [0 .. n - 1]++-- 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 a -> 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)+  ok+checkFieldLabel _ = ok++tcFieldLabel :: HasSpanInfo p => [Ident] -> (Ident, p, TypeExpr)+             -> TCM (Ident, p, Type)+tcFieldLabel tvs (l, p, ty) = do+  m <- getModuleIdent+  tcEnv <- getTyConsEnv+  let ForAll n (PredType _ ty') = polyType $ expandMonoType m tcEnv tvs ty+  unless (n <= length tvs) $ report $ errSkolemFieldLabel p l+  return (l, p, ty')++groupLabels :: Eq a => [(a, b, c)] -> [(a, b, [c])]+groupLabels []               = []+groupLabels ((x, y, z):xyzs) =+  (x, y, z : map thd3 xyzs') : groupLabels xyzs''+  where (xyzs', xyzs'') = partition ((x ==) . fst3) xyzs++tcFieldLabels :: HasSpanInfo p => (Ident, p, [Type]) -> TCM ()+tcFieldLabels (_, _, [])     = return ()+tcFieldLabels (l, p, ty:tys) = unless (not (any (ty /=) tys)) $ do+  m <- getModuleIdent+  report $ errIncompatibleLabelTypes p m l ty (head tys)++-- Defining Field Labels:+-- Next the types of all field labels are added to the value environment.++bindLabels :: TCM ()+bindLabels = do+  m <- getModuleIdent+  tcEnv <- getTyConsEnv+  modifyValueEnv $ bindLabels' m tcEnv++bindLabels' :: ModuleIdent -> TCEnv -> ValueEnv -> ValueEnv+bindLabels' m tcEnv vEnv = foldr (bindData . snd) vEnv $ localBindings tcEnv+  where+    bindData (DataType tc k cs) vEnv' =+      foldr (bindLabel m n (constrType' tc n)) vEnv' $ nubBy sameLabel clabels+      where+        n = kindArity k+        labels = zip (concatMap recLabels cs) (concatMap recLabelTypes cs)+        clabels = [(l, constr l, ty) | (l, ty) <- labels]+        constr l = [qualifyLike tc (constrIdent c)+                     | c <- cs, l `elem` recLabels c]+        sameLabel (l1, _, _) (l2, _, _) = l1 == l2+    bindData (RenamingType tc k (RecordConstr c [l] [lty])) vEnv'+      = bindLabel m n (constrType' tc n) (l, [qc], lty) vEnv'+      where+        n = kindArity k+        qc = qualifyLike tc c+    bindData (RenamingType _ _ (RecordConstr _ _ _)) _ =+      internalError $ "Checks.TypeCheck.bindLabels'.bindData: " +++        "RenamingType with more than one record label"+    bindData _ vEnv' = vEnv'++bindLabel :: ModuleIdent -> Int -> Type -> (Ident, [QualIdent], Type)+          -> ValueEnv -> ValueEnv+bindLabel m n ty (l, lcs, lty) =+  bindGlobalInfo (\qc tyScheme -> Label qc lcs tyScheme) m l+                 (ForAll n (predType (TypeArrow ty lty)))++-- Defining class methods:+-- Last, the types of all class methods are added to the value environment.++bindClassMethods :: TCM ()+bindClassMethods = do+  m <- getModuleIdent+  tcEnv <- getTyConsEnv+  modifyValueEnv $ bindClassMethods' m tcEnv++bindClassMethods' :: ModuleIdent -> TCEnv -> ValueEnv -> ValueEnv+bindClassMethods' m tcEnv vEnv =+  foldr (bindMethods . snd) vEnv $ localBindings tcEnv+  where+    bindMethods (TypeClass cls _ ms) vEnv' =+      foldr (bindClassMethod m cls) vEnv' ms+    bindMethods _                    vEnv' =+      vEnv'++-- Since the implementations of class methods can differ in their arity,+-- we assume an arity of 0 when we enter one into the value environment.++bindClassMethod :: ModuleIdent -> QualIdent -> ClassMethod -> ValueEnv+                -> ValueEnv+bindClassMethod m cls (ClassMethod f _ ty) =+  bindGlobalInfo (\qc tySc -> Value qc (Just cls) 0 tySc) m f (typeScheme ty)++-- -----------------------------------------------------------------------------+-- Default Types+-- -----------------------------------------------------------------------------++-- Default Types:+-- The list of default types is given either by a default declaration in+-- the source code or defaults to the predefined list of numeric data types.++setDefaults :: Decl a -> TCM ()+setDefaults (DefaultDecl _ tys) = mapM toDefaultType tys >>= setDefaultTypes+  where+    toDefaultType =+      liftM snd . (inst =<<) . liftM typeScheme+                . expandPoly . QualTypeExpr NoSpanInfo []+setDefaults _ = ok++-- Type Signatures:+-- The type checker collects type signatures in a flat environment.+-- The types are 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 QualTypeExpr++emptySigEnv :: SigEnv+emptySigEnv = Map.empty++bindTypeSig :: Ident -> QualTypeExpr -> SigEnv -> SigEnv+bindTypeSig = Map.insert++bindTypeSigs :: Decl a -> SigEnv -> SigEnv+bindTypeSigs (TypeSig _ vs ty) env = foldr (`bindTypeSig` ty) env vs+bindTypeSigs _                 env = env++lookupTypeSig :: Ident -> SigEnv -> Maybe QualTypeExpr+lookupTypeSig = Map.lookup++-- Declaration groups:+-- 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 value environment is extended with new bindings for all+-- variables and functions defined in the group. Next, types are inferred for+-- all declarations without an explicit type signature and the inferred types+-- are then generalized. Finally, the types of all explicitly typed declarations+-- are checked.++-- Within a group of mutually recursive declarations, all type variables that+-- appear in the types of the variables defined in the group and whose type+-- cannot be generalized must not be generalized in the other declarations of+-- that group as well.++tcDecls :: [Decl a] -> TCM (PredSet, [Decl PredType])+tcDecls = fmap (fmap fromPDecls) . tcPDecls . toPDecls++tcPDecls :: [PDecl a] -> TCM (PredSet, [PDecl PredType])+tcPDecls pds = withLocalSigEnv $ do+  let (vpds, opds) = partition (isValueDecl . snd) pds+  setSigEnv $ foldr (bindTypeSigs . snd) emptySigEnv $ opds+  m <- getModuleIdent+  (ps, vpdss') <-+    mapAccumM tcPDeclGroup emptyPredSet $ scc (bv . snd) (qfv m . snd) vpds+  return (ps, map untyped opds ++ concat (vpdss' :: [[PDecl PredType]]))++tcPDeclGroup :: PredSet -> [PDecl a] -> TCM (PredSet, [PDecl PredType])+tcPDeclGroup ps [(i, ExternalDecl p fs)] = do+  tys <- mapM (tcExternal . varIdent) fs+  return (ps, [(i, ExternalDecl p (zipWith (fmap . const . predType) tys fs))])+tcPDeclGroup ps [(i, FreeDecl p fvs)] = do+  vs <- mapM (tcDeclVar False) (bv fvs)+  m <- getModuleIdent+  (vs', ps') <- unzip <$> mapM addDataPred vs+  modifyValueEnv $ flip (bindVars m) vs'+  let d = FreeDecl p (map (\(v, _, ForAll _ ty) -> Var ty v) vs')+  return (ps `Set.union` Set.unions ps', [(i, d)])+  where+    addDataPred (idt, n, ForAll ids ty1) = do+      (ps2, ty2) <- freshDataType+      ps' <- unify idt "free variable" (ppIdent idt) emptyPredSet (unpredType ty1) ps2 ty2+      return ((idt, n, ForAll ids ty1), ps')+tcPDeclGroup ps pds = do+  vEnv <- getValueEnv+  vss <- mapM (tcDeclVars . snd) pds+  m <- getModuleIdent+  modifyValueEnv $ flip (bindVars m) $ concat vss+  sigs <- getSigEnv+  let (impPds, expPds) = partitionPDecls sigs pds+  (ps', impPds') <- mapAccumM tcPDecl ps impPds+  theta <- getTypeSubst+  tvs <- concatMap (typeVars . subst theta . fst) <$>+           filterM (notM . isNonExpansive . snd . snd) impPds'+  let fvs = foldr Set.insert (fvEnv (subst theta vEnv)) tvs+      (gps, lps) = splitPredSet fvs ps'+  lps' <- foldM (uncurry . defaultPDecl fvs) lps impPds'+  theta' <- getTypeSubst+  let impPds'' = map (uncurry (fixType . gen fvs lps' . subst theta')) impPds'+  modifyValueEnv $ flip (rebindVars m) (concatMap (declVars . snd) impPds'')+  (ps'', expPds') <- mapAccumM (uncurry . tcCheckPDecl) gps expPds+  return (ps'', impPds'' ++ expPds')++partitionPDecls :: SigEnv -> [PDecl a] -> ([PDecl a], [(QualTypeExpr, PDecl a)])+partitionPDecls sigs =+  foldr (\pd -> maybe (implicit pd) (explicit pd) (typeSig $ snd pd)) ([], [])+  where implicit pd ~(impPds, expPds) = (pd : impPds, expPds)+        explicit pd qty ~(impPds, expPds) = (impPds, (qty, pd) : expPds)+        typeSig (FunctionDecl _ _ f _) = lookupTypeSig f sigs+        typeSig (PatternDecl _ (VariablePattern _ _ v) _) = lookupTypeSig v sigs+        typeSig _ = Nothing++bindVars :: ModuleIdent -> ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv+bindVars m = foldr $ uncurry3 $ flip (bindFun m) Nothing++rebindVars :: ModuleIdent -> ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv+rebindVars m = foldr $ uncurry3 $ flip (rebindFun m) Nothing++tcDeclVars :: Decl a -> TCM [(Ident, Int, TypeScheme)]+tcDeclVars (FunctionDecl _ _ f eqs) = do+  sigs <- getSigEnv+  let n = eqnArity $ head eqs+  case lookupTypeSig f sigs of+    Just qty -> do+      pty <- expandPoly qty+      return [(f, n, typeScheme pty)]+    Nothing -> do+      tys <- replicateM (n + 1) freshTypeVar+      return [(f, n, monoType $ foldr1 TypeArrow tys)]+tcDeclVars (PatternDecl _ t _) = case t of+  VariablePattern _ _ v -> return <$> tcDeclVar True v+  _ -> mapM (tcDeclVar False) (bv t)+tcDeclVars _ = internalError "TypeCheck.tcDeclVars"++tcDeclVar :: Bool -> Ident -> TCM (Ident, Int, TypeScheme)+tcDeclVar poly v = do+  sigs <- getSigEnv+  case lookupTypeSig v sigs of+    Just qty+      | poly || null (fv qty) -> do+        pty <- expandPoly qty+        return (v, 0, typeScheme pty)+      | otherwise -> do+        report $ errPolymorphicVar v+        lambdaVar v+    Nothing -> lambdaVar v++tcPDecl :: PredSet -> PDecl a -> TCM (PredSet, (Type, PDecl PredType))+tcPDecl ps (i, FunctionDecl p _ f eqs) = do+  vEnv <- getValueEnv+  tcFunctionPDecl i ps (varType f vEnv) p f eqs+tcPDecl ps (i, d@(PatternDecl p t rhs)) = do+  (ps', ty', t') <- tcPattern p t+  (ps'', rhs') <- tcRhs rhs >>-+    unifyDecl p "pattern declaration" (pPrint d) (ps `Set.union` ps') ty'+  return (ps'', (ty', (i, PatternDecl p t' rhs')))+tcPDecl _ _ = internalError "TypeCheck.tcPDecl"++-- The function 'tcFunctionPDecl' ignores the context of a function's type+-- signature. This prevents missing instance errors when the inferred type+-- of a function is less general than the declared type.++tcFunctionPDecl :: Int -> PredSet -> TypeScheme -> SpanInfo -> Ident+                -> [Equation a] -> TCM (PredSet, (Type, PDecl PredType))+tcFunctionPDecl i ps tySc@(ForAll _ pty) p f eqs = do+  (_, ty) <- inst tySc+  (ps', eqs') <- mapAccumM (tcEquation ty) ps eqs+  return (ps', (ty, (i, FunctionDecl p pty f eqs')))++tcEquation :: Type -> PredSet -> Equation a+           -> TCM (PredSet, Equation PredType)+tcEquation ty ps eqn@(Equation p lhs rhs) =+  tcEqn p lhs rhs >>- unifyDecl p "equation" (pPrint eqn) ps ty++tcEqn :: SpanInfo -> Lhs a -> Rhs a+      -> TCM (PredSet, Type, Equation PredType)+tcEqn p lhs rhs = do+  (ps, tys, lhs', ps', ty, rhs') <- withLocalValueEnv $ do+    bindLambdaVars lhs+    (ps, tys, lhs') <- S.evalStateT (tcLhs p lhs) Set.empty+    (ps', ty, rhs') <- tcRhs rhs+    return (ps, tys, lhs', ps', ty, rhs')+  ps'' <- reducePredSet p "equation" (pPrint (Equation p lhs' rhs'))+                        (ps `Set.union` ps')+  return (ps'', foldr TypeArrow ty tys, Equation p lhs' rhs')++bindLambdaVars :: QuantExpr t => t -> TCM ()+bindLambdaVars t = do+  m <- getModuleIdent+  vs <- mapM lambdaVar (nub $ bv t)+  modifyValueEnv $ flip (bindVars m) vs++lambdaVar :: Ident -> TCM (Ident, Int, TypeScheme)+lambdaVar v = do+  ty <- freshTypeVar+  return (v, 0, monoType ty)++unifyDecl :: HasSpanInfo p => p -> String -> Doc -> PredSet -> Type -> PredSet+          -> Type+          -> TCM PredSet+unifyDecl p what doc psLhs tyLhs psRhs tyRhs = do+  ps <- unify p what doc psLhs tyLhs psRhs tyRhs+  fvs <- computeFvEnv+  applyDefaultsDecl p what doc fvs ps tyLhs++-- After inferring types for a group of mutually recursive declarations+-- and computing the set of its constrained type variables, the compiler+-- has to be prepared for some of the constrained type variables to not+-- appear in some of the inferred types, i.e., there may be ambiguous+-- types that have not been reported by 'unifyDecl' above at the level+-- of individual function equations and pattern declarations.++defaultPDecl :: Set.Set Int -> PredSet -> Type -> PDecl a -> TCM PredSet+defaultPDecl fvs ps ty (_, FunctionDecl p _ f _) =+  applyDefaultsDecl p ("function " ++ escName f) empty fvs ps ty+defaultPDecl fvs ps ty (_, PatternDecl p t _) = case t of+  VariablePattern _ _ v ->+    applyDefaultsDecl p ("variable " ++ escName v) empty fvs ps ty+  _ -> return ps+defaultPDecl _ _ _ _ = internalError "TypeCheck.defaultPDecl"++applyDefaultsDecl :: HasSpanInfo p => p -> String -> Doc -> Set.Set Int+                  -> PredSet -> Type -> TCM PredSet+applyDefaultsDecl p what doc fvs ps ty = do+  theta <- getTypeSubst+  let ty' = subst theta ty+      fvs' = foldr Set.insert fvs $ typeVars ty'+  applyDefaults p what doc fvs' ps ty'++-- After 'tcDeclGroup' has generalized the types of the implicitly+-- typed declarations of a declaration group it must update their left+-- hand side type annotations and the type environment accordingly.+-- Recall that the compiler generalizes only the types of variable and+-- function declarations.++fixType :: TypeScheme -> PDecl PredType -> PDecl PredType+fixType ~(ForAll _ pty) (i, FunctionDecl p _ f eqs) =+  (i, FunctionDecl p pty f eqs)+fixType ~(ForAll _ pty) pd@(i, PatternDecl p t rhs) = case t of+  VariablePattern spi _ v+    -> (i, PatternDecl p (VariablePattern spi pty v) rhs)+  _ -> pd+fixType _ _ = internalError "TypeCheck.fixType"++declVars :: Decl PredType -> [(Ident, Int, TypeScheme)]+declVars (FunctionDecl _ pty f eqs) = [(f, eqnArity $ head eqs, typeScheme pty)]+declVars (PatternDecl _ t _) = case t of+  VariablePattern _ pty v -> [(v, 0, typeScheme pty)]+  _ -> []+declVars _ = internalError "TypeCheck.declVars"++-- The function 'tcCheckPDecl' checks the type of an explicitly typed function+-- or variable declaration. After inferring a type for the declaration, the+-- inferred type is compared with the type signature. Since the inferred type+-- of an explicitly typed function or variable declaration is automatically an+-- instance of its type signature, the type signature is correct only if the+-- inferred type matches the type signature exactly except for the inferred+-- predicate set, which may contain only a subset of the declared context+-- because the context of a function's type signature is ignored in the+-- function 'tcFunctionPDecl' above.++tcCheckPDecl :: PredSet -> QualTypeExpr -> PDecl a+             -> TCM (PredSet, PDecl PredType)+tcCheckPDecl ps qty pd = do+  (ps', (ty, pd')) <- tcPDecl ps pd+  fvs <- computeFvEnv+  theta <- getTypeSubst+  poly <- isNonExpansive $ snd pd+  let (gps, lps) = splitPredSet fvs ps'+      ty' = subst theta ty+      tySc = if poly then gen fvs lps ty' else monoType ty'+  checkPDeclType qty gps tySc pd'++checkPDeclType :: QualTypeExpr -> PredSet -> TypeScheme -> PDecl PredType+               -> TCM (PredSet, PDecl PredType)+checkPDeclType qty ps tySc (i, FunctionDecl p _ f eqs) = do+  pty <- expandPoly qty+  unlessM (checkTypeSig pty tySc) $ do+    m <- getModuleIdent+    report $ errTypeSigTooGeneral m (text "Function:" <+> ppIdent f) qty tySc+  return (ps, (i, FunctionDecl p pty f eqs))+checkPDeclType qty ps tySc (i, PatternDecl p (VariablePattern spi _ v) rhs) = do+  pty <- expandPoly qty+  unlessM (checkTypeSig pty tySc) $ do+    m <- getModuleIdent+    report $ errTypeSigTooGeneral m (text "Variable:" <+> ppIdent v) qty tySc+  return (ps, (i, PatternDecl p (VariablePattern spi pty v) rhs))+checkPDeclType _ _ _ _ = internalError "TypeCheck.checkPDeclType"++checkTypeSig :: PredType -> TypeScheme -> TCM Bool+checkTypeSig (PredType sigPs sigTy) (ForAll _ (PredType ps ty)) = do+  clsEnv <- getClassEnv+  return $+    ty `eqTypes` sigTy &&+    all (`Set.member` maxPredSet clsEnv sigPs) (Set.toList ps)++-- The function 'equTypes' computes whether two types are equal modulo+-- renaming of type variables.+-- WARNING: This operation is not reflexive and expects the second type to be+-- the type signature provided by the programmer.+eqTypes :: Type -> Type -> Bool+eqTypes t1 t2 = fst (eq [] t1 t2)+ where+ -- @is@ is an AssocList of type variable indices+ eq is (TypeConstructor   qid1) (TypeConstructor   qid2) = (qid1 == qid2, is)+ eq is (TypeVariable        i1) (TypeVariable        i2)+   | i1 < 0    = (False, is)+   | otherwise = eqVar is i1 i2+ eq is (TypeConstrained ts1 i1) (TypeConstrained ts2 i2)+   = let (res1, is1) = eqs   is  ts1 ts2+         (res2, is2) = eqVar is1 i1  i2+     in  (res1 && res2, is2)+ eq is (TypeApply      ta1 tb1) (TypeApply      ta2 tb2)+   = let (res1, is1) = eq is  ta1 ta2+         (res2, is2) = eq is1 tb1 tb2+     in  (res1 && res2, is2)+ eq is (TypeArrow      tf1 tt1) (TypeArrow      tf2 tt2)+   = let (res1, is1) = eq is  tf1 tf2+         (res2, is2) = eq is1 tt1 tt2+     in  (res1 && res2, is2)+ eq is (TypeForall     is1 t1') (TypeForall     is2 t2')+   = let (res1, is') = eqs [] (map TypeVariable is1) (map TypeVariable is2)+         (res2, _  ) = eq is' t1' t2'+     in  (res1 && res2, is)+ eq is _                        _                        = (False, is)++ eqVar is i1 i2 = case lookup i1 is of+   Nothing  -> (True, (i1, i2) : is)+   Just i2' -> (i2 == i2', is)++ eqs is []        []        = (True , is)+ eqs is (t1':ts1) (t2':ts2)+    = let (res1, is1) = eq  is t1'  t2'+          (res2, is2) = eqs is1 ts1 ts2+      in  (res1 && res2, is2)+ eqs is _         _         = (False, is)++-- In Curry, a non-expansive expression is either+--+-- * a literal,+-- * a variable,+-- * an application of a constructor with arity n to at most n+--   non-expansive expressions,+-- * an application of a function with arity n to at most n-1+--   non-expansive expressions, or+-- * a let expression whose body is a non-expansive expression and+--   whose local declarations are either function declarations or+--   variable declarations of the form x=e where e is a non-expansive+--   expression, or+-- * an expression whose desugared form is one of the above.+--+-- At first it may seem strange that variables are included in the list+-- above because a variable may be bound to a logical variable. However,+-- this is no problem because type variables that are present among the+-- typing assumptions of the environment enclosing a let expression+-- cannot be generalized.++class Binding a where+  isNonExpansive :: a -> TCM Bool++instance Binding a => Binding [a] where+  isNonExpansive = allM isNonExpansive++instance Binding (Decl a) where+  isNonExpansive (InfixDecl       _ _ _ _) = return True+  isNonExpansive (TypeSig           _ _ _) = return True+  isNonExpansive (FunctionDecl    _ _ _ _) = return True+  isNonExpansive (ExternalDecl        _ _) = return True+  isNonExpansive (PatternDecl       _ _ _) = return False+    -- TODO: Uncomment when polymorphic let declarations are fully supported+  {-isNonExpansive (PatternDecl     _ t rhs) = case t of+    VariablePattern _ _ -> isNonExpansive rhs+    _                   -> return False-}+  isNonExpansive (FreeDecl            _ _) = return False+  isNonExpansive _                         =+    internalError "TypeCheck.isNonExpansive: declaration"++instance Binding (Rhs a) where+  isNonExpansive (GuardedRhs _ _ _ _) = return False+  isNonExpansive (SimpleRhs _ _ e ds) = withLocalValueEnv $ do+    m <- getModuleIdent+    tcEnv <- getTyConsEnv+    clsEnv <- getClassEnv+    sigs <- getSigEnv+    modifyValueEnv $ flip (foldr (bindDeclArity m tcEnv clsEnv sigs)) ds+    isNonExpansive e &&^ isNonExpansive ds++-- A record construction is non-expansive only if all field labels are present.++instance Binding (Expression a) where+  isNonExpansive = isNonExpansive' 0++isNonExpansive' :: Int -> Expression a -> TCM Bool+isNonExpansive' _ (Literal         _ _ _) = return True+isNonExpansive' n (Variable        _ _ v)+  | v' == anonId = return False+  | isRenamed v' = do+    vEnv <- getValueEnv+    return $ n == 0 || n < varArity v vEnv+  | otherwise = do+    vEnv <- getValueEnv+    return $ n < varArity v vEnv+  where v' = unqualify v+isNonExpansive' _ (Constructor     _ _ _) = return True+isNonExpansive' n (Paren             _ e) = isNonExpansive' n e+isNonExpansive' n (Typed           _ e _) = isNonExpansive' n e+isNonExpansive' _ (Record       _ _ c fs) = do+  m <- getModuleIdent+  vEnv <- getValueEnv+  fmap ((length (constrLabels m c vEnv) == length fs) &&) (isNonExpansive fs)+isNonExpansive' _ (Tuple _ es)            = isNonExpansive es+isNonExpansive' _ (List _ _ es)           = isNonExpansive es+isNonExpansive' n (Apply _ f e)           = isNonExpansive' (n + 1) f+                                              &&^ isNonExpansive e+isNonExpansive' n (InfixApply _ e1 op e2)+  = isNonExpansive' (n + 2) (infixOp op) &&^ isNonExpansive e1+                                         &&^ isNonExpansive e2+isNonExpansive' n (LeftSection _ e op)    = isNonExpansive' (n + 1) (infixOp op)+                                              &&^ isNonExpansive e+isNonExpansive' n (Lambda _ ts e)         = withLocalValueEnv $ do+  modifyValueEnv $ flip (foldr bindVarArity) (bv ts)+  fmap (((n < length ts) ||) . (all isVariablePattern ts &&))+    (isNonExpansive' (n - length ts) e)+isNonExpansive' n (Let _ _ ds e)            = withLocalValueEnv $ do+  m <- getModuleIdent+  tcEnv <- getTyConsEnv+  clsEnv <- getClassEnv+  sigs <- getSigEnv+  modifyValueEnv $ flip (foldr (bindDeclArity m tcEnv clsEnv sigs)) ds+  isNonExpansive ds &&^ isNonExpansive' n e+isNonExpansive' _ _                     = return False++instance Binding a => Binding (Field a) where+  isNonExpansive (Field _ _ e) = isNonExpansive e++bindDeclArity :: ModuleIdent -> TCEnv -> ClassEnv -> SigEnv ->  Decl a+              -> ValueEnv -> ValueEnv+bindDeclArity _ _     _      _    (InfixDecl        _ _ _ _) = id+bindDeclArity _ _     _      _    (TypeSig            _ _ _) = id+bindDeclArity _ _     _      _    (FunctionDecl   _ _ f eqs) =+  bindArity f (eqnArity $ head eqs)+bindDeclArity m tcEnv clsEnv sigs (ExternalDecl        _ fs) =+  flip (foldr $ \(Var _ f) -> bindArity f $ arrowArity $ ty f) fs+  where ty = unpredType . expandPolyType m tcEnv clsEnv . fromJust .+               flip lookupTypeSig sigs+bindDeclArity _ _     _      _    (PatternDecl        _ t _) =+  flip (foldr bindVarArity) (bv t)+bindDeclArity _ _     _      _    (FreeDecl            _ vs) =+  flip (foldr bindVarArity) (bv vs)+bindDeclArity _ _     _      _    _                          =+  internalError "TypeCheck.bindDeclArity"++bindVarArity :: Ident -> ValueEnv -> ValueEnv+bindVarArity v = bindArity v 0++bindArity :: Ident -> Int -> ValueEnv -> ValueEnv+bindArity v n = bindTopEnv v (Value (qualify v) Nothing n undefined)++-- Class and instance declarations:+-- When checking method implementations in class and instance+-- declarations, the compiler must check that the inferred type matches+-- the method's declared type. This is straight forward in class+-- declarations (the only difference with respect to an overloaded+-- function with an explicit type signature is that a class method's type+-- signature is composed of its declared type signature and the context+-- from the class declaration), but a little bit more complicated for+-- instance declarations because the instance type must be substituted+-- for the type variable used in the type class declaration.+--+-- When checking inferred method types against their expected types, we have to+-- be careful because the class' type variable is always assigned index 0 in+-- the method types recorded in the value environment. However, in the inferred+-- type scheme returned from 'tcMethodDecl', type variables are assigned+-- indices in the order of their occurrence. In order to avoid incorrectly+-- reporting errors when the type class variable is not the first variable that+-- appears in a method's type, 'tcInstanceMethodPDecl' normalizes the expected+-- method type before applying 'checkInstMethodType' to it. Unfortunately, this+-- means that the compiler has to add the class constraint explicitly to the+-- type signature.++tcTopPDecl :: PDecl a -> TCM (PDecl PredType)+tcTopPDecl (i, DataDecl p tc tvs cs clss)+  = return (i, DataDecl p tc tvs cs clss)+tcTopPDecl (i, ExternalDataDecl p tc tvs)+  = return (i, ExternalDataDecl p tc tvs)+tcTopPDecl (i, NewtypeDecl p tc tvs nc clss)+  = return (i, NewtypeDecl p tc tvs nc clss)+tcTopPDecl (i, TypeDecl p tc tvs ty)+  = return (i, TypeDecl p tc tvs ty)+tcTopPDecl (i, DefaultDecl p tys)+  = return (i, DefaultDecl p tys)+tcTopPDecl (i, ClassDecl p li cx cls tv ds)     = withLocalSigEnv $ do+  let (vpds, opds) = partition (isValueDecl . snd) $ toPDecls ds+  setSigEnv $ foldr (bindTypeSigs . snd) emptySigEnv opds+  vpds' <- mapM (tcClassMethodPDecl (qualify cls) tv) vpds+  return (i, ClassDecl p li cx cls tv $ fromPDecls $ map untyped opds ++ vpds')+tcTopPDecl (i, InstanceDecl p li cx qcls ty ds) = do+  tcEnv <- getTyConsEnv+  pty <- expandPoly $ QualTypeExpr NoSpanInfo cx ty+  mid <- getModuleIdent+  let origCls = getOrigName mid qcls tcEnv+      clsQual = head $ filter isQualified $ reverseLookupByOrigName origCls tcEnv+      qQualCls = qualQualify (fromJust $ qidModule clsQual) qcls+  vpds' <- mapM (tcInstanceMethodPDecl qQualCls pty) vpds+  return (i,InstanceDecl p li cx qcls ty $ fromPDecls $ map untyped opds++vpds')+  where (vpds, opds) = partition (isValueDecl . snd) $ toPDecls ds+tcTopPDecl _ = internalError "TypeCheck.tcTopDecl"++tcClassMethodPDecl :: QualIdent -> Ident -> PDecl a -> TCM (PDecl PredType)+tcClassMethodPDecl qcls tv pd@(_, FunctionDecl _ _ f _) = do+  methTy <- classMethodType qualify f+  (tySc, pd') <- tcMethodPDecl qcls methTy pd+  sigs <- getSigEnv+  let QualTypeExpr spi cx ty = fromJust $ lookupTypeSig f sigs+      qty = QualTypeExpr spi+              (Constraint NoSpanInfo qcls (VariableType NoSpanInfo tv) : cx) ty+  checkClassMethodType qty tySc pd'+tcClassMethodPDecl _ _ _ = internalError "TypeCheck.tcClassMethodPDecl"++tcInstanceMethodPDecl :: QualIdent -> PredType -> PDecl a+                      -> TCM (PDecl PredType)+tcInstanceMethodPDecl qcls pty pd@(_, FunctionDecl _ _ f _) = do+  methTy <- instMethodType (qualifyLike qcls) pty f+  (tySc, pd') <- tcMethodPDecl qcls (typeScheme methTy) pd+  checkInstMethodType (normalize 0 methTy) tySc pd'+tcInstanceMethodPDecl _ _ _ = internalError "TypeCheck.tcInstanceMethodPDecl"++tcMethodPDecl :: QualIdent -> TypeScheme -> PDecl a -> TCM (TypeScheme, PDecl PredType)+tcMethodPDecl qcls tySc (i, FunctionDecl p _ f eqs) = withLocalValueEnv $ do+  m <- getModuleIdent+  modifyValueEnv $ bindFun m f (Just qcls) (eqnArity $ head eqs) tySc+  (ps, (ty, pd)) <- tcFunctionPDecl i emptyPredSet tySc p f eqs+  theta <- getTypeSubst+  return (gen Set.empty ps $ subst theta ty, pd)+tcMethodPDecl _ _ _ = internalError "TypeCheck.tcMethodPDecl"++checkClassMethodType :: QualTypeExpr -> TypeScheme -> PDecl PredType+                     -> TCM (PDecl PredType)+checkClassMethodType qty tySc pd@(_, FunctionDecl _ _ f _) = do+  pty <- expandPoly qty+  unlessM (checkTypeSig pty tySc) $ do+    m <- getModuleIdent+    report $ errTypeSigTooGeneral m (text "Method:" <+> ppIdent f) qty tySc+  return pd+checkClassMethodType _ _ _ = internalError "TypeCheck.checkClassMethodType"++checkInstMethodType :: PredType -> TypeScheme -> PDecl PredType+                    -> TCM (PDecl PredType)+checkInstMethodType pty tySc pd@(_, FunctionDecl _ _ f _) = do+  unlessM (checkTypeSig pty tySc) $ do+    m <- getModuleIdent+    report $+      errMethodTypeTooSpecific f m (text "Method:" <+> ppIdent f) pty tySc+  return pd+checkInstMethodType _ _ _ = internalError "TypeCheck.checkInstMethodType"++classMethodType :: (Ident -> QualIdent) -> Ident -> TCM TypeScheme+classMethodType qual f = do+  m <- getModuleIdent+  vEnv <- getValueEnv+  return $ funType m (qual $ unRenameIdent f) vEnv++-- Due to the sorting of the predicate set, we can simply remove the minimum+-- element as this is guaranteed to be the class constraint (see module 'Types'+-- for more information).++instMethodType :: (Ident -> QualIdent) -> PredType -> Ident -> TCM PredType+instMethodType qual (PredType ps ty) f = do+  ForAll _ (PredType ps' ty') <- classMethodType qual f+  let PredType ps'' ty'' = instanceType ty (PredType (Set.deleteMin ps') ty')+  return $ PredType (ps `Set.union` ps'') ty''++-- External functions:++tcExternal :: Ident -> TCM Type+tcExternal f = do+  sigs <- getSigEnv+  case lookupTypeSig f sigs of+    Nothing -> internalError "TypeCheck.tcExternal: type signature not found"+    Just (QualTypeExpr _ _ ty) -> do+      m <- getModuleIdent+      PredType _ ty' <- expandPoly $ QualTypeExpr NoSpanInfo [] ty+      modifyValueEnv $ bindFun m f Nothing (arrowArity ty') (polyType ty')+      return ty'++-- Patterns and Expressions:+-- Note that the type attribute associated with a constructor or infix+-- pattern is the type of the whole pattern and not the type of the+-- constructor itself. Overloaded (numeric) literals are not supported in+-- patterns.++tcLiteral :: Bool -> Literal -> TCM (PredSet, Type)+tcLiteral _ (Char _) = return (emptyPredSet, charType)+tcLiteral poly (Int _)+  | poly      = freshNumType+  | otherwise = fmap ((,) emptyPredSet) (freshConstrained numTypes)+tcLiteral poly (Float _)+  | poly      = freshFractionalType+  | otherwise = fmap ((,) emptyPredSet) (freshConstrained fractionalTypes)+tcLiteral _    (String _) = return (emptyPredSet, stringType)++tcLhs :: HasSpanInfo p => p -> Lhs a -> PTCM (PredSet, [Type], Lhs PredType)+tcLhs p (FunLhs spi f ts) = do+  (pss, tys, ts') <- unzip3 <$> mapM (tcPatternHelper p) ts+  return (Set.unions pss, tys, FunLhs spi f ts')+tcLhs p (OpLhs spi t1 op t2) = do+  (ps1, ty1, t1') <- tcPatternHelper p t1+  (ps2, ty2, t2') <- tcPatternHelper p t2+  return (ps1 `Set.union` ps2, [ty1, ty2], OpLhs spi t1' op t2')+tcLhs p (ApLhs spi lhs ts) = do+  (ps, tys1, lhs') <- tcLhs p lhs+  (pss, tys2, ts') <- unzip3 <$> mapM (tcPatternHelper p) ts+  return (Set.unions (ps:pss), tys1 ++ tys2, ApLhs spi lhs' ts')++-- When computing the type of a variable in a pattern, we ignore the+-- predicate set of the variable's type (which can only be due to a type+-- signature in the same declaration group) for just the same reason as+-- in 'tcFunctionPDecl'. Infix and infix functional patterns are currently+-- checked as constructor and functional patterns, respectively, resulting+-- in slighty misleading error messages if the type check fails.++-- We also keep track of already used variables,+-- in order to add a Data constraint for non-linear patterns++tcPattern :: HasSpanInfo p => p -> Pattern a+          -> TCM (PredSet, Type, Pattern PredType)+tcPattern = tcPatternWith Set.empty++tcPatternWith :: HasSpanInfo p => Set.Set Ident -> p -> Pattern a+              -> TCM (PredSet, Type, Pattern PredType)+tcPatternWith s p pt = S.evalStateT (tcPatternHelper p pt) s++type PTCM a = S.StateT (Set.Set Ident) TCM a++tcPatternHelper :: HasSpanInfo p => p -> Pattern a+                -> PTCM (PredSet, Type, Pattern PredType)+tcPatternHelper _ (LiteralPattern spi _ l) = do+  (ps, ty) <- lift $ tcLiteral False l+  return (ps, ty, LiteralPattern spi (predType ty) l)+tcPatternHelper _ (NegativePattern spi _ l) = do+  (ps, ty) <- lift $ tcLiteral False l+  return (ps, ty, NegativePattern spi (predType ty) l)+tcPatternHelper _ (VariablePattern spi _ v) = do+  vEnv <- lift getValueEnv+  (_, ty) <- lift $ inst (varType v vEnv)+  used <- S.get+  ps <- if Set.member v used+          then return (Set.singleton (Pred qDataId ty))+          else S.put (Set.insert v used) >> return Set.empty+  return (ps, ty, VariablePattern spi (predType ty) v)+tcPatternHelper p t@(ConstructorPattern spi _ c ts) = do+  m <- lift getModuleIdent+  vEnv <- lift getValueEnv+  (ps, (tys, ty')) <- fmap arrowUnapply <$> lift (skol (constrType m c vEnv))+  (ps', ts') <- mapAccumM (uncurry . ptcPatternArg p "pattern" (pPrintPrec 0 t))+                          ps (zip tys ts)+  return (ps', ty', ConstructorPattern spi (predType ty') c ts')+tcPatternHelper p (InfixPattern spi a t1 op t2) = do+  (ps, ty, t') <- tcPatternHelper p (ConstructorPattern NoSpanInfo a op [t1,t2])+  let ConstructorPattern _ a' op' [t1', t2'] = t'+  return (ps, ty, InfixPattern spi a' t1' op' t2')+tcPatternHelper p (ParenPattern spi t) = do+  (ps, ty, t') <- tcPatternHelper p t+  return (ps, ty, ParenPattern spi t')+tcPatternHelper _ t@(RecordPattern spi _ c fs) = do+  m <- lift getModuleIdent+  vEnv <- lift getValueEnv+  (ps, ty) <- fmap arrowBase <$> lift (skol (constrType m c vEnv))+  -- tcField does not support passing "used" variables, thus we do it by hand+  used <- S.get+  (ps', fs') <- lift $ mapAccumM (tcField (tcPatternWith used) "pattern"+    (\t' -> pPrintPrec 0 t $-$ text "Term:" <+> pPrintPrec 0 t') ty) ps fs+  S.put $ foldr Set.insert used $ concatMap bv fs+  return (ps', ty, RecordPattern spi (predType ty) c fs')+tcPatternHelper p (TuplePattern spi ts) = do+  (pss, tys, ts') <- unzip3 <$> mapM (tcPatternHelper p) ts+  return (Set.unions pss, tupleType tys, TuplePattern spi ts')+tcPatternHelper p t@(ListPattern spi _ ts) = do+  ty <- lift freshTypeVar+  (ps, ts') <- mapAccumM (flip (ptcPatternArg p "pattern" (pPrintPrec 0 t)) ty)+                         emptyPredSet ts+  return (ps, listType ty, ListPattern spi (predType $ listType ty) ts')+tcPatternHelper p t@(AsPattern spi v t') = do+  vEnv <- lift getValueEnv+  (_, ty) <- lift $ inst (varType v vEnv)+  used <- S.get+  ps <- if Set.member v used+          then return (Set.singleton (Pred qDataId ty))+          else S.put (Set.insert v used) >> return Set.empty+  (ps'', t'') <- tcPatternHelper p t' >>-+    (\ps' ty' -> lift $ unify p "pattern" (pPrintPrec 0 t) ps ty ps' ty')+  return (ps'', ty, AsPattern spi v t'')+tcPatternHelper p (LazyPattern spi t) = do+  (ps, ty, t') <- tcPatternHelper p t+  return (ps, ty, LazyPattern spi t')+tcPatternHelper p t@(FunctionPattern spi _ f ts) = do+  m <- lift getModuleIdent+  vEnv <- lift getValueEnv+  (ps, ty) <- lift $ inst (funType m f vEnv)+  -- insert all+  S.modify (flip (foldr Set.insert) (bv t))+  tcFuncPattern p spi (pPrintPrec 0 t) f id ps ty ts+tcPatternHelper p (InfixFuncPattern spi a t1 op t2) = do+  (ps, ty, t') <- tcPatternHelper p (FunctionPattern spi a op [t1, t2])+  let FunctionPattern _ a' op' [t1', t2'] = t'+  return (ps, ty, InfixFuncPattern spi a' t1' op' t2')++tcFuncPattern :: HasSpanInfo p => p -> SpanInfo -> Doc -> QualIdent+              -> ([Pattern PredType] -> [Pattern PredType])+              -> PredSet -> Type -> [Pattern a]+              -> PTCM (PredSet, Type, Pattern PredType)+tcFuncPattern _ spi _ f ts ps ty [] =+  return (Set.insert (Pred qDataId ty) ps, ty, FunctionPattern spi (predType ty) f (ts []))+tcFuncPattern p spi doc f ts ps ty (t':ts') = do+  (alpha, beta) <- lift $+    tcArrow p "functional pattern" (doc $-$ text "Term:" <+> pPrintPrec 0 t) ty+  (ps', t'') <- ptcPatternArg p "functional pattern" doc ps alpha t'+  tcFuncPattern p spi doc f (ts . (t'' :)) ps' beta ts'+  where t = FunctionPattern spi (predType ty) f (ts [])++ptcPatternArg :: HasSpanInfo p => p -> String -> Doc -> PredSet -> Type+             -> Pattern a -> PTCM (PredSet, Pattern PredType)+ptcPatternArg p what doc ps ty t =+  tcPatternHelper p t >>-+    (\ps' ty' -> lift $+      unify p what (doc $-$ text "Term:" <+> pPrintPrec 0 t) ps ty ps' ty')++tcPatternArg :: HasSpanInfo p => p -> String -> Doc -> PredSet -> Type+             -> Pattern a -> TCM (PredSet, Pattern PredType)+tcPatternArg p what doc ps ty t =+  tcPattern p t >>-+    unify p what (doc $-$ text "Term:" <+> pPrintPrec 0 t) ps ty++tcRhs :: Rhs a -> TCM (PredSet, Type, Rhs PredType)+tcRhs (SimpleRhs p li e ds) = do+  (ps, ds', ps', ty, e') <- withLocalValueEnv $ do+    (ps, ds') <- tcDecls ds+    (ps', ty, e') <- tcExpr e+    return (ps, ds', ps', ty, e')+  ps'' <- reducePredSet p "expression" (pPrintPrec 0 e') (ps `Set.union` ps')+  return (ps'', ty, SimpleRhs p li e' ds')+tcRhs (GuardedRhs spi li es ds) = withLocalValueEnv $ do+  (ps, ds') <- tcDecls ds+  ty <- freshTypeVar+  (ps', es') <- mapAccumM (tcCondExpr ty) ps es+  return (ps', ty, GuardedRhs spi li es' ds')++tcCondExpr :: Type -> PredSet -> CondExpr a -> TCM (PredSet, CondExpr PredType)+tcCondExpr ty ps (CondExpr p g e) = do+  (ps', g') <- tcExpr g >>- unify p "guard" (pPrintPrec 0 g) ps boolType+  (ps'', e') <- tcExpr e >>- unify p "guarded expression" (pPrintPrec 0 e) ps' ty+  return (ps'', CondExpr p g' e')++tcExpr :: Expression a -> TCM (PredSet, Type, Expression PredType)+tcExpr (Literal spi _ l) = do+  (ps, ty) <- tcLiteral True l+  return (ps, ty, Literal spi (predType ty) l)+tcExpr (Variable spi _ v) = do+  m <- getModuleIdent+  vEnv <- getValueEnv+  (ps, ty) <- if isAnonId (unqualify v) then freshPredType [qDataId]+                                        else inst (funType m v vEnv)+  return (ps, ty, Variable spi (predType ty) v)+tcExpr (Constructor spi _ c) = do+  m <- getModuleIdent+  vEnv <- getValueEnv+  (ps, ty) <- inst (constrType m c vEnv)+  return (ps, ty, Constructor spi (predType ty) c)+tcExpr (Paren spi e) = do+  (ps, ty, e') <- tcExpr e+  return (ps, ty, Paren spi e')+tcExpr (Typed spi e qty) = do+  pty <- expandPoly qty+  (ps, ty) <- inst (typeScheme pty)+  (ps', e') <- tcExpr e >>-+    unifyDecl spi "explicitly typed expression" (pPrintPrec 0 e) emptyPredSet ty+  fvs <- computeFvEnv+  theta <- getTypeSubst+  let (gps, lps) = splitPredSet fvs ps'+      tySc = gen fvs lps (subst theta ty)+  unlessM (checkTypeSig pty tySc) $ do+    m <- getModuleIdent+    report $+      errTypeSigTooGeneral m (text "Expression:" <+> pPrintPrec 0 e) qty tySc+  return (ps `Set.union` gps, ty, Typed spi e' qty)+tcExpr e@(Record spi _ c fs) = do+  m <- getModuleIdent+  vEnv <- getValueEnv+  (ps, ty) <- fmap arrowBase <$> inst (constrType m c vEnv)+  (ps', fs') <- mapAccumM (tcField (const tcExpr) "construction"+    (\e' -> pPrintPrec 0 e $-$ text "Term:" <+> pPrintPrec 0 e') ty) ps fs+  let missing = map (qualifyLike c) (constrLabels m c vEnv)+                  \\ map (\(Field _ qid _) -> qid) fs'+  pss <- mapM (tcMissingField spi ty) missing+  return (Set.unions (ps':pss), ty, Record spi (predType ty) c fs')+tcExpr e@(RecordUpdate spi e1 fs) = do+  (ps, ty, e1') <- tcExpr e1+  (ps', fs') <- mapAccumM (tcField (const tcExpr) "update"+    (\e' -> pPrintPrec 0 e $-$ text "Term:" <+> pPrintPrec 0 e') ty) ps fs+  return (ps', ty, RecordUpdate spi e1' fs')+tcExpr (Tuple spi es) = do+  (pss, tys, es') <- liftM unzip3 $ mapM (tcExpr) es+  return (Set.unions pss, tupleType tys, Tuple spi es')+tcExpr e@(List spi _ es) = do+  ty <- freshTypeVar+  (ps, es') <-+    mapAccumM (flip (tcArg spi "expression" (pPrintPrec 0 e)) ty) emptyPredSet es+  return (ps, listType ty, List spi (predType $ listType ty) es')+tcExpr (ListCompr spi e qs) = do+  (ps, qs', ps', ty, e') <- withLocalValueEnv $ do+    (ps, qs') <- mapAccumM (tcQual spi) emptyPredSet qs+    (ps', ty, e') <- tcExpr e+    return (ps, qs', ps', ty, e')+  ps'' <- reducePredSet spi "expression" (pPrintPrec 0 e') (ps `Set.union` ps')+  return (ps'', listType ty, ListCompr spi e' qs')+tcExpr e@(EnumFrom spi e1) = do+  (ps, ty) <- freshEnumType+  (ps', e1') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps ty e1+  return (ps', listType ty, EnumFrom spi e1')+tcExpr e@(EnumFromThen spi e1 e2) = do+  (ps, ty) <- freshEnumType+  (ps', e1') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps ty e1+  (ps'', e2') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps' ty e2+  return (ps'', listType ty, EnumFromThen spi e1' e2')+tcExpr e@(EnumFromTo spi e1 e2) = do+  (ps, ty) <- freshEnumType+  (ps', e1') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps ty e1+  (ps'', e2') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps' ty e2+  return (ps'', listType ty, EnumFromTo spi e1' e2')+tcExpr e@(EnumFromThenTo spi e1 e2 e3) = do+  (ps, ty) <- freshEnumType+  (ps', e1') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps ty e1+  (ps'', e2') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps' ty e2+  (ps''', e3') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps'' ty e3+  return (ps''', listType ty, EnumFromThenTo spi e1' e2' e3')+tcExpr e@(UnaryMinus spi e1) = do+  (ps, ty) <- freshNumType+  (ps', e1') <- tcArg spi "unary negation" (pPrintPrec 0 e) ps ty e1+  return (ps', ty, UnaryMinus spi e1')+tcExpr e@(Apply spi e1 e2) = do+  (ps, (alpha, beta), e1') <- tcExpr e1 >>=-+    tcArrow spi "application" (pPrintPrec 0 e $-$ text "Term:" <+> pPrintPrec 0 e1)+  (ps', e2') <- tcArg spi "application" (pPrintPrec 0 e) ps alpha e2+  return (ps', beta, Apply spi e1' e2')+tcExpr e@(InfixApply spi e1 op e2) = do+  (ps, (alpha, beta, gamma), op') <- tcInfixOp op >>=-+    tcBinary spi "infix application" (pPrintPrec 0 e $-$ text "Operator:" <+> pPrint op)+  (ps', e1') <- tcArg spi "infix application" (pPrintPrec 0 e) ps alpha e1+  (ps'', e2') <- tcArg spi "infix application" (pPrintPrec 0 e) ps' beta e2+  return (ps'', gamma, InfixApply spi e1' op' e2')+tcExpr e@(LeftSection spi e1 op) = do+  (ps, (alpha, beta), op') <- tcInfixOp op >>=-+    tcArrow spi "left section" (pPrintPrec 0 e $-$ text "Operator:" <+> pPrint op)+  (ps', e1') <- tcArg spi "left section" (pPrintPrec 0 e) ps alpha e1+  return (ps', beta, LeftSection spi e1' op')+tcExpr e@(RightSection spi op e1) = do+  (ps, (alpha, beta, gamma), op') <- tcInfixOp op >>=-+    tcBinary spi "right section" (pPrintPrec 0 e $-$ text "Operator:" <+> pPrint op)+  (ps', e1') <- tcArg spi "right section" (pPrintPrec 0 e) ps beta e1+  return (ps', TypeArrow alpha gamma, RightSection spi op' e1')+tcExpr (Lambda spi ts e) = do+  (pss, tys, ts', ps, ty, e')<- withLocalValueEnv $ do+    bindLambdaVars ts+    (pss, tys, ts') <- liftM unzip3 $ mapM (tcPattern spi) ts+    (ps, ty, e') <- tcExpr e+    return (pss, tys, ts', ps, ty, e')+  ps' <- reducePredSet spi "expression" (pPrintPrec 0 e') (Set.unions $ ps : pss)+  return (ps', foldr TypeArrow ty tys, Lambda spi ts' e')+tcExpr (Let spi li ds e) = do+  (ps, ds', ps', ty, e') <- withLocalValueEnv $ do+    (ps, ds') <- tcDecls ds+    (ps', ty, e') <- tcExpr e+    return (ps, ds', ps', ty, e')+  ps'' <- reducePredSet spi "expression" (pPrintPrec 0 e') (ps `Set.union` ps')+  return (ps'', ty, Let spi li ds' e')+tcExpr (Do spi li sts e) = do+  (sts', ty, ps', e') <- withLocalValueEnv $ do+    ((ps, mTy), sts') <-+      mapAccumM (uncurry (tcStmt spi)) (emptyPredSet, Nothing) sts+    ty <- liftM (maybe id TypeApply mTy) freshTypeVar+    (ps', e') <- tcExpr e >>- unify spi "statement" (pPrintPrec 0 e) ps ty+    return (sts', ty, ps', e')+  return (ps', ty, Do spi li sts' e')+tcExpr e@(IfThenElse spi e1 e2 e3) = do+  (ps, e1') <- tcArg spi "expression" (pPrintPrec 0 e) emptyPredSet boolType e1+  (ps', ty, e2') <- tcExpr e2+  (ps'', e3') <- tcArg spi "expression" (pPrintPrec 0 e) (ps `Set.union` ps') ty e3+  return (ps'', ty, IfThenElse spi e1' e2' e3')+tcExpr (Case spi li ct e as) = do+  (ps, tyLhs, e') <- tcExpr e+  tyRhs <- freshTypeVar+  (ps', as') <- mapAccumM (tcAlt tyLhs tyRhs) ps as+  return (ps', tyRhs, Case spi li ct e' as')++tcArg :: HasSpanInfo p => p -> String -> Doc -> PredSet -> Type -> Expression a+      -> TCM (PredSet, Expression PredType)+tcArg p what doc ps ty e =+  tcExpr e >>- unify p what (doc $-$ text "Term:" <+> pPrintPrec 0 e) ps ty++tcAlt :: Type -> Type -> PredSet -> Alt a+      -> TCM (PredSet, Alt PredType)+tcAlt tyLhs tyRhs ps a@(Alt p t rhs) =+  tcAltern tyLhs p t rhs >>-+    unify p "case alternative" (pPrint a) ps tyRhs++tcAltern :: Type -> SpanInfo -> Pattern a+         -> Rhs a -> TCM (PredSet, Type, Alt PredType)+tcAltern tyLhs p t rhs = do+  (ps, t', ps', ty', rhs') <- withLocalValueEnv $ do+    bindLambdaVars t+    (ps, t') <-+      tcPatternArg p "case pattern" (pPrint (Alt p t rhs)) emptyPredSet tyLhs t+    (ps', ty', rhs') <- tcRhs rhs+    return (ps, t', ps', ty', rhs')+  ps'' <- reducePredSet p "alternative" (pPrint (Alt p t' rhs'))+                        (ps `Set.union` ps')+  return (ps'', ty', Alt p t' rhs')++tcQual :: HasSpanInfo p => p -> PredSet -> Statement a+       -> TCM (PredSet, Statement PredType)+tcQual p ps (StmtExpr spi e) = do+  (ps', e') <- tcExpr e >>- unify p "guard" (pPrintPrec 0 e) ps boolType+  return (ps', StmtExpr spi e')+tcQual _ ps (StmtDecl spi li ds) = do+  (ps', ds') <- tcDecls ds+  return (ps `Set.union` ps', StmtDecl spi li ds')+tcQual p ps q@(StmtBind spi t e) = do+  alpha <- freshTypeVar+  (ps', e') <- tcArg p "generator" (pPrint q) ps (listType alpha) e+  bindLambdaVars t+  (ps'', t') <- tcPatternArg p "generator" (pPrint q) ps' alpha t+  return (ps'', StmtBind spi t' e')++tcStmt :: HasSpanInfo p => p -> PredSet -> Maybe Type -> Statement a+       -> TCM ((PredSet, Maybe Type), Statement PredType)+tcStmt p ps mTy (StmtExpr spi e) = do+  (ps', ty) <- maybe freshMonadType (return . (,) emptyPredSet) mTy+  alpha <- freshTypeVar+  (ps'', e') <- tcExpr e >>-+    unify p "statement" (pPrintPrec 0 e) (ps `Set.union` ps') (applyType ty [alpha])+  return ((ps'', Just ty), StmtExpr spi e')+tcStmt _ ps mTy (StmtDecl spi li ds) = do+  (ps', ds') <- tcDecls ds+  return ((ps `Set.union` ps', mTy), StmtDecl spi li ds')+tcStmt p ps mTy st@(StmtBind spi t e) = do+  failable <- checkFailableBind t+  let freshMType = if failable then freshMonadFailType else freshMonadType+  (ps', ty) <- maybe freshMType (return . (,) emptyPredSet) mTy+  alpha <- freshTypeVar+  (ps'', e') <-+    tcArg p "statement" (pPrint st) (ps `Set.union` ps') (applyType ty [alpha]) e+  bindLambdaVars t+  (ps''', t') <- tcPatternArg p "statement" (pPrint st) ps'' alpha t+  return ((ps''', Just ty), StmtBind spi t' e')++checkFailableBind :: Pattern a -> TCM Bool+checkFailableBind (ConstructorPattern _ _ idt ps   ) = do+  tcEnv <- getTyConsEnv+  case qualLookupTypeInfo idt tcEnv of+    [RenamingType _ _ _ ] -> or <$> mapM checkFailableBind ps -- or [] == False+    [DataType     _ _ cs]+      | length cs == 1    -> or <$> mapM checkFailableBind ps+      | otherwise         -> return True+    _                     -> return True+checkFailableBind (InfixPattern       _ _ p1 idt p2) = do+  tcEnv <- getTyConsEnv+  case qualLookupTypeInfo idt tcEnv of+    [RenamingType _ _ _ ] -> (||) <$> checkFailableBind p1+                                  <*> checkFailableBind p2+    [DataType     _ _ cs]+      | length cs == 1    -> (||) <$> checkFailableBind p1+                                  <*> checkFailableBind p2+      | otherwise         -> return True+    _                     -> return True+checkFailableBind (RecordPattern      _ _ idt fs   ) = do+  tcEnv <- getTyConsEnv+  case qualLookupTypeInfo idt tcEnv of+    [RenamingType _ _ _ ] -> or <$> mapM (checkFailableBind . fieldContent) fs+    [DataType     _ _ cs]+      | length cs == 1    -> or <$> mapM (checkFailableBind . fieldContent) fs+      | otherwise         -> return True+    _                     -> return True+  where fieldContent (Field _ _ c) = c+checkFailableBind (TuplePattern       _       ps   ) =+  or <$> mapM checkFailableBind ps+checkFailableBind (AsPattern          _   _   p    ) = checkFailableBind p+checkFailableBind (ParenPattern       _       p    ) = checkFailableBind p+checkFailableBind (LazyPattern        _       _    ) = return False+checkFailableBind (VariablePattern    _ _ _        ) = return False+checkFailableBind _                                  = return True++tcInfixOp :: InfixOp a -> TCM (PredSet, Type, InfixOp PredType)+tcInfixOp (InfixOp _ op) = do+  m <- getModuleIdent+  vEnv <- getValueEnv+  (ps, ty) <- inst (funType m op vEnv)+  return (ps, ty, InfixOp (predType ty) op)+tcInfixOp (InfixConstr _ op) = do+  m <- getModuleIdent+  vEnv <- getValueEnv+  (ps, ty) <- inst (constrType m op vEnv)+  return (ps, ty, InfixConstr (predType ty) op)++-- The first unification in 'tcField' cannot fail; it serves only for+-- instantiating the type variables in the field label's type.++tcField :: (SpanInfo -> a b -> TCM (PredSet, Type, a PredType))+        -> String -> (a b -> Doc) -> Type -> PredSet -> Field (a b)+        -> TCM (PredSet, Field (a PredType))+tcField check what doc ty ps (Field p l x) = do+  m <- getModuleIdent+  vEnv <- getValueEnv+  (ps', ty') <- inst (labelType m l vEnv)+  let TypeArrow ty1 ty2 = ty'+  _ <- unify p "field label" empty emptyPredSet ty emptyPredSet ty1+  (ps'', x') <- check p x >>-+    unify p ("record " ++ what) (doc x) (ps `Set.union` ps') ty2+  return (ps'', Field p l x')++tcMissingField :: HasSpanInfo p => p -> Type -> QualIdent -> TCM PredSet+tcMissingField p ty l = do+  m <- getModuleIdent+  vEnv <- getValueEnv+  (ps, ty') <- inst (labelType m l vEnv)+  let TypeArrow _ ty2 = ty'+  let ps' = Set.singleton (Pred qDataId ty2)+  unify p "field label" empty ps ty' ps' (TypeArrow ty ty2)++-- | Checks that it's argument can be used as an arrow type @a -> b@ and returns+-- the pair @(a, b)@.+tcArrow :: HasSpanInfo p => p -> 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 :: HasSpanInfo p => p -> 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 :: HasSpanInfo p => p -> String -> Doc -> PredSet -> Type -> PredSet+      -> Type -> TCM PredSet+unify p what doc ps1 ty1 ps2 ty2 = do+  theta <- getTypeSubst+  let ty1' = subst theta ty1+      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)+  reducePredSet p what doc $ ps1 `Set.union` ps2++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 _ (TypeConstructor tc1) (TypeConstructor tc2)+  | tc1 == tc2 = Right idSubst+unifyTypes m (TypeApply ty11 ty12) (TypeApply ty21 ty22) =+  unifyTypeLists m [ty11, ty12] [ty21, ty22]+unifyTypes m ty1@(TypeApply _ _) (TypeArrow ty21 ty22) =+  unifyTypes m ty1 (TypeApply (TypeApply (TypeConstructor qArrowId) ty21) ty22)+unifyTypes m (TypeArrow ty11 ty12) ty2@(TypeApply _ _) =+  unifyTypes m (TypeApply (TypeApply (TypeConstructor qArrowId) ty11) ty12) ty2+unifyTypes m (TypeArrow ty11 ty12) (TypeArrow ty21 ty22) =+  unifyTypeLists m [ty11, ty12] [ty21, ty22]+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))++-- After performing a unification, the resulting substitution is applied+-- to the current predicate set and the resulting predicate set is subject+-- to a reduction. This predicate set reduction retains all predicates whose+-- types are simple variables and which are not implied but other+-- predicates in the predicate set. For all other predicates, the compiler+-- checks whether an instance exists and replaces them by applying the+-- instances' predicate set to the respective types. A minor complication+-- arises due to constrained types, which at present are used to+-- implement overloading of guard expressions and of numeric literals in+-- patterns. The set of admissible types of a constrained type may be+-- restricted by the current predicate set after the reduction and thus+-- may cause a further extension of the current type substitution.++reducePredSet :: HasSpanInfo p => p -> String -> Doc -> PredSet -> TCM PredSet+reducePredSet p what doc ps = do+  m <- getModuleIdent+  clsEnv <- getClassEnv+  theta <- getTypeSubst+  inEnv <- fmap (fmap (subst theta)) <$> getInstEnv+  let ps' = subst theta ps+      (ps1, ps2) = partitionPredSet $ minPredSet clsEnv $ reducePreds inEnv ps'+  theta' <-+    foldM (reportMissingInstance m p what doc inEnv) idSubst $ Set.toList ps2+  modifyTypeSubst $ compose theta'+  return ps1+  where+    reducePreds inEnv = Set.concatMap $ reducePred inEnv+    reducePred inEnv pr@(Pred qcls ty) =+      maybe (Set.singleton pr) (reducePreds inEnv) (instPredSet inEnv qcls ty)++instPredSet :: InstEnv' -> QualIdent -> Type -> Maybe PredSet+instPredSet inEnv qcls ty = case Map.lookup qcls $ snd inEnv of+  Just tys | ty `elem` tys -> Just emptyPredSet+  _ -> case unapplyType False ty of+    (TypeConstructor tc, tys) ->+      fmap (expandAliasType tys . snd3) (lookupInstInfo (qcls, tc) $ fst inEnv)+    _ -> Nothing++reportMissingInstance :: HasSpanInfo p => ModuleIdent -> p -> String -> Doc+                      -> InstEnv' -> TypeSubst -> Pred -> TCM TypeSubst+reportMissingInstance m p what doc inEnv theta (Pred qcls ty) =+  case subst theta ty of+    ty'@(TypeConstrained tys tv) ->+      case filter (hasInstance inEnv qcls) tys of+        [] -> do+          report $ errMissingInstance m p what doc (Pred qcls ty')+          return theta+        [ty''] -> return (bindSubst tv ty'' theta)+        tys'+          | length tys == length tys' -> return theta+          | otherwise ->+              liftM (flip (bindSubst tv) theta) (freshConstrained tys')+    ty'+      | hasInstance inEnv qcls ty' -> return theta+      | otherwise -> do+        report $ errMissingInstance m p what doc (Pred qcls ty')+        return theta++hasInstance :: InstEnv' -> QualIdent -> Type -> Bool+hasInstance inEnv qcls = isJust . instPredSet inEnv qcls++-- When a constrained type variable that is not free in the type environment+-- disappears from the current type, the type becomes ambiguous. For instance,+-- the type of the expression+--+-- let x = read "" in show x+--+-- is ambiguous assuming that 'read' and 'show' have types+--+-- read :: Read a => String -> a+-- show :: Show a => a -> String+--+-- because the compiler cannot determine which 'Read' and 'Show' instances to+-- use.+--+-- In the case of expressions with an ambiguous numeric type, i.e., a type that+-- must be an instance of 'Num' or one of its subclasses, the compiler tries to+-- resolve the ambiguity by choosing the first type from the list of default+-- types that satisfies all constraints for the ambiguous type variable. An+-- error is reported if no such type exists.++applyDefaults :: HasSpanInfo p => p -> String -> Doc -> Set.Set Int -> PredSet+              -> Type -> TCM PredSet+applyDefaults p what doc fvs ps ty = do+  m <- getModuleIdent+  clsEnv <- getClassEnv+  inEnv <- getInstEnv+  defs <- getDefaultTypes+  let theta = foldr (bindDefault defs inEnv ps) idSubst $ nub+                [ tv | Pred qcls (TypeVariable tv) <- Set.toList ps+                     , tv `Set.notMember` fvs, isNumClass clsEnv qcls ]+      ps'   = fst (partitionPredSet (subst theta ps))+      ty'   = subst theta ty+      tvs'  = nub $ filter (`Set.notMember` fvs) (typeVars ps')+  mapM_ (report . errAmbiguousTypeVariable m p what doc ps' ty') tvs'+  modifyTypeSubst $ compose theta+  return ps'++bindDefault :: [Type] -> InstEnv' -> PredSet -> Int -> TypeSubst -> TypeSubst+bindDefault defs inEnv ps tv =+  case foldr (defaultType inEnv tv) defs (Set.toList ps) of+    [] -> id+    ty:_ -> bindSubst tv ty++defaultType :: InstEnv' -> Int -> Pred -> [Type] -> [Type]+defaultType inEnv tv (Pred qcls (TypeVariable tv'))+  | tv == tv' = filter (hasInstance inEnv qcls)+  | otherwise = id+defaultType _ _ _ = id++isNumClass :: ClassEnv -> QualIdent -> Bool+isNumClass = (elem qNumId .) . flip allSuperClasses++-- 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)++freshTypeVar :: TCM Type+freshTypeVar = freshVar TypeVariable++freshPredType :: [QualIdent] -> TCM (PredSet, Type)+freshPredType qclss = do+  ty <- freshTypeVar+  return (foldr (\qcls -> Set.insert $ Pred qcls ty) emptyPredSet qclss, ty)++freshEnumType :: TCM (PredSet, Type)+freshEnumType = freshPredType [qEnumId]++freshNumType :: TCM (PredSet, Type)+freshNumType = freshPredType [qNumId]++freshFractionalType :: TCM (PredSet, Type)+freshFractionalType = freshPredType [qFractionalId]++freshMonadType :: TCM (PredSet, Type)+freshMonadType = freshPredType [qMonadId]++freshMonadFailType :: TCM (PredSet, Type)+freshMonadFailType = freshPredType [qMonadFailId]++freshDataType :: TCM (PredSet, Type)+freshDataType = freshPredType [qDataId]++freshConstrained :: [Type] -> TCM Type+freshConstrained = freshVar . TypeConstrained++inst :: TypeScheme -> TCM (PredSet, Type)+inst (ForAll n (PredType ps ty)) = do+  tys <- replicateM n freshTypeVar+  return (expandAliasType tys ps, expandAliasType tys ty)++-- The function 'skol' instantiates the type of data and newtype+-- constructors in patterns. All universally quantified type variables+-- are instantiated with fresh type variables and all existentially+-- quantified type variables are instantiated with fresh skolem types.+-- All constraints that appear on the right hand side of the+-- constructor's declaration are added to the dynamic instance+-- environment.++skol :: TypeScheme -> TCM (PredSet, Type)+skol (ForAll n (PredType ps ty)) = do+  tys <- replicateM n freshTypeVar+  clsEnv <- getClassEnv+  modifyInstEnv $+    fmap $ bindSkolemInsts $ expandAliasType tys $ maxPredSet clsEnv ps+  return (emptyPredSet, expandAliasType tys ty)+  where bindSkolemInsts = flip (foldr bindSkolemInst) . Set.toList+        bindSkolemInst (Pred qcls ty') dInEnv =+          Map.insert qcls (ty' : fromMaybe [] (Map.lookup qcls dInEnv)) dInEnv++-- The function 'gen' generalizes a predicate set ps and a type tau into+-- a type scheme forall alpha . ps -> tau by universally quantifying all+-- type variables that are free in tau and not fixed by the environment.+-- The set of the latter is given by gvs.++gen :: Set.Set Int -> PredSet -> Type -> TypeScheme+gen gvs ps ty = ForAll (length tvs) (subst theta (PredType ps ty))+  where tvs = [tv | tv <- nub (typeVars ty), tv `Set.notMember` gvs]+        tvs' = map TypeVariable [0 ..]+        theta = foldr2 bindSubst idSubst tvs tvs'++-- Auxiliary Functions:+-- The functions 'constrType', 'varType', 'funType' and 'labelType' are used+-- to retrieve the type of constructors, pattern variables, variables and+-- labels in expressions, respectively, from the value 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.++-- The function 'constrLabels' returns a list of all labels belonging to a+-- data constructor. The function 'varArity' works like 'varType' but returns+-- a variable's arity instead of its type.++constrType :: ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme+constrType m c vEnv = case qualLookupValue c vEnv of+  [DataConstructor  _ _ _ tySc] -> tySc+  [NewtypeConstructor _ _ tySc] -> tySc+  _ -> case qualLookupValue (qualQualify m c) vEnv of+    [DataConstructor  _ _ _ tySc] -> tySc+    [NewtypeConstructor _ _ tySc] -> tySc+    _ -> internalError $ "TypeCheck.constrType: " ++ show c++constrLabels :: ModuleIdent -> QualIdent -> ValueEnv -> [Ident]+constrLabels m c vEnv = case qualLookupValue c vEnv of+  [DataConstructor _ _ ls _] -> ls+  [NewtypeConstructor _ l _] -> [l]+  _ -> case qualLookupValue (qualQualify m c) vEnv of+    [DataConstructor _ _ ls _] -> ls+    [NewtypeConstructor _ l _] -> [l]+    _ -> internalError $ "TypeCheck.constrLabels: " ++ show c++varType :: Ident -> ValueEnv -> TypeScheme+varType v vEnv = case lookupValue v vEnv of+  Value _ _ _ tySc : _ -> tySc+  _ -> internalError $ "TypeCheck.varType: " ++ show v++varArity :: QualIdent -> ValueEnv -> Int+varArity v vEnv = case qualLookupValue v vEnv of+  Value _ _ n _ : _ -> n+  Label   _ _ _ : _ -> 1+  _ -> internalError $ "TypeCheck.varArity: " ++ show v++funType :: ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme+funType m f vEnv = case qualLookupValue f vEnv of+  [Value _ _ _ tySc] -> tySc+  [Label _ _ tySc] -> tySc+  _ -> case qualLookupValue (qualQualify m f) vEnv of+    [Value _ _ _ tySc] -> tySc+    [Label _ _ tySc] -> tySc+    _ -> internalError $ "TypeCheck.funType: " ++ show f++labelType :: ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme+labelType m l vEnv = case qualLookupValue l vEnv of+  [Label _ _ tySc] -> tySc+  _ -> case qualLookupValue (qualQualify m l) vEnv of+    [Label _ _ tySc] -> tySc+    _ -> internalError $ "TypeCheck.labelType: " ++ show l++-- The function 'expandPoly' handles the expansion of type aliases.++expandPoly :: QualTypeExpr -> TCM PredType+expandPoly qty = do+  m <- getModuleIdent+  tcEnv <- getTyConsEnv+  clsEnv <- getClassEnv+  return $ expandPolyType m tcEnv clsEnv qty++-- The function 'splitPredSet' splits a predicate set into a pair of predicate+-- set such that all type variables that appear in the types of the predicates+-- in the first predicate set are elements of a given set of type variables.++splitPredSet :: Set.Set Int -> PredSet -> (PredSet, PredSet)+splitPredSet fvs = Set.partition (all (`Set.member` fvs) . typeVars)++-- 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 vEnv =+  Set.fromList [tv | tySc <- localTypes vEnv, tv <- typeVars tySc, tv < 0]++computeFvEnv :: TCM (Set.Set Int)+computeFvEnv = do+  theta <- getTypeSubst+  vEnv <- getValueEnv+  return $ fvEnv (subst theta vEnv)++localTypes :: ValueEnv -> [TypeScheme]+localTypes vEnv = [tySc | (_, Value _ _ _ tySc) <- localBindings vEnv]++-- ---------------------------------------------------------------------------+-- Error functions+-- ---------------------------------------------------------------------------++errPolymorphicVar :: Ident -> Message+errPolymorphicVar v = spanInfoMessage v $ hsep $ map text+  ["Variable", idName v, "has a polymorphic type"]++errTypeSigTooGeneral :: ModuleIdent -> Doc -> QualTypeExpr+                     -> TypeScheme -> Message+errTypeSigTooGeneral m what qty tySc = spanInfoMessage qty $ vcat+  [ text "Type signature too general", what+  , text "Inferred type:"  <+> ppTypeScheme m tySc+  , text "Type signature:" <+> pPrint qty+  ]++errMethodTypeTooSpecific :: HasSpanInfo a => a -> ModuleIdent -> Doc -> PredType+                         -> TypeScheme -> Message+errMethodTypeTooSpecific p m what pty tySc = spanInfoMessage p $ vcat+  [ text "Method type too specific", what+  , text "Inferred type:" <+> ppTypeScheme m tySc+  , text "Expected type:" <+> ppPredType m pty+  ]++errNonFunctionType :: HasSpanInfo a => a -> String -> Doc -> ModuleIdent -> Type+                   -> Message+errNonFunctionType p what doc m ty = spanInfoMessage p $ vcat+  [ text "Type error in" <+> text what, doc+  , text "Type:" <+> ppType m ty+  , text "Cannot be applied"+  ]++errNonBinaryOp :: HasSpanInfo a => a -> String -> Doc -> ModuleIdent -> Type+               -> Message+errNonBinaryOp p what doc m ty = spanInfoMessage p $ vcat+  [ text "Type error in" <+> text what, doc+  , text "Type:" <+> ppType m ty+  , text "Cannot be used as binary operator"+  ]++errTypeMismatch :: HasSpanInfo a => a -> String -> Doc -> ModuleIdent -> Type+                -> Type -> Doc -> Message+errTypeMismatch p what doc m ty1 ty2 reason = spanInfoMessage p $ vcat+  [ text "Type error in"  <+> text what, doc+  , text "Inferred type:" <+> ppType m ty2+  , text "Expected type:" <+> ppType m ty1+  , reason+  ]++errSkolemFieldLabel :: HasSpanInfo a => a -> Ident -> Message+errSkolemFieldLabel p l = spanInfoMessage p $ hsep $ map text+  ["Existential type escapes with type of record selector", escName l]++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 :: HasSpanInfo a => a -> ModuleIdent -> Ident -> Type+                          -> Type -> Message+errIncompatibleLabelTypes p m l ty1 ty2 = spanInfoMessage p $ sep+  [ text "Labeled types" <+> ppIdent l <+> text "::" <+> ppType m ty1+  , nest 10 $ text "and" <+> ppIdent l <+> text "::" <+> ppType m ty2+  , text "are incompatible"+  ]++errMissingInstance :: HasSpanInfo a => ModuleIdent -> a -> String -> Doc -> Pred+                   -> Message+errMissingInstance m p what doc pr = spanInfoMessage p $ vcat+  [ text "Missing instance for" <+> ppPred m pr+  , text "in" <+> text what+  , doc+  ]++errAmbiguousTypeVariable :: HasSpanInfo a => ModuleIdent -> a -> String -> Doc+                         -> PredSet -> Type -> Int -> Message+errAmbiguousTypeVariable m p what doc ps ty tv = spanInfoMessage p $ vcat+  [ text "Ambiguous type variable" <+> ppType m (TypeVariable tv)+  , text "in type" <+> ppPredType m (PredType ps ty)+  , text "inferred for" <+> text what+  , doc+  ]
+ src/Checks/TypeSyntaxCheck.hs view
@@ -0,0 +1,498 @@+{- |+    Module      :  $Header$+    Description :  Checks type syntax+    Copyright   :  (c) 2016 - 2017 Finn Teegen+    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 checks all type definitions and+   signatures. In particular, this module disambiguates 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.TypeSyntaxCheck (typeSyntaxCheck) where++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative      ((<$>), (<*>), pure)+#endif+import           Control.Monad            (unless, when)+import qualified Control.Monad.State as S (State, runState, gets, modify)+import           Data.List                (nub)+import           Data.Maybe               (isNothing)++import Curry.Base.Ident+import Curry.Base.Position+import Curry.Base.SpanInfo+import Curry.Base.Pretty+import Curry.Syntax+import Curry.Syntax.Pretty++import Base.Expr (Expr (fv))+import Base.Messages (Message, spanInfoMessage, internalError)+import Base.TopEnv+import Base.Utils (findMultiples, findDouble)++import Env.TypeConstructor (TCEnv)+import Env.Type++-- TODO Use span info for err messages++-- In order to check type constructor applications, the compiler+-- maintains an environment containing all known type constructors and+-- type classes. The function 'typeSyntaxCheck' expects a type constructor+-- environment that is already initialized with the imported type constructors+-- and type classes. The type constructor environment is converted to a type+-- identifier environment, before all locally defined type constructors and+-- type classes are added to this environment and the declarations are checked+-- within this environment.++typeSyntaxCheck :: TCEnv -> Module a -> (Module a, [Message])+typeSyntaxCheck tcEnv mdl@(Module _ _ _ m _ _ ds) =+  case findMultiples $ map getIdent tcds of+    [] -> if length dfds <= 1+            then runTSCM (checkModule mdl) state+            else (mdl, [errMultipleDefaultDeclarations dfps])+    tss -> (mdl, map errMultipleDeclarations tss)+  where+    tcds = filter isTypeOrClassDecl ds+    dfds = filter isDefaultDecl ds+    dfps = map (\(DefaultDecl p _) -> p) dfds+    tEnv = foldr (bindType m) (fmap toTypeKind tcEnv) tcds+    state = TSCState m tEnv 1 []++-- Type Syntax Check Monad+type TSCM = S.State TSCState++-- |Internal state of the Type Syntax Check+data TSCState = TSCState+  { moduleIdent :: ModuleIdent+  , typeEnv     :: TypeEnv+  , nextId      :: Integer+  , errors      :: [Message]+  }++runTSCM :: TSCM a -> TSCState -> (a, [Message])+runTSCM tscm s = let (a, s') = S.runState tscm s in (a, reverse $ errors s')++getModuleIdent :: TSCM ModuleIdent+getModuleIdent = S.gets moduleIdent++getTypeEnv :: TSCM TypeEnv+getTypeEnv = S.gets typeEnv++newId :: TSCM Integer+newId = do+  curId <- S.gets nextId+  S.modify $ \s -> s { nextId = succ curId }+  return curId++report :: Message -> TSCM ()+report err = S.modify (\s -> s { errors = err : errors s })++ok :: TSCM ()+ok = return ()++bindType :: ModuleIdent -> Decl a -> TypeEnv -> TypeEnv+bindType m (DataDecl _ tc _ cs _) = bindTypeKind m tc (Data qtc ids)+  where+    qtc = qualifyWith m tc+    ids = map constrId cs ++ nub (concatMap recordLabels cs)+bindType m (ExternalDataDecl _ tc _) = bindTypeKind m tc (Data qtc [])+  where+    qtc = qualifyWith m tc+bindType m (NewtypeDecl _ tc _ nc _) = bindTypeKind m tc (Data qtc ids)+  where+    qtc = qualifyWith m tc+    ids = nconstrId nc : nrecordLabels nc+bindType m (TypeDecl _ tc _ _) = bindTypeKind m tc (Alias qtc)+  where+    qtc = qualifyWith m tc+bindType m (ClassDecl _ _ _ cls _ ds)  = bindTypeKind m cls (Class qcls ms)+  where+    qcls = qualifyWith m cls+    ms = concatMap methods ds+bindType _ _ = id++-- 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.++checkModule :: Module a -> TSCM (Module a)+checkModule (Module spi li ps m es is ds) = do+  ds' <- mapM checkDecl ds+  return $ Module spi li ps m es is ds'++checkDecl :: Decl a -> TSCM (Decl a)+checkDecl (DataDecl p tc tvs cs clss)         = do+  checkTypeLhs tvs+  cs' <- mapM (checkConstrDecl tvs) cs+  mapM_ (checkClass False) clss+  return $ DataDecl p tc tvs cs' clss+checkDecl (NewtypeDecl p tc tvs nc clss)      = do+  checkTypeLhs tvs+  nc' <- checkNewConstrDecl tvs nc+  mapM_ (checkClass False) clss+  return $ NewtypeDecl p tc tvs nc' clss+checkDecl (TypeDecl p tc tvs ty)              = do+  checkTypeLhs tvs+  ty' <- checkClosedType tvs ty+  return $ TypeDecl p tc tvs ty'+checkDecl (TypeSig p vs qty)                   =+  TypeSig p vs <$> checkQualType qty+checkDecl (FunctionDecl a p f eqs)            = FunctionDecl a p f <$>+  mapM checkEquation eqs+checkDecl (PatternDecl p t rhs)               = PatternDecl p t <$> checkRhs rhs+checkDecl (DefaultDecl p tys)                 = DefaultDecl p <$>+  mapM (checkClosedType []) tys+checkDecl (ClassDecl p li cx cls clsvar ds)   = do+  checkTypeVars "class declaration" [clsvar]+  cx' <- checkClosedContext [clsvar] cx+  checkSimpleContext cx'+  ds' <- mapM checkDecl ds+  mapM_ (checkClassMethod clsvar) ds'+  return $ ClassDecl p li cx' cls clsvar ds'+checkDecl (InstanceDecl p li cx qcls inst ds) = do+  checkClass True qcls+  QualTypeExpr _ cx' inst' <- checkQualType $ QualTypeExpr NoSpanInfo cx inst+  checkSimpleContext cx'+  checkInstanceType p inst'+  InstanceDecl p li cx' qcls inst' <$> mapM checkDecl ds+checkDecl d                                   = return d++checkConstrDecl :: [Ident] -> ConstrDecl -> TSCM ConstrDecl+checkConstrDecl tvs (ConstrDecl p c tys) = do+  tys' <- mapM (checkClosedType tvs) tys+  return $ ConstrDecl p c tys'+checkConstrDecl tvs (ConOpDecl p ty1 op ty2) = do+  tys' <- mapM (checkClosedType tvs) [ty1, ty2]+  let [ty1', ty2'] = tys'+  return $ ConOpDecl p ty1' op ty2'+checkConstrDecl tvs (RecordDecl p c fs) = do+  fs' <- mapM (checkFieldDecl tvs) fs+  return $ RecordDecl p c fs'++checkFieldDecl :: [Ident] -> FieldDecl -> TSCM FieldDecl+checkFieldDecl tvs (FieldDecl p ls ty) =+  FieldDecl p ls <$> checkClosedType tvs ty++checkNewConstrDecl :: [Ident] -> NewConstrDecl -> TSCM NewConstrDecl+checkNewConstrDecl tvs (NewConstrDecl p c ty) = do+  ty'  <- checkClosedType tvs ty+  return $ NewConstrDecl p c ty'+checkNewConstrDecl tvs (NewRecordDecl p c (l, ty)) = do+  ty'  <- checkClosedType tvs ty+  return $ NewRecordDecl p c (l, ty')++checkSimpleContext :: Context -> TSCM ()+checkSimpleContext = mapM_ checkSimpleConstraint++checkSimpleConstraint :: Constraint -> TSCM ()+checkSimpleConstraint c@(Constraint _ _ ty) =+  unless (isVariableType ty) $ report $ errIllegalSimpleConstraint c++-- Class method's type signatures have to obey a few additional restrictions.+-- The class variable must appear in the method's type and the method's+-- context must not contain any additional constraints for that class variable.++checkClassMethod :: Ident -> Decl a -> TSCM ()+checkClassMethod tv (TypeSig spi _ qty) = do+  unless (tv `elem` fv qty) $ report $ errAmbiguousType spi tv+  let QualTypeExpr _ cx _ = qty+  when (tv `elem` fv cx) $ report $ errConstrainedClassVariable spi tv+checkClassMethod _ _ = ok++checkInstanceType :: SpanInfo -> InstanceType -> TSCM ()+checkInstanceType p inst = do+  tEnv <- getTypeEnv+  unless (isSimpleType inst &&+    not (isTypeSyn (typeConstr inst) tEnv) &&+    not (any isAnonId $ typeVariables inst) &&+    isNothing (findDouble $ fv inst)) $+      report $ errIllegalInstanceType p inst++checkTypeLhs :: [Ident] -> TSCM ()+checkTypeLhs = checkTypeVars "left hand side of type declaration"++-- |Checks a list of type variables for+-- * Anonymous type variables are allowed+-- * only type variables (no type constructors)+-- * linearity+checkTypeVars :: String -> [Ident] -> TSCM ()+checkTypeVars _    []         = ok+checkTypeVars what (tv : tvs) = do+  unless (isAnonId tv) $ do+    isTypeConstrOrClass <- not . null . lookupTypeKind tv <$> getTypeEnv+    when isTypeConstrOrClass $ report $ errNoVariable tv what+    when (tv `elem` tvs) $ report $ errNonLinear tv what+  checkTypeVars what 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 a -> TSCM (Equation a)+checkEquation (Equation p lhs rhs) = Equation p lhs <$> checkRhs rhs++checkRhs :: Rhs a -> TSCM (Rhs a)+checkRhs (SimpleRhs spi li e ds)   =+  SimpleRhs spi li <$> checkExpr e <*> mapM checkDecl ds+checkRhs (GuardedRhs spi li es ds) =+  GuardedRhs spi li <$> mapM checkCondExpr es <*> mapM checkDecl ds++checkCondExpr :: CondExpr a -> TSCM (CondExpr a)+checkCondExpr (CondExpr spi g e) = CondExpr spi <$> checkExpr g <*> checkExpr e++checkExpr :: Expression a -> TSCM (Expression a)+checkExpr l@(Literal             _ _ _) = return l+checkExpr v@(Variable            _ _ _) = return v+checkExpr c@(Constructor         _ _ _) = return c+checkExpr (Paren                 spi e) = Paren spi <$> checkExpr e+checkExpr (Typed             spi e qty) = Typed spi <$> checkExpr e+                                                    <*> checkQualType qty+checkExpr (Record           spi a c fs) =+  Record spi a c <$> mapM checkFieldExpr fs+checkExpr (RecordUpdate       spi e fs) =+  RecordUpdate spi <$> checkExpr e <*> mapM checkFieldExpr fs+checkExpr (Tuple                spi es) = Tuple spi <$> mapM checkExpr es+checkExpr (List               spi a es) = List spi a <$> mapM checkExpr es+checkExpr (ListCompr          spi e qs) = ListCompr spi <$> checkExpr e+                                                        <*> mapM checkStmt qs+checkExpr (EnumFrom              spi e) = EnumFrom spi <$> checkExpr e+checkExpr (EnumFromThen      spi e1 e2) = EnumFromThen spi <$> checkExpr e1+                                                           <*> checkExpr e2+checkExpr (EnumFromTo        spi e1 e2) = EnumFromTo spi <$> checkExpr e1+                                                         <*> checkExpr e2+checkExpr (EnumFromThenTo spi e1 e2 e3) = EnumFromThenTo spi <$> checkExpr e1+                                                             <*> checkExpr e2+                                                             <*> checkExpr e3+checkExpr (UnaryMinus            spi e) = UnaryMinus spi <$> checkExpr e+checkExpr (Apply             spi e1 e2) = Apply spi <$> checkExpr e1+                                                    <*> checkExpr e2+checkExpr (InfixApply     spi e1 op e2) = InfixApply spi <$> checkExpr e1+                                                         <*> return op+                                                         <*> checkExpr e2+checkExpr (LeftSection spi e op)        = flip (LeftSection spi) op <$>+  checkExpr e+checkExpr (RightSection spi op e)       = RightSection spi op <$> checkExpr e+checkExpr (Lambda spi ts e)             = Lambda spi ts <$> checkExpr e+checkExpr (Let spi li ds e)             = Let spi li <$> mapM checkDecl ds+                                                     <*> checkExpr e+checkExpr (Do spi li sts e)             = Do spi li <$> mapM checkStmt sts+                                                    <*> checkExpr e+checkExpr (IfThenElse spi e1 e2 e3)     = IfThenElse spi <$> checkExpr e1+                                                         <*> checkExpr e2+                                                         <*> checkExpr e3+checkExpr (Case spi li ct e alts)       = Case spi li ct <$> checkExpr e+                                                         <*> mapM checkAlt alts++checkStmt :: Statement a -> TSCM (Statement a)+checkStmt (StmtExpr spi e)     = StmtExpr spi    <$> checkExpr e+checkStmt (StmtBind spi t e)   = StmtBind spi t  <$> checkExpr e+checkStmt (StmtDecl spi li ds) = StmtDecl spi li <$> mapM checkDecl ds++checkAlt :: Alt a -> TSCM (Alt a)+checkAlt (Alt spi t rhs) = Alt spi t <$> checkRhs rhs++checkFieldExpr :: Field (Expression a) -> TSCM (Field (Expression a))+checkFieldExpr (Field spi l e) = Field spi 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.++checkQualType :: QualTypeExpr -> TSCM QualTypeExpr+checkQualType (QualTypeExpr spi cx ty) = do+  ty' <- checkType ty+  cx' <- checkClosedContext (fv ty') cx+  return $ QualTypeExpr spi cx' ty'++checkClosedContext :: [Ident] -> Context -> TSCM Context+checkClosedContext tvs cx = do+  cx' <- checkContext cx+  mapM_ (\(Constraint _ _ ty) -> checkClosed tvs ty) cx'+  return cx'++checkContext :: Context -> TSCM Context+checkContext = mapM checkConstraint++checkConstraint :: Constraint -> TSCM Constraint+checkConstraint c@(Constraint spi qcls ty) = do+  checkClass False qcls+  ty' <- checkType ty+  unless (isVariableType $ rootType ty') $ report $ errIllegalConstraint c+  return $ Constraint spi qcls ty'+  where+    rootType (ApplyType _ ty' _) = ty'+    rootType ty'                 = ty'++checkClass :: Bool -> QualIdent -> TSCM ()+checkClass isInstDecl qcls = do+  m <- getModuleIdent+  tEnv <- getTypeEnv+  case qualLookupTypeKind qcls tEnv of+    [] -> report $ errUndefinedClass qcls+    [Class c _]+      | c == qDataId -> when (isInstDecl && m /= preludeMIdent) $ report $+                          errIllegalDataInstance qcls+      | otherwise    -> ok+    [_] -> report $ errUndefinedClass qcls+    tks -> case qualLookupTypeKind (qualQualify m qcls) tEnv of+      [Class c _]+        | c == qDataId -> when (isInstDecl && m /= preludeMIdent) $ report $+                            errIllegalDataInstance qcls+        | otherwise    -> ok+      [_] -> report $ errUndefinedClass qcls+      _ -> report $ errAmbiguousIdent qcls $ map origName tks++checkClosedType :: [Ident] -> TypeExpr -> TSCM TypeExpr+checkClosedType tvs ty = do+  ty' <- checkType ty+  checkClosed tvs ty'+  return ty'++checkType :: TypeExpr -> TSCM TypeExpr+checkType c@(ConstructorType spi tc) = do+  m <- getModuleIdent+  tEnv <- getTypeEnv+  case qualLookupTypeKind tc tEnv of+    []+      | isQTupleId tc -> return c+      | not (isQualified tc) -> return $ VariableType spi $ unqualify tc+      | otherwise -> report (errUndefinedType tc) >> return c+    [Class _ _] -> report (errUndefinedType tc) >> return c+    [_] -> return c+    tks -> case qualLookupTypeKind (qualQualify m tc) tEnv of+      [Class _ _] -> report (errUndefinedType tc) >> return c+      [_] -> return c+      _ -> report (errAmbiguousIdent tc $ map origName tks) >> return c+checkType (ApplyType spi ty1 ty2) = ApplyType spi <$> checkType ty1+                                                  <*> checkType ty2+checkType (VariableType spi tv)+  | isAnonId tv = (VariableType spi . renameIdent tv) <$> newId+  | otherwise   = checkType $ ConstructorType spi (qualify tv)+checkType (TupleType     spi tys) = TupleType  spi    <$> mapM checkType tys+checkType (ListType       spi ty) = ListType   spi    <$> checkType ty+checkType (ArrowType spi ty1 ty2) = ArrowType  spi    <$> checkType ty1+                                                      <*> checkType ty2+checkType (ParenType      spi ty) = ParenType  spi    <$> checkType ty+checkType (ForallType  spi vs ty) = ForallType spi vs <$> checkType ty++checkClosed :: [Ident] -> TypeExpr -> TSCM ()+checkClosed _   (ConstructorType _ _) = ok+checkClosed tvs (ApplyType _ ty1 ty2) = mapM_ (checkClosed tvs) [ty1, ty2]+checkClosed tvs (VariableType   _ tv) =+  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+checkClosed tvs (ForallType  _ vs ty) = checkClosed (tvs ++ vs) ty++-- ---------------------------------------------------------------------------+-- Auxiliary definitions+-- ---------------------------------------------------------------------------++getIdent :: Decl a -> Ident+getIdent (DataDecl     _ tc _ _ _) = tc+getIdent (ExternalDataDecl _ tc _) = tc+getIdent (NewtypeDecl _ tc _ _ _)  = tc+getIdent (TypeDecl _ tc _ _)       = tc+getIdent (ClassDecl _ _ _ cls _ _) = cls+getIdent _                         = internalError+  "Checks.TypeSyntaxCheck.getIdent: no type or class declaration"++isTypeSyn :: QualIdent -> TypeEnv -> Bool+isTypeSyn tc tEnv = case qualLookupTypeKind tc tEnv of+  [Alias _] -> True+  _ -> False++-- ---------------------------------------------------------------------------+-- Error messages+-- ---------------------------------------------------------------------------++errMultipleDefaultDeclarations :: [SpanInfo] -> Message+errMultipleDefaultDeclarations spis = spanInfoMessage (head spis) $+  text "More than one default declaration:" $+$+    nest 2 (vcat $ map showPos spis)+  where showPos = text . showLine . getPosition++errMultipleDeclarations :: [Ident] -> Message+errMultipleDeclarations is = spanInfoMessage i $+  text "Multiple declarations of" <+> text (escName i) <+> text "at:" $+$+    nest 2 (vcat $ map showPos is)+  where i = head is+        showPos = text . showLine . getPosition++errUndefined :: String -> QualIdent -> Message+errUndefined what qident = spanInfoMessage qident $ hsep $ map text+  ["Undefined", what, qualName qident]++errUndefinedClass :: QualIdent -> Message+errUndefinedClass = errUndefined "class"++errUndefinedType :: QualIdent -> Message+errUndefinedType = errUndefined "type"++errAmbiguousIdent :: QualIdent -> [QualIdent] -> Message+errAmbiguousIdent qident qidents = spanInfoMessage qident $+  text "Ambiguous identifier" <+> text (escQualName qident) $+$+    text "It could refer to:" $+$ nest 2 (vcat (map (text . qualName) qidents))++errAmbiguousType :: SpanInfo -> Ident -> Message+errAmbiguousType spi ident = spanInfoMessage spi $ hsep $ map text+  [ "Method type does not mention class variable", idName ident ]++errConstrainedClassVariable :: SpanInfo -> Ident -> Message+errConstrainedClassVariable spi ident = spanInfoMessage spi $ hsep $ map text+  [ "Method context must not constrain class variable", idName ident ]++errNonLinear :: Ident -> String -> Message+errNonLinear tv what = spanInfoMessage tv $ hsep $ map text+  [ "Type variable", idName tv, "occurs more than once in", what ]++errNoVariable :: Ident -> String -> Message+errNoVariable tv what = spanInfoMessage tv $ hsep $ map text+  ["Type constructor or type class identifier", idName tv, "used in", what]++errUnboundVariable :: Ident -> Message+errUnboundVariable tv = spanInfoMessage tv $ hsep $ map text+  [ "Unbound type variable", idName tv ]++errIllegalConstraint :: Constraint -> Message+errIllegalConstraint c@(Constraint _ qcls _) = spanInfoMessage qcls $ vcat+  [ text "Illegal class constraint" <+> pPrint c+  , text "Constraints must be of the form C u or C (u t1 ... tn),"+  , text "where C is a type class, u is a type variable and t1, ..., tn are types."+  ]++errIllegalSimpleConstraint :: Constraint -> Message+errIllegalSimpleConstraint c@(Constraint _ qcls _) = spanInfoMessage qcls $ vcat+  [ text "Illegal class constraint" <+> pPrint c+  , text "Constraints in class and instance declarations must be of"+  , text "the form C u, where C is a type class and u is a type variable."+  ]++errIllegalInstanceType :: SpanInfo -> InstanceType -> Message+errIllegalInstanceType spi inst = spanInfoMessage spi $ vcat+  [ text "Illegal instance type" <+> ppInstanceType inst+  , text "The instance type must be of the form (T u_1 ... u_n),"+  , text "where T is not a type synonym and u_1, ..., u_n are"+  , text "mutually distinct, non-anonymous type variables."+  ]++errIllegalDataInstance :: QualIdent -> Message+errIllegalDataInstance qcls = spanInfoMessage qcls $ vcat+  [ text "Illegal instance of" <+> ppQIdent qcls+  , text "Instances of this class cannot be defined."+  , text "Instead, they are automatically derived if possible."+  ]
+ src/Checks/WarnCheck.hs view
@@ -0,0 +1,1641 @@+{- |+    Module      :  $Header$+    Description :  Checks for irregular code+    Copyright   :  (c) 2006        Martin Engelke+                       2011 - 2014 Björn Peemöller+                       2014 - 2015 Jan Tikovsky+                       2016 - 2017 Finn Teegen+    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.+-}+{-# LANGUAGE CPP #-}+module Checks.WarnCheck (warnCheck) where++#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif++import           Control.Applicative+  ((<|>))+import           Control.Monad+  (filterM, foldM_, guard, liftM, liftM2, when, unless, void)+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           Data.Char+  (isLower, isUpper, toLower, toUpper, isAlpha)+import qualified Data.Set.Extra as Set+import           Data.Tuple.Extra+  (snd3)++import Curry.Base.Ident+import Curry.Base.Position+import Curry.Base.Pretty+import Curry.Base.SpanInfo+import Curry.Syntax+import Curry.Syntax.Utils  (typeVariables)+import Curry.Syntax.Pretty (pPrint)++import Base.CurryTypes (ppTypeScheme, fromPred, toPredSet)+import Base.Messages   (Message, spanInfoMessage, 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.Class (ClassEnv, classMethods, hasDefaultImpl)+import Env.TypeConstructor ( TCEnv, TypeInfo (..), lookupTypeInfo+                           , qualLookupTypeInfo, getOrigName )+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+--   - wrong case mode+--   - redundant context+warnCheck :: WarnOpts -> CaseMode -> AliasEnv -> ValueEnv -> TCEnv -> ClassEnv+          -> Module a -> [Message]+warnCheck wOpts cOpts aEnv valEnv tcEnv clsEnv mdl+  = runOn (initWcState mid aEnv valEnv tcEnv clsEnv (wnWarnFlags wOpts) cOpts) $ do+      checkImports   is+      checkDeclGroup ds+      checkExports   es+      checkMissingTypeSignatures ds+      checkModuleAlias is+      checkCaseMode  ds+      checkRedContext ds+  where Module _ _ _ mid es is ds = fmap (const ()) mdl++type ScopeEnv = NestEnv IdInfo++-- Current state of generating warnings+data WcState = WcState+  { moduleId    :: ModuleIdent+  , scope       :: ScopeEnv+  , aliasEnv    :: AliasEnv+  , valueEnv    :: ValueEnv+  , tyConsEnv   :: TCEnv+  , classEnv    :: ClassEnv+  , warnFlags   :: [WarnFlag]+  , caseMode    :: CaseMode+  , 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 -> ClassEnv+            -> [WarnFlag] -> CaseMode -> WcState+initWcState mid ae ve te ce wf cm = WcState mid emptyEnv ae ve te ce wf cm []++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 = spanInfoMessage mid $ hsep $ map text+  ["Module", moduleName mid, "is imported more than once"]++warnMultiplyImportedSymbol :: ModuleIdent -> Ident -> Message+warnMultiplyImportedSymbol mid ident = spanInfoMessage ident $ hsep $ map text+  [ "Symbol", escName ident, "from module", moduleName mid+  , "is imported more than once" ]++warnMultiplyHiddenSymbol :: ModuleIdent -> Ident -> Message+warnMultiplyHiddenSymbol mid ident = spanInfoMessage 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 a] -> 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 (spanInfo2Pos p')+          return (f, env)+  check (_    , env) _                     = return (mkIdent "", env)++warnDisjoinedFunctionRules :: Ident -> Position -> Message+warnDisjoinedFunctionRules ident pos = spanInfoMessage 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 (NewtypeDecl       _ _ vs nc _) = inNestedScope $ do+  mapM_ insertTypeVar   vs+  checkNewConstrDecl nc+  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 (DefaultDecl             _ tys) = mapM_ checkTypeExpr tys+checkDecl (ClassDecl        _ _ _ _ _ ds) = mapM_ checkDecl ds+checkDecl (InstanceDecl p _ cx cls ty ds) = do+  checkOrphanInstance p cx cls ty+  checkMissingMethodImplementations p cls ds+  mapM_ checkDecl ds+checkDecl _                             = ok++--TODO: shadowing und context etc.+checkConstrDecl :: ConstrDecl -> WCM ()+checkConstrDecl (ConstrDecl     _ c tys) = inNestedScope $ do+  visitId c+  mapM_ checkTypeExpr tys+checkConstrDecl (ConOpDecl _ ty1 op ty2) = inNestedScope $ do+  visitId op+  mapM_ checkTypeExpr [ty1, ty2]+checkConstrDecl (RecordDecl      _ c fs) = inNestedScope $ do+  visitId c+  mapM_ checkTypeExpr tys+  where+    tys = [ty | FieldDecl _ _ ty <- fs]++checkNewConstrDecl :: NewConstrDecl -> WCM ()+checkNewConstrDecl (NewConstrDecl _ c      ty) = do+  visitId c+  checkTypeExpr ty+checkNewConstrDecl (NewRecordDecl _ c (_, ty)) = do+  visitId c+  checkTypeExpr ty++checkTypeExpr :: TypeExpr -> WCM ()+checkTypeExpr (ConstructorType     _ qid) = visitQTypeId qid+checkTypeExpr (ApplyType       _ ty1 ty2) = mapM_ checkTypeExpr [ty1, ty2]+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+checkTypeExpr (ForallType        _ vs ty) = do+  mapM_ insertTypeVar vs+  checkTypeExpr ty++-- Checks locally declared identifiers (i.e. functions and logic variables)+-- for shadowing+checkLocalDecl :: Decl a -> WCM ()+checkLocalDecl (FunctionDecl _ _ f _) = checkShadowing f+checkLocalDecl (FreeDecl        _ vs) = mapM_ (checkShadowing . varIdent) vs+checkLocalDecl (PatternDecl    _ p _) = checkPattern p+checkLocalDecl _                      = ok++checkFunctionDecl :: SpanInfo -> Ident -> [Equation ()] -> WCM ()+checkFunctionDecl _ _ []  = ok+checkFunctionDecl p f eqs = inNestedScope $ do+  mapM_ checkEquation eqs+  checkFunctionPatternMatch p f eqs++checkFunctionPatternMatch :: SpanInfo -> Ident -> [Equation ()] -> WCM ()+checkFunctionPatternMatch spi f eqs = do+  let pats = map (\(Equation _ lhs _) -> snd (flatLhs lhs)) eqs+  let guards = map eq2Guards eqs+  (nonExhaustive, overlapped, nondet) <- checkPatternMatching pats guards+  unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $+    warnMissingPattern spi ("an equation for " ++ escName f) nonExhaustive+  when (nondet || not (null overlapped)) $ warnFor WarnOverlapping $ report $+    warnNondetOverlapping spi ("Function " ++ escName f)+  where eq2Guards :: Equation () -> [CondExpr ()]+        eq2Guards (Equation _ _ (GuardedRhs _ _ conds _)) = conds+        eq2Guards _ = []++-- 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 a -> WCM ()+checkLhs (FunLhs    _ _ ts) = do+  mapM_ checkPattern ts+  mapM_ (insertPattern False) ts+checkLhs (OpLhs spi t1 op t2) = checkLhs (FunLhs spi op [t1, t2])+checkLhs (ApLhs   _ lhs ts) = do+  checkLhs lhs+  mapM_ checkPattern ts+  mapM_ (insertPattern False) ts++checkPattern :: Pattern a -> WCM ()+checkPattern (VariablePattern          _ _ v) = checkShadowing v+checkPattern (ConstructorPattern    _ _ _ ps) = mapM_ checkPattern ps+checkPattern (InfixPattern     spi a p1 f p2) =+  checkPattern (ConstructorPattern spi a 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 spi a p1 f p2) =+  checkPattern (FunctionPattern spi a 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      spi _ ct e alts) = do+  checkExpr e+  mapM_ checkAlt alts+  checkCaseAlts spi 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 orphan instances+-- -----------------------------------------------------------------------------++checkOrphanInstance :: SpanInfo -> Context -> QualIdent -> TypeExpr -> WCM ()+checkOrphanInstance p cx cls ty = warnFor WarnOrphanInstances $ do+  m <- getModuleIdent+  tcEnv <- gets tyConsEnv+  let ocls = getOrigName m cls tcEnv+      otc  = getOrigName m tc  tcEnv+  unless (isLocalIdent m ocls || isLocalIdent m otc) $ report $+    warnOrphanInstance p $ pPrint $+    InstanceDecl p WhitespaceLayout cx cls ty []+  where tc = typeConstr ty++warnOrphanInstance :: SpanInfo -> Doc -> Message+warnOrphanInstance spi doc = spanInfoMessage spi $ text "Orphan instance:" <+> doc++-- -----------------------------------------------------------------------------+-- Check for missing method implementations+-- -----------------------------------------------------------------------------++checkMissingMethodImplementations :: SpanInfo -> QualIdent -> [Decl a] -> WCM ()+checkMissingMethodImplementations p cls ds = warnFor WarnMissingMethods $ do+  m <- getModuleIdent+  tcEnv <- gets tyConsEnv+  clsEnv <- gets classEnv+  let ocls = getOrigName m cls tcEnv+      ms   = classMethods ocls clsEnv+  mapM_ (report . warnMissingMethodImplementation p) $+    filter ((null fs ||) . not . flip (hasDefaultImpl ocls) clsEnv) $ ms \\ fs+  where fs = map unRenameIdent $ concatMap impls ds++warnMissingMethodImplementation :: SpanInfo -> Ident -> Message+warnMissingMethodImplementation spi f = spanInfoMessage spi $ hsep $ map text+  ["No explicit implementation for method", escName f]++-- -----------------------------------------------------------------------------+-- 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 a] -> 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 = spanInfoMessage 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 = spanInfoMessage 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 = spanInfoMessage (head mids) $ text+  "Overlapping module aliases" $+$ nest 2 (vcat (map myppAlias mids))+  where myppAlias mid =+          ppLine (getPosition mid) <> text ":" <+> text (escModuleName mid)++-- -----------------------------------------------------------------------------+-- Check for overlapping/unreachable and non-exhaustive case alternatives+-- -----------------------------------------------------------------------------++checkCaseAlts :: SpanInfo -> CaseType -> [Alt ()] -> WCM ()+checkCaseAlts _ _ []      = ok+checkCaseAlts spi ct alts = do+  let spis = map (\(Alt s _ _) -> s) alts+  let pats = map (\(Alt _ pat _) -> [pat]) alts+  let guards = map alt2Guards alts+  (nonExhaustive, overlapped, nondet) <- checkPatternMatching pats guards+  case ct of+    Flex -> do+      unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $+        warnMissingPattern spi "an fcase alternative" nonExhaustive+      when (nondet || not (null overlapped)) $ warnFor WarnOverlapping $ report+        $ warnNondetOverlapping spi "An fcase expression"+    Rigid -> do+      unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $+        warnMissingPattern spi "a case alternative" nonExhaustive+      unless (null overlapped) $ void $ mapM (warnFor WarnOverlapping . report) $+        map (\(i, pat) -> warnUnreachablePattern (spis !! i) pat) overlapped+  where alt2Guards :: Alt () -> [CondExpr ()]+        alt2Guards (Alt _ _ (GuardedRhs _ _ conds _)) = conds+        alt2Guards _ = []++-- -----------------------------------------------------------------------------+-- 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 ()]] -> [[CondExpr ()]]+                     -> WCM ([ExhaustivePats], [OverlappingPats], Bool)+checkPatternMatching pats guards = 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 (zip3 [0..] simplePats guards)+  -- 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 = [(i, eqn) | (i, eqn) <- zip [0..] 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 s -> simplifyListPattern $ map (LiteralPattern NoSpanInfo () . Char) s+  _        -> p+simplifyPat (NegativePattern       spi a l) =+  return $ LiteralPattern spi a (negateLit l)+  where+  negateLit (Int   n) = Int   (-n)+  negateLit (Float d) = Float (-d)+  negateLit x         = x+simplifyPat v@(VariablePattern       _ _ _) = return v+simplifyPat (ConstructorPattern spi a c ps) =+  ConstructorPattern spi a c `liftM` mapM simplifyPat ps+simplifyPat (InfixPattern    spi a p1 c p2) =+  ConstructorPattern spi a 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 NoSpanInfo () c ps)+  where+    getPattern fs' l' =+      fromMaybe wildPat (lookup l' [(unqualify l, p) | (l, p) <- fs'])+simplifyPat (TuplePattern            _ ps) =+  ConstructorPattern NoSpanInfo () (qTupleId (length ps))+    `liftM` mapM simplifyPat ps+simplifyPat (ListPattern           _ _ ps) =+  simplifyListPattern `liftM` mapM simplifyPat ps+simplifyPat (AsPattern             _ _ p) = simplifyPat p+simplifyPat (LazyPattern             _ _) = return wildPat+simplifyPat (FunctionPattern     _ _ _ _) = return wildPat+simplifyPat (InfixFuncPattern  _ _ _ _ _) = return wildPat++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 NoSpanInfo () qConsId [p1, p2])+        (ConstructorPattern NoSpanInfo () 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 EqnGuards = [CondExpr ()]+type EqnNo   = Int+type EqnInfo = (EqnNo, EqnPats, EqnGuards)++type ExhaustivePats = (EqnPats, [(Ident, [Literal])])+type OverlappingPats = (EqnNo, EqnPats)+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, gs):eqs')+  | null ps                = if guardsExhaustive then return ([], IntSet.singleton n, length eqs > 1)+                                                 else do -- Current expression is guarded, thus potentially+                                                         -- non-exhaustive. Therefore process remaining expressions.+                                                         (missing', used', _) <- processEqs eqs'+                                                         return (missing', IntSet.insert n used', 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+        guardsExhaustive = null gs || any guardAlwaysTrue gs+        guardAlwaysTrue :: CondExpr () -> Bool+        guardAlwaysTrue (CondExpr _ e _) = case e of+          Constructor _ _ q -> qidAlwaysTrue q+          Variable    _ _ q -> qidAlwaysTrue q+          _ -> False+        qidAlwaysTrue :: QualIdent -> Bool+        qidAlwaysTrue q = elem (idName $ qidIdent q) ["True", "success", "otherwise"]+        ++-- |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 NoSpanInfo () newVar :+                   replicate (length (snd3 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 NoSpanInfo () 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 (snd3 q) - 1) wildPat, [])+  mkPattern  c = ConstructorPattern NoSpanInfo ()+                  (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 NoSpanInfo () c args : rest+  +  removeFirstCon c a (n, p:ps, gs)+    | isVarPat p = (n, replicate a wildPat ++ ps, gs)+    | isCon c  p = (n, patArgs p           ++ ps, gs)+  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 . rootOfType . 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  _ _ _ (ForAll _ (PredType _ ty))] -> return ty+    [NewtypeConstructor _ _ (ForAll _ (PredType _ ty))] -> return ty+    _ -> case qualLookupTypeInfo q tcEnv of+      [AliasType _ _ _ ty] -> return ty+      _ -> internalError $ "Checks.WarnCheck.getConTy: " ++ show q++-- |Retrieve all constructors of a given type.+getTyCons :: QualIdent -> WCM [DataConstr]+getTyCons tc = do+  tc'   <- unAlias tc+  tcEnv <- gets tyConsEnv+  let getTyCons' :: [TypeInfo] -> Either String [DataConstr]+      getTyCons' ti = case ti of+        [DataType     _ _ cs] -> Right cs+        [RenamingType _ _ nc] -> Right $ [nc]+        _                     -> Left $ "Checks.WarnCheck.getTyCons: " ++ show tc ++ ' ' : show ti ++ '\n' : show tcEnv+      csResult = getTyCons' (qualLookupTypeInfo tc tcEnv)+             <|> getTyCons' (qualLookupTypeInfo tc' tcEnv)+             <|> getTyCons' (lookupTypeInfo (unqualify tc) tcEnv) -- Fall back on unqualified lookup if qualified doesn't work+  case csResult of+    Right cs -> return cs+    Left err -> internalError err++-- |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)+  | isQTupleId c                      =+    TuplePattern NoSpanInfo `liftM` mapM tidyPat ps+  | c == qConsId && isFiniteList p    =+    ListPattern NoSpanInfo () `liftM` mapM tidyPat (unwrapFinite p)+  | c == qConsId                      = unwrapInfinite p+  | otherwise                         =+    ConstructorPattern NoSpanInfo () 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 _ a d [p1,p2]) =+    liftM2 (flip (InfixPattern NoSpanInfo a) 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), gs) = (n, ps, gs)++-- |Wildcard pattern.+wildPat :: Pattern ()+wildPat = VariablePattern NoSpanInfo () anonId++-- |Retrieve any literal out of a pattern.+getLit :: Pattern a -> [Literal]+getLit (LiteralPattern _ _ l) = [l]+getLit _                      = []++-- |Retrieve the constructor name and its arity for a pattern.+getCon :: Pattern a -> [(QualIdent, Int)]+getCon (ConstructorPattern _ _ c ps) = [(c, length ps)]+getCon _                             = []++-- |Is a pattern a variable or literal pattern?+isVarLit :: Literal -> Pattern a -> 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 a -> Bool+isVarCon c p = isVarPat p || isCon c p++-- |Is a pattern a pattern matching for the given constructor?+isCon :: QualIdent -> Pattern a -> Bool+isCon c (ConstructorPattern _ _ d _) = c == d+isCon _ _                            = False++-- |Is a pattern a pattern matching for the given literal?+isLit :: Literal -> Pattern a -> Bool+isLit l (LiteralPattern _ _ m) = l == m+isLit _ _                      = False++-- |Is a pattern a literal pattern?+isLitPat :: Pattern a -> Bool+isLitPat (LiteralPattern  _ _ _) = True+isLitPat _                       = False++-- |Is a pattern a variable pattern?+isVarPat :: Pattern a -> Bool+isVarPat (VariablePattern _ _ _) = True+isVarPat _                       = False++-- |Is a pattern a constructor pattern?+isConPat :: Pattern a -> Bool+isConPat (ConstructorPattern _ _ _ _) = True+isConPat _                            = False++-- |Retrieve the arguments of a pattern.+patArgs :: Pattern a -> [Pattern a]+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 :: SpanInfo -> String -> [ExhaustivePats] -> Message+warnMissingPattern spi loc pats = spanInfoMessage spi+  $   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 (pPrintPrec 2) ps)+  ppCons (i, lits) = pPrint i <+> text "`notElem`"+            <+> pPrintPrec 0 (List NoSpanInfo () (map (Literal NoSpanInfo ()) lits))++-- |Warning message for unreachable patterns.+-- To shorten the output only the first 'maxPattern' are printed,+-- additional pattern are abbreviated by dots.+warnUnreachablePattern :: SpanInfo  -> [Pattern a] -> Message+warnUnreachablePattern spi pats = spanInfoMessage spi+  $   text "Pattern matches are potentially unreachable"+  $+$ text "In a case alternative:"+  $+$ nest 2 (ppPat pats <+> text "->" <+> text "...")+  where+  ppPat ps = hsep (map (pPrintPrec 2) ps)++-- |Maximum number of missing patterns to be shown.+maxPattern :: Int+maxPattern = 4++warnNondetOverlapping :: SpanInfo -> String -> Message+warnNondetOverlapping spi loc = spanInfoMessage spi $+  text loc <+> text "is potentially 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 a -> WCM ()+insertDecl (DataDecl      _ d _ cs _) = do+  insertTypeConsId d+  mapM_ insertConstrDecl cs+insertDecl (ExternalDataDecl   _ d _) = insertTypeConsId d+insertDecl (NewtypeDecl   _ d _ nc _) = do+  insertTypeConsId d+  insertNewConstrDecl nc+insertDecl (TypeDecl        _ t _ ty) = do+  insertTypeConsId t+  insertTypeExpr ty+insertDecl (FunctionDecl     _ _ f _) = do+  cons <- isConsId f+  unless cons $ insertVar f+insertDecl (ExternalDecl        _ vs) = mapM_ (insertVar . varIdent) vs+insertDecl (PatternDecl        _ p _) = insertPattern False p+insertDecl (FreeDecl            _ vs) = mapM_ (insertVar . varIdent) vs+insertDecl (ClassDecl _ _ _ cls _ ds) = do+  insertTypeConsId cls+  mapM_ insertVar $ concatMap methods ds+insertDecl _                          = ok++insertTypeExpr :: TypeExpr -> WCM ()+insertTypeExpr (VariableType       _ _) = ok+insertTypeExpr (ConstructorType    _ _) = ok+insertTypeExpr (ApplyType    _ ty1 ty2) = mapM_ insertTypeExpr [ty1,ty2]+insertTypeExpr (TupleType        _ tys) = mapM_ insertTypeExpr tys+insertTypeExpr (ListType          _ ty) = insertTypeExpr ty+insertTypeExpr (ArrowType    _ ty1 ty2) = mapM_ insertTypeExpr [ty1,ty2]+insertTypeExpr (ParenType         _ ty) = insertTypeExpr ty+insertTypeExpr (ForallType      _ _ ty) = insertTypeExpr ty++insertConstrDecl :: ConstrDecl -> WCM ()+insertConstrDecl (ConstrDecl _    c _) = insertConsId c+insertConstrDecl (ConOpDecl  _ _ op _) = insertConsId op+insertConstrDecl (RecordDecl _    c _) = insertConsId c++insertNewConstrDecl :: NewConstrDecl -> WCM ()+insertNewConstrDecl (NewConstrDecl _ c _) = insertConsId c+insertNewConstrDecl (NewRecordDecl _ 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 a -> 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    spi a p1 c p2)+  = insertPattern fp (ConstructorPattern spi a 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 spi a p1 f p2)+  = insertPattern True (FunctionPattern spi a f [p1, p2])+insertPattern _ _ = ok++insertFieldPattern :: Bool -> Field (Pattern a) -> 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)++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++shadowsVar :: Ident -> WCM (Maybe Ident)+shadowsVar v = gets (shadows $ commonId v)++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+++-- --------------------------------------------------------------------------+-- Check Case Mode+-- --------------------------------------------------------------------------+++-- The following functions traverse the AST and search for (defining)+-- identifiers and check if their names have the appropriate case mode.+checkCaseMode :: [Decl a] -> WCM ()+checkCaseMode = warnFor WarnIrregularCaseMode . mapM_ checkCaseModeDecl++checkCaseModeDecl :: Decl a -> WCM ()+checkCaseModeDecl (DataDecl _ tc vs cs _) = do+  checkCaseModeID isDataDeclName tc+  mapM_ (checkCaseModeID isVarName) vs+  mapM_ checkCaseModeConstr cs+checkCaseModeDecl (NewtypeDecl _ tc vs nc _) = do+  checkCaseModeID isDataDeclName tc+  mapM_ (checkCaseModeID isVarName) vs+  checkCaseModeNewConstr nc+checkCaseModeDecl (TypeDecl _ tc vs ty) = do+  checkCaseModeID isDataDeclName tc+  mapM_ (checkCaseModeID isVarName) vs+  checkCaseModeTypeExpr ty+checkCaseModeDecl (TypeSig _ fs qty) = do+  mapM_ (checkCaseModeID isFuncName) fs+  checkCaseModeQualTypeExpr qty+checkCaseModeDecl (FunctionDecl _ _ f eqs) = do+  checkCaseModeID isFuncName f+  mapM_ checkCaseModeEquation eqs+checkCaseModeDecl (ExternalDecl _ vs) =+  mapM_ (checkCaseModeID isFuncName . varIdent) vs+checkCaseModeDecl (PatternDecl _ t rhs) = do+  checkCaseModePattern t+  checkCaseModeRhs rhs+checkCaseModeDecl (FreeDecl  _ vs) =+  mapM_ (checkCaseModeID isVarName . varIdent) vs+checkCaseModeDecl (DefaultDecl _ tys) = mapM_ checkTypeExpr tys+checkCaseModeDecl (ClassDecl _ _ cx cls tv ds) = do+  checkCaseModeContext cx+  checkCaseModeID isClassDeclName cls+  checkCaseModeID isVarName tv+  mapM_ checkCaseModeDecl ds+checkCaseModeDecl (InstanceDecl _ _ cx _ inst ds) = do+  checkCaseModeContext cx+  checkCaseModeTypeExpr inst+  mapM_ checkCaseModeDecl ds+checkCaseModeDecl _ = ok++checkCaseModeConstr :: ConstrDecl -> WCM ()+checkCaseModeConstr (ConstrDecl _ c tys) = do+  checkCaseModeID isConstrName c+  mapM_ checkCaseModeTypeExpr tys+checkCaseModeConstr (ConOpDecl  _ ty1 c ty2) = do+  checkCaseModeTypeExpr ty1+  checkCaseModeID isConstrName c+  checkCaseModeTypeExpr ty2+checkCaseModeConstr (RecordDecl _ c fs) = do+  checkCaseModeID isConstrName c+  mapM_ checkCaseModeFieldDecl fs++checkCaseModeFieldDecl :: FieldDecl -> WCM ()+checkCaseModeFieldDecl (FieldDecl _ fs ty) = do+  mapM_ (checkCaseModeID isFuncName) fs+  checkCaseModeTypeExpr ty++checkCaseModeNewConstr :: NewConstrDecl -> WCM ()+checkCaseModeNewConstr (NewConstrDecl _ nc ty) = do+  checkCaseModeID isConstrName nc+  checkCaseModeTypeExpr ty+checkCaseModeNewConstr (NewRecordDecl _ nc (f, ty)) = do+  checkCaseModeID isConstrName nc+  checkCaseModeID isFuncName f+  checkCaseModeTypeExpr ty++checkCaseModeContext :: Context -> WCM ()+checkCaseModeContext = mapM_ checkCaseModeConstraint++checkCaseModeConstraint :: Constraint -> WCM ()+checkCaseModeConstraint (Constraint _ _ ty) = checkCaseModeTypeExpr ty++checkCaseModeTypeExpr :: TypeExpr -> WCM ()+checkCaseModeTypeExpr (ApplyType _ ty1 ty2) = do+  checkCaseModeTypeExpr ty1+  checkCaseModeTypeExpr ty2+checkCaseModeTypeExpr (VariableType _ tv) = checkCaseModeID isVarName tv+checkCaseModeTypeExpr (TupleType _ tys) = mapM_ checkCaseModeTypeExpr tys+checkCaseModeTypeExpr (ListType _ ty) = checkCaseModeTypeExpr ty+checkCaseModeTypeExpr (ArrowType _ ty1 ty2) = do+  checkCaseModeTypeExpr ty1+  checkCaseModeTypeExpr ty2+checkCaseModeTypeExpr (ParenType _ ty) = checkCaseModeTypeExpr ty+checkCaseModeTypeExpr (ForallType _ tvs ty) = do+  mapM_ (checkCaseModeID isVarName) tvs+  checkCaseModeTypeExpr ty+checkCaseModeTypeExpr _ = ok++checkCaseModeQualTypeExpr :: QualTypeExpr -> WCM ()+checkCaseModeQualTypeExpr (QualTypeExpr _ cx ty) = do+  checkCaseModeContext cx+  checkCaseModeTypeExpr ty++checkCaseModeEquation :: Equation a -> WCM ()+checkCaseModeEquation (Equation _ lhs rhs) = do+  checkCaseModeLhs lhs+  checkCaseModeRhs rhs++checkCaseModeLhs :: Lhs a -> WCM ()+checkCaseModeLhs (FunLhs _ f ts) = do+  checkCaseModeID isFuncName f+  mapM_ checkCaseModePattern ts+checkCaseModeLhs (OpLhs _ t1 f t2) = do+  checkCaseModePattern t1+  checkCaseModeID isFuncName f+  checkCaseModePattern t2+checkCaseModeLhs (ApLhs _ lhs ts) = do+  checkCaseModeLhs lhs+  mapM_ checkCaseModePattern ts++checkCaseModeRhs :: Rhs a -> WCM ()+checkCaseModeRhs (SimpleRhs _ _ e ds) = do+  checkCaseModeExpr e+  mapM_ checkCaseModeDecl ds+checkCaseModeRhs (GuardedRhs _ _ es ds) = do+  mapM_ checkCaseModeCondExpr es+  mapM_ checkCaseModeDecl ds++checkCaseModeCondExpr :: CondExpr a -> WCM ()+checkCaseModeCondExpr (CondExpr _ g e) = do+  checkCaseModeExpr g+  checkCaseModeExpr e++checkCaseModePattern :: Pattern a -> WCM ()+checkCaseModePattern (VariablePattern _ _ v) = checkCaseModeID isVarName v+checkCaseModePattern (ConstructorPattern _ _ _ ts) =+  mapM_ checkCaseModePattern ts+checkCaseModePattern (InfixPattern _ _ t1 _ t2) = do+  checkCaseModePattern t1+  checkCaseModePattern t2+checkCaseModePattern (ParenPattern _ t) = checkCaseModePattern t+checkCaseModePattern (RecordPattern _ _ _ fs) =+  mapM_ checkCaseModeFieldPattern fs+checkCaseModePattern (TuplePattern _ ts) = mapM_ checkCaseModePattern ts+checkCaseModePattern (ListPattern _ _ ts) = mapM_ checkCaseModePattern ts+checkCaseModePattern (AsPattern _ v t) = do+  checkCaseModeID isVarName v+  checkCaseModePattern t+checkCaseModePattern (LazyPattern _ t) = checkCaseModePattern t+checkCaseModePattern (FunctionPattern _ _ _ ts) = mapM_ checkCaseModePattern ts+checkCaseModePattern (InfixFuncPattern _ _ t1 _ t2) = do+  checkCaseModePattern t1+  checkCaseModePattern t2+checkCaseModePattern _ = ok++checkCaseModeExpr :: Expression a -> WCM ()+checkCaseModeExpr (Paren _ e) = checkCaseModeExpr e+checkCaseModeExpr (Typed _ e qty) = do+  checkCaseModeExpr e+  checkCaseModeQualTypeExpr qty+checkCaseModeExpr (Record _ _ _ fs) = mapM_ checkCaseModeFieldExpr fs+checkCaseModeExpr (RecordUpdate _ e fs) = do+  checkCaseModeExpr e+  mapM_ checkCaseModeFieldExpr fs+checkCaseModeExpr (Tuple _ es) = mapM_ checkCaseModeExpr es+checkCaseModeExpr (List _ _ es) = mapM_ checkCaseModeExpr es+checkCaseModeExpr (ListCompr _ e stms)  = do+  checkCaseModeExpr e+  mapM_ checkCaseModeStatement stms+checkCaseModeExpr (EnumFrom _ e) = checkCaseModeExpr e+checkCaseModeExpr (EnumFromThen _ e1 e2) = do+  checkCaseModeExpr e1+  checkCaseModeExpr e2+checkCaseModeExpr (EnumFromTo _ e1 e2) = do+  checkCaseModeExpr e1+  checkCaseModeExpr e2+checkCaseModeExpr (EnumFromThenTo _ e1 e2 e3) = do+  checkCaseModeExpr e1+  checkCaseModeExpr e2+  checkCaseModeExpr e3+checkCaseModeExpr (UnaryMinus _ e) = checkCaseModeExpr e+checkCaseModeExpr (Apply _ e1 e2) = do+  checkCaseModeExpr e1+  checkCaseModeExpr e2+checkCaseModeExpr (InfixApply _ e1 _ e2) = do+  checkCaseModeExpr e1+  checkCaseModeExpr e2+checkCaseModeExpr (LeftSection _ e _) = checkCaseModeExpr e+checkCaseModeExpr (RightSection _ _ e) = checkCaseModeExpr e+checkCaseModeExpr (Lambda _ ts e) = do+  mapM_ checkCaseModePattern ts+  checkCaseModeExpr e+checkCaseModeExpr (Let _ _ ds e) = do+  mapM_ checkCaseModeDecl ds+  checkCaseModeExpr e+checkCaseModeExpr (Do _ _ stms e) = do+  mapM_ checkCaseModeStatement stms+  checkCaseModeExpr e+checkCaseModeExpr (IfThenElse _ e1 e2 e3) = do+  checkCaseModeExpr e1+  checkCaseModeExpr e2+  checkCaseModeExpr e3+checkCaseModeExpr (Case _ _ _ e as) = do+  mapM_ checkCaseModeAlt as+  checkCaseModeExpr e+checkCaseModeExpr _ = ok++checkCaseModeStatement :: Statement a -> WCM ()+checkCaseModeStatement (StmtExpr _    e) = checkCaseModeExpr e+checkCaseModeStatement (StmtDecl _ _ ds) = mapM_ checkCaseModeDecl ds+checkCaseModeStatement (StmtBind _  t e) = do+  checkCaseModePattern t+  checkCaseModeExpr e++checkCaseModeAlt :: Alt a -> WCM ()+checkCaseModeAlt (Alt _ t rhs) = checkCaseModePattern t >> checkCaseModeRhs rhs++checkCaseModeFieldPattern :: Field (Pattern a) -> WCM ()+checkCaseModeFieldPattern (Field _ _ t) = checkCaseModePattern t++checkCaseModeFieldExpr :: Field (Expression a) -> WCM ()+checkCaseModeFieldExpr (Field _ _ e) = checkCaseModeExpr e++checkCaseModeID :: (CaseMode -> String -> Bool) -> Ident -> WCM ()+checkCaseModeID f i@(Ident _ name _) = do+  c <- gets caseMode+  unless (f c name) (report $ warnCaseMode i c)++isVarName :: CaseMode -> String -> Bool+isVarName CaseModeProlog  (x:_) | isAlpha x = isUpper x+isVarName CaseModeGoedel  (x:_) | isAlpha x = isLower x+isVarName CaseModeHaskell (x:_) | isAlpha x = isLower x+isVarName _               _     = True++isFuncName :: CaseMode -> String -> Bool+isFuncName CaseModeHaskell (x:_) | isAlpha x = isLower x+isFuncName CaseModeGoedel  (x:_) | isAlpha x = isUpper x+isFuncName CaseModeProlog  (x:_) | isAlpha x = isLower x+isFuncName _               _     = True++isConstrName :: CaseMode -> String -> Bool+isConstrName = isDataDeclName++isClassDeclName :: CaseMode -> String -> Bool+isClassDeclName = isDataDeclName++isDataDeclName :: CaseMode -> String -> Bool+isDataDeclName CaseModeProlog  (x:_) | isAlpha x = isLower x+isDataDeclName CaseModeGoedel  (x:_) | isAlpha x = isUpper x+isDataDeclName CaseModeHaskell (x:_) | isAlpha x = isUpper x+isDataDeclName _               _     = True++-- ---------------------------------------------------------------------------+-- Warn for redundant context+-- ---------------------------------------------------------------------------++--traverse the AST for QualTypeExpr/Context and check for redundancy+checkRedContext :: [Decl a] -> WCM ()+checkRedContext = warnFor WarnRedundantContext . mapM_ checkRedContextDecl++getRedPredSet :: ModuleIdent -> ClassEnv -> TCEnv -> PredSet -> PredSet+getRedPredSet m cenv tcEnv ps =+  Set.map (pm Map.!) $ Set.difference qps $ minPredSet cenv qps --or fromJust $ Map.lookup+  where (qps, pm) = Set.foldr qualifyAndAddPred (Set.empty, Map.empty) ps+        qualifyAndAddPred p@(Pred qid ty) (ps', pm') =+          let qp = Pred (getOrigName m qid tcEnv) ty+          in (Set.insert qp ps', Map.insert qp p pm')++getPredFromContext :: Context -> ([Ident], PredSet)+getPredFromContext cx =+  let vs = concatMap (\(Constraint _ _ ty) -> typeVariables ty) cx+  in (vs, toPredSet vs cx)++checkRedContext' :: (Pred -> Message) -> PredSet -> WCM ()+checkRedContext' f ps = do+  m     <- gets moduleId+  cenv  <- gets classEnv+  tcEnv <- gets tyConsEnv+  mapM_ (report . f) (getRedPredSet m cenv tcEnv ps)++checkRedContextDecl :: Decl a -> WCM ()+checkRedContextDecl (TypeSig _ ids (QualTypeExpr _ cx _)) =+  checkRedContext' (warnRedContext (warnRedFuncString ids) vs) ps+  where (vs, ps) = getPredFromContext cx+checkRedContextDecl (FunctionDecl _ _ _ eqs) = mapM_ checkRedContextEq eqs+checkRedContextDecl (PatternDecl _ _ rhs) = checkRedContextRhs rhs+checkRedContextDecl (ClassDecl _ _ cx i _ ds) = do+  checkRedContext'+    (warnRedContext (text ("class declaration " ++ escName i)) vs)+    ps+  mapM_ checkRedContextDecl ds+  where (vs, ps) = getPredFromContext cx+checkRedContextDecl (InstanceDecl _ _ cx qid _ ds) = do+  checkRedContext'+    (warnRedContext (text ("instance declaration " ++ escQualName qid)) vs)+    ps+  mapM_ checkRedContextDecl ds+  where (vs, ps) = getPredFromContext cx+checkRedContextDecl _ = return ()++checkRedContextEq :: Equation a -> WCM ()+checkRedContextEq (Equation _ _ rhs) = checkRedContextRhs rhs++checkRedContextRhs :: Rhs a -> WCM ()+checkRedContextRhs (SimpleRhs  _ _ e  ds) = do+  checkRedContextExpr e+  mapM_ checkRedContextDecl ds+checkRedContextRhs (GuardedRhs _ _ cs ds) = do+  mapM_ checkRedContextCond cs+  mapM_ checkRedContextDecl ds++checkRedContextCond :: CondExpr a -> WCM ()+checkRedContextCond (CondExpr _ e1 e2) = do+  checkRedContextExpr e1+  checkRedContextExpr e2++checkRedContextExpr :: Expression a -> WCM ()+checkRedContextExpr (Paren _ e) = checkRedContextExpr e+checkRedContextExpr (Typed _ e (QualTypeExpr _ cx _)) = do+  checkRedContextExpr e+  checkRedContext' (warnRedContext (text "type signature") vs) ps+  where (vs, ps) = getPredFromContext cx+checkRedContextExpr (Record _ _ _ fs) = mapM_ checkRedContextFieldExpr fs+checkRedContextExpr (RecordUpdate _ e fs) = do+  checkRedContextExpr e+  mapM_ checkRedContextFieldExpr fs+checkRedContextExpr (Tuple  _ es) = mapM_ checkRedContextExpr es+checkRedContextExpr (List _ _ es) = mapM_ checkRedContextExpr es+checkRedContextExpr (ListCompr _ e sts) = do+  checkRedContextExpr e+  mapM_ checkRedContextStmt sts+checkRedContextExpr (EnumFrom _ e) = checkRedContextExpr e+checkRedContextExpr (EnumFromThen _ e1 e2) = do+  checkRedContextExpr e1+  checkRedContextExpr e2+checkRedContextExpr (EnumFromTo _ e1 e2) = do+  checkRedContextExpr e1+  checkRedContextExpr e2+checkRedContextExpr (EnumFromThenTo _ e1 e2 e3) = do+  checkRedContextExpr e1+  checkRedContextExpr e2+  checkRedContextExpr e3+checkRedContextExpr (UnaryMinus _ e) = checkRedContextExpr e+checkRedContextExpr (Apply _ e1 e2) = do+  checkRedContextExpr e1+  checkRedContextExpr e2+checkRedContextExpr (InfixApply _ e1 _ e2) = do+  checkRedContextExpr e1+  checkRedContextExpr e2+checkRedContextExpr (LeftSection  _ e _) = checkRedContextExpr e+checkRedContextExpr (RightSection _ _ e) = checkRedContextExpr e+checkRedContextExpr (Lambda _ _ e) = checkRedContextExpr e+checkRedContextExpr (Let _ _ ds e) = do+  mapM_ checkRedContextDecl ds+  checkRedContextExpr e+checkRedContextExpr (IfThenElse _ e1 e2 e3) = do+  checkRedContextExpr e1+  checkRedContextExpr e2+  checkRedContextExpr e3+checkRedContextExpr (Case _ _ _ e as) = do+  checkRedContextExpr e+  mapM_ checkRedContextAlt as+checkRedContextExpr _ = return ()++checkRedContextStmt :: Statement a -> WCM ()+checkRedContextStmt (StmtExpr   _  e) = checkRedContextExpr e+checkRedContextStmt (StmtDecl _ _ ds) = mapM_ checkRedContextDecl ds+checkRedContextStmt (StmtBind _ _  e) = checkRedContextExpr e++checkRedContextAlt :: Alt a -> WCM ()+checkRedContextAlt (Alt _ _ rhs) = checkRedContextRhs rhs++checkRedContextFieldExpr :: Field (Expression a) -> WCM ()+checkRedContextFieldExpr (Field _ _ e) = checkRedContextExpr e++-- ---------------------------------------------------------------------------+-- Warnings messages+-- ---------------------------------------------------------------------------++warnRedFuncString :: [Ident] -> Doc+warnRedFuncString is = text "type signature for function" <>+                       text (if length is == 1 then [] else "s") <+>+                       csep (map (text . escName) is)++-- Doc description -> TypeVars -> Pred -> Warning+warnRedContext :: Doc -> [Ident] -> Pred -> Message+warnRedContext d vs p@(Pred qid _) = spanInfoMessage qid $+  text "Redundant context in" <+> d <> colon <+>+  quotes (pPrint $ fromPred vs p) -- idents use ` ' as quotes not ' '++-- seperate a list by ', '+csep :: [Doc] -> Doc+csep []     = empty+csep [x]    = x+csep (x:xs) = x <> comma <+> csep xs++warnCaseMode :: Ident -> CaseMode -> Message+warnCaseMode i@(Ident _ name _ ) c = spanInfoMessage i $+  text "Wrong case mode in symbol" <+> text (escName i) <+>+  text "due to selected case mode" <+> text (escapeCaseMode c) <> comma <+>+  text "try renaming to" <+> text (caseSuggestion name) <+> text "instead"++caseSuggestion :: String -> String+caseSuggestion (x:xs) | isLower x = toUpper x : xs+                      | isUpper x = toLower x : xs+caseSuggestion _      = internalError+ "Checks.WarnCheck.caseSuggestion: Identifier starts with illegal Symbol"++escapeCaseMode :: CaseMode -> String+escapeCaseMode CaseModeFree    = "`free`"+escapeCaseMode CaseModeHaskell = "`haskell`"+escapeCaseMode CaseModeProlog  = "`prolog`"+escapeCaseMode CaseModeGoedel  = "`goedel`"++warnUnrefTypeVar :: Ident -> Message+warnUnrefTypeVar v = spanInfoMessage v $ hsep $ map text+  [ "Unreferenced type variable", escName v ]++warnUnrefVar :: Ident -> Message+warnUnrefVar v = spanInfoMessage v $ hsep $ map text+  [ "Unused declaration of variable", escName v ]++warnShadowing :: Ident -> Ident -> Message+warnShadowing x v = spanInfoMessage x $+  text "Shadowing symbol" <+> text (escName x)+  <> comma <+> text "bound at:" <+> ppPosition (getPosition v)
+ src/CompilerEnv.hs view
@@ -0,0 +1,117 @@+{- |+    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 (allBindings, allLocalBindings)++import Env.Class+import Env.Instance+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 and type classes+  , classEnv     :: ClassEnv            -- ^ all type classes with their super classes+  , instEnv      :: InstEnv             -- ^ instances+  , 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+  , classEnv     = initClassEnv+  , instEnv      = initInstEnv+  , valueEnv     = initDCEnv+  , opPrecEnv    = initOpPrecEnv+  }++-- |Show the 'CompilerEnv'+showCompilerEnv :: CompilerEnv -> Bool -> Bool -> String+showCompilerEnv env allBinds simpleEnv = 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 simpleEnv $ aliasEnv env+  , header "Precedences        " $ ppAL simpleEnv $ bindings $ opPrecEnv env+  , header "Type Constructors  " $ ppAL simpleEnv $ bindings $ tyConsEnv env+  , header "Classes            " $ ppMap simpleEnv $ classEnv env+  , header "Instances          " $ ppMap simpleEnv $ instEnv env+  , header "Values             " $ ppAL simpleEnv $ bindings $ valueEnv  env+  ]+  where+  header hdr content = hang (text hdr <+> colon) 4 content+  bindings = if allBinds then allBindings else allLocalBindings++-- |Pretty print a 'Map'+ppMap :: (Show a, Pretty a, Show b, Pretty b) => Bool-> Map.Map a b -> Doc+ppMap True  = ppMapPretty+ppMap False = ppMapShow++ppMapShow :: (Show a, Show b) => Map.Map a b -> Doc+ppMapShow = ppALShow . Map.toList++ppMapPretty :: (Pretty a, Pretty b) => Map.Map a b -> Doc+ppMapPretty = ppALPretty . Map.toList++-- |Pretty print an association list+ppAL :: (Show a, Pretty a, Show b, Pretty b) => Bool -> [(a, b)] -> Doc+ppAL True  = ppALPretty+ppAL False = ppALShow++ppALShow :: (Show a, Show b) => [(a, b)] -> Doc+ppALShow 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 ' ')++ppALPretty :: (Pretty a, Pretty b) => [(a, b)] -> Doc+ppALPretty xs = vcat+        $ map (\(a,b) -> text (pad a keyWidth) <+> equals <+> text b) showXs+  where showXs   = map (\(a,b) -> (render (pPrint a), render (pPrint b))) xs+        keyWidth = maximum (0 : map (length .fst) showXs)+        pad s n  = take n (s ++ repeat ' ')+
+ src/CompilerOpts.hs view
@@ -0,0 +1,644 @@+{- |+    Module      :  $Header$+    Description :  Compiler options+    Copyright   :  (c) 2005        Martin Engelke+                       2007        Sebastian Fischer+                       2011 - 2016 Björn Peemöller+                       2016 - 2017 Finn Teegen+                       2018        Kai-Oliver Prott+    License     :  BSD-3-clause++    Maintainer  :  fte@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 (..), CppOpts (..), PrepOpts (..), WarnOpts (..), DebugOpts (..)+  , OptimizationOpts(..), CaseMode (..), 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           Data.Char             (isDigit)+import qualified Data.Map    as Map    (Map, empty, insert)+import System.Console.GetOpt+import System.Environment              (getArgs, getProgName)+import System.FilePath                 ( addTrailingPathSeparator, normalise+                                       , splitSearchPath )++import Curry.Files.Filenames           (defaultOutDir)+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+  , optOutDir        :: FilePath            -- ^ output directory for FlatCurry, ...+  , optHtmlDir       :: Maybe FilePath      -- ^ output directory for HTML+  , optUseOutDir     :: 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+  , optCaseMode      :: CaseMode            -- ^ case mode+  , optCppOpts       :: CppOpts             -- ^ C preprocessor options+  , optOptimizations :: OptimizationOpts -- ^ Optimization options+  } deriving Show++-- |C preprocessor options+data CppOpts = CppOpts+  { cppRun         :: Bool                -- ^ run C preprocessor+  , cppDefinitions :: Map.Map String Int  -- ^ defintions for the C preprocessor+  } deriving Show++-- |Preprocessor options+data PrepOpts = PrepOpts+  { ppPreprocess :: Bool      -- ^ apply custom preprocessor+  , ppCmd        :: String    -- ^ preprocessor command+  , ppOpts       :: [String]  -- ^ preprocessor options+  } deriving Show++data CaseMode+  = CaseModeFree+  | CaseModeHaskell+  | CaseModeProlog+  | CaseModeGoedel+  deriving (Eq, 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+  , dbDumpAllBindings :: Bool        -- ^ dump all bindings instead of just the+                                     --   local bindings+  , dbDumpSimple      :: Bool        -- ^ print more readable environments+  } deriving Show++data OptimizationOpts = OptimizationOpts+  { optDesugarNewtypes     :: Bool -- ^ Desugar newtypes+  , optInlineDictionaries  :: Bool -- ^ Inline type class dictionaries+  , optRemoveUnusedImports :: Bool -- ^ Remove unused imports in IL+  } deriving Show++-- | Default compiler options+defaultOptions :: Options+defaultOptions = Options+  { optMode          = ModeMake+  , optVerbosity     = VerbStatus+  , optForce         = False+  , optLibraryPaths  = []+  , optImportPaths   = []+  , optOutDir        = defaultOutDir+  , optHtmlDir       = Nothing+  , optUseOutDir     = True+  , optInterface     = True+  , optPrepOpts      = defaultPrepOpts+  , optWarnOpts      = defaultWarnOpts+  , optTargetTypes   = []+  , optExtensions    = []+  , optDebugOpts     = defaultDebugOpts+  , optCaseMode      = CaseModeFree+  , optCppOpts       = defaultCppOpts+  , optOptimizations = defaultOptimizationOpts+  }++-- | Default C preprocessor options+defaultCppOpts :: CppOpts+defaultCppOpts = CppOpts+  { cppRun         = False+  , cppDefinitions = Map.empty+  }++-- | 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+  , dbDumpAllBindings = False+  , dbDumpSimple      = False+  }++defaultOptimizationOpts :: OptimizationOpts+defaultOptimizationOpts = OptimizationOpts+  { optDesugarNewtypes     = False+  , optInlineDictionaries  = True+  , optRemoveUnusedImports = True+  }++-- |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+  | Comments             -- ^ Source code comments+  | Parsed               -- ^ Parsed source code+  | FlatCurry            -- ^ FlatCurry+  | AnnotatedFlatCurry   -- ^ Annotated FlatCurry+  | TypedFlatCurry       -- ^ Typed FlatCurry+  | AbstractCurry        -- ^ AbstractCurry+  | UntypedAbstractCurry -- ^ Untyped AbstractCurry+  | Html                 -- ^ HTML documentation+  | AST                  -- ^ Abstract-Syntax-Tree after checks+  | ShortAST             -- ^ Abstract-Syntax-Tree with shortened decls+    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+  | WarnMissingMethods       -- ^ Warn for missing method implementations+  | WarnOrphanInstances      -- ^ Warn for orphan instances+  | WarnIrregularCaseMode    -- ^ Warn for irregular case mode+  | WarnRedundantContext     -- ^ Warn for redundant context in type signatures+    deriving (Eq, Bounded, Enum, Show)++-- |Warning flags enabled by default+stdWarnFlags :: [WarnFlag]+stdWarnFlags =+  [ WarnMultipleImports   , WarnDisjoinedRules   --, WarnUnusedGlobalBindings+  , WarnUnusedBindings    , WarnNameShadowing    , WarnOverlapping+  , WarnIncompletePatterns, WarnMissingSignatures, WarnMissingMethods+  , WarnIrregularCaseMode , WarnRedundantContext+  ]++-- |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"        )+  , ( WarnMissingMethods      , "missing-methods"+    , "missing method implementations" )+  , ( WarnOrphanInstances     , "orphan-instances"+    , "orphan instances"               )+  , ( WarnIrregularCaseMode   , "irregular-case-mode"+    , "irregular case mode")+  , ( WarnRedundantContext    , "redundant-context"+    , "redundant context")+  ]++-- |Dump level+data DumpLevel+  = DumpCondCompiled      -- ^ dump source code after conditional compiling+  | DumpParsed            -- ^ dump source code after parsing+  | DumpExtensionChecked  -- ^ dump source code after extension checking+  | DumpTypeSyntaxChecked -- ^ dump source code after type syntax checking+  | DumpKindChecked       -- ^ dump source code after kind checking+  | DumpSyntaxChecked     -- ^ dump source code after syntax checking+  | DumpPrecChecked       -- ^ dump source code after precedence checking+  | DumpDeriveChecked     -- ^ dump source code after derive checking+  | DumpInstanceChecked   -- ^ dump source code after instance checking+  | DumpTypeChecked       -- ^ dump source code after type checking+  | DumpExportChecked     -- ^ dump source code after export checking+  | DumpQualified         -- ^ dump source code after qualification+  | DumpDerived           -- ^ dump source code after deriving+  | DumpDesugared         -- ^ dump source code after desugaring+  | DumpDictionaries      -- ^ dump source code after dictionary transformation+  | DumpNewtypes          -- ^ dump source code after removing newtype constructors+  | DumpSimplified        -- ^ dump source code after simplification+  | DumpLifted            -- ^ dump source code after lambda-lifting+  | DumpTranslated        -- ^ dump IL code after translation+  | DumpCaseCompleted     -- ^ dump IL code after case completion+  | DumpTypedFlatCurry    -- ^ dump typed FlatCurry code+  | DumpFlatCurry         -- ^ dump FlatCurry code+    deriving (Eq, Bounded, Enum, Show)++-- |Description and flag of dump levels+dumpLevel :: [(DumpLevel, String, String)]+dumpLevel = [ (DumpCondCompiled     , "dump-cond" , "conditional compiling"           )+            , (DumpParsed           , "dump-parse", "parsing"                         )+            , (DumpExtensionChecked , "dump-exc"  , "extension checking"              )+            , (DumpTypeSyntaxChecked, "dump-tsc"  , "type syntax checking"            )+            , (DumpKindChecked      , "dump-kc"   , "kind checking"                   )+            , (DumpSyntaxChecked    , "dump-sc"   , "syntax checking"                 )+            , (DumpPrecChecked      , "dump-pc"   , "precedence checking"             )+            , (DumpDeriveChecked    , "dump-dc"   , "derive checking"                 )+            , (DumpInstanceChecked  , "dump-inc"  , "instance checking"               )+            , (DumpTypeChecked      , "dump-tc"   , "type checking"                   )+            , (DumpExportChecked    , "dump-ec"   , "export checking"                 )+            , (DumpQualified        , "dump-qual" , "qualification"                   )+            , (DumpDerived          , "dump-deriv", "deriving"                        )+            , (DumpDesugared        , "dump-ds"   , "desugaring"                      )+            , (DumpDictionaries     , "dump-dict" , "dictionary insertion"            )+            , (DumpNewtypes         , "dump-new"  , "removing newtype constructors"   )+            , (DumpLifted           , "dump-lift" , "lifting"                         )+            , (DumpSimplified       , "dump-simpl", "simplification"                  )+            , (DumpTranslated       , "dump-trans", "pattern matching compilation"    )+            , (DumpCaseCompleted    , "dump-cc"   , "case completion"                 )+            , (DumpTypedFlatCurry   , "dump-tflat", "translation into typed FlatCurry")+            , (DumpFlatCurry        , "dump-flat" , "translation into FlatCurry"      )+            ]++-- |Description and flag of language extensions+extensions :: [(KnownExtension, String, String)]+extensions =+  [ ( AnonFreeVars             , "AnonFreeVars"+    , "enable anonymous free variables"              )+  , ( CPP                      , "CPP"+    , "run C preprocessor"                           )+  , ( 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)++onCppOpts :: (CppOpts -> CppOpts) -> OptErr -> OptErr+onCppOpts f (opts, errs) = (opts { optCppOpts = f (optCppOpts 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)++onOptimOpts :: (OptimizationOpts -> OptimizationOpts) -> OptErr -> OptErr+onOptimOpts f (opts, errs)+    = (opts { optOptimizations = f (optOptimizations opts) }, errs)++withArg :: ((a -> b) -> OptErr -> OptErr)+        -> (String -> a -> b) -> 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 "o"  ["outdir"]+      (ReqArg (withArg onOpts $ \ arg opts -> opts { optOutDir = arg }) "dir")+      "write compilation artifacts (FlatCurry, ...) into directory `dir'"+  , Option []   ["htmldir"]+      (ReqArg (withArg onOpts $ \ arg opts -> opts { optHtmlDir =+        Just arg }) "dir")+      "write HTML documentation into directory `dir'"+  , Option ""   ["no-outdir", "no-subdir"]+      (NoArg (onOpts $ \ opts -> opts { optUseOutDir = False }))+      ("disable writing to `" ++ defaultOutDir ++ "' 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 Comments               "comments"+      "generate comments stream"+  , targetOption Parsed                 "parse-only"+      "generate source representation"+  , targetOption FlatCurry              "flat"+      "generate FlatCurry code"+  , targetOption TypedFlatCurry         "typed-flat"+      "generate typed FlatCurry code"+  , targetOption AnnotatedFlatCurry     "type-annotated-flat"+      "generate type-annotated FlatCurry code"+  , targetOption AbstractCurry          "acy"+      "generate typed AbstractCurry"+  , targetOption UntypedAbstractCurry   "uacy"+      "generate untyped AbstractCurry"+  , targetOption Html                   "html"+      "generate html documentation"+  , targetOption AST                    "ast"+      "generate abstract syntax tree"+  , targetOption ShortAST               "short-ast"+      "generate shortened abstract syntax tree for 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 <cmd>"+  , Option ""   ["optF"]+      (ReqArg (withArg onPrepOpts $ \ arg opts ->+        opts { ppOpts = ppOpts opts ++ [arg]}) "option")+      "execute preprocessor with option <option>"+  -- extensions+  , Option "e"  ["extended"]+      (NoArg (onOpts $ \ opts -> opts { optExtensions =+        nub $ kielExtensions ++ optExtensions opts }))+      "enable extended Curry functionalities"+  , mkOptDescr onOpts      "c" ["case-mode"] "mode" "case mode"           caseModeDescriptions+  , mkOptDescr onOpts      "X" []            "ext"  "language extension"  extDescriptions+  , mkOptDescr onWarnOpts  "W" []            "opt"  "warning option"      warnDescriptions+  , mkOptDescr onDebugOpts "d" []            "opt"  "debug option"        debugDescriptions+  , mkOptDescr onOptimOpts "O" []            "opt"  "optimization option" optimizeDescriptions+  , Option ""   ["cpp"]+      (NoArg (onCppOpts $ \ opts -> opts { cppRun = True }))+      "run C preprocessor"+  , Option "D"  []+      (ReqArg (withArg ($) parseCppDefinition) "s=v")+      "define symbol `s` with value `v` for the C preprocessor"+  ]++parseCppDefinition :: String -> OptErr -> OptErr+parseCppDefinition arg optErr+  | not (null s) && not (null v) && all isDigit v+  = onCppOpts (addCppDefinition s v) optErr+  | otherwise+  = addErr (cppDefinitionErr arg) optErr+  where (s, v) = drop 1 <$> break ('=' ==) arg++addCppDefinition :: String -> String -> CppOpts -> CppOpts+addCppDefinition s v opts =+  opts { cppDefinitions = Map.insert s (read v) (cppDefinitions opts) }++cppDefinitionErr :: String -> String+cppDefinitionErr = (++) "Invalid format for option '-D': "++targetOption :: TargetType -> String -> String -> OptDescr (OptErr -> OptErr)+targetOption ty flag+  = Option "" [flag] (NoArg (onOpts $ \ opts -> opts { optTargetTypes =+      nub $ ty : optTargetTypes opts }))++verbDescriptions :: OptErrTable Options+verbDescriptions = map toDescr verbosities+  where+  toDescr (flag, name, desc)+    = (name, desc, \ opts -> opts { optVerbosity = flag })++extDescriptions :: OptErrTable Options+extDescriptions = map toDescr extensions+  where+  toDescr (flag, name, desc)+    = (name, desc,+        \opts -> let cppOpts = optCppOpts opts+                 in opts { optCppOpts    =+                             cppOpts { cppRun = cppRun cppOpts || flag == CPP }+                         , optExtensions = addFlag flag (optExtensions opts)+                         })+++caseModeDescriptions :: OptErrTable Options+caseModeDescriptions+  = [ ( "free"   , "use free case mode"+        , \ opts -> opts { optCaseMode = CaseModeFree    } )+    , ( "haskell", "use haskell style case mode"+        , \ opts -> opts { optCaseMode = CaseModeHaskell } )+    , ( "prolog" , "use prolog style case mode"+        , \ opts -> opts { optCaseMode = CaseModeProlog  } )+    , ( "goedel"  , "use goedel case mode"+        , \ opts -> opts { optCaseMode = CaseModeGoedel  } )+    ]++warnDescriptions :: OptErrTable WarnOpts+warnDescriptions+  = [ ( "all"  , "turn on all warnings"+        , \ opts -> opts { wnWarnFlags = [minBound .. maxBound] } )+    , ("none" , "turn off all warnings"+        , \ opts -> opts { wnWarnFlags = []                     } )+    , ("error", "treat warnings as errors"+        , \ opts -> opts { wnWarnAsError = True                 } )+    ] ++ map turnOn warnFlags ++ map turnOff warnFlags+  where+  turnOn (flag, name, desc)+    = (name, "warn for " ++ desc+      , \ opts -> opts { wnWarnFlags = addFlag flag (wnWarnFlags opts)})+  turnOff (flag, name, desc)+    = ("no-" ++ name, "do not warn for " ++ desc+      , \ opts -> opts { wnWarnFlags = removeFlag flag (wnWarnFlags opts)})++debugDescriptions :: OptErrTable DebugOpts+debugDescriptions =+  [ ( "dump-all"          , "dump everything"+    , \ opts -> opts { dbDumpLevels = [minBound .. maxBound]    })+  , ( "dump-none"         , "dump nothing"+    , \ opts -> opts { dbDumpLevels = []                        })+  , ( "dump-env"          , "additionally dump compiler environment"+    , \ opts -> opts { dbDumpEnv = True                         })+  , ( "dump-raw"          , "dump as raw AST (instead of pretty printing)"+    , \ opts -> opts { dbDumpRaw = True                         })+  , ( "dump-all-bindings" , "when dumping bindings, dump all instead of just local ones"+    , \ opts -> opts { dbDumpAllBindings = True                 })+  , ( "dump-simple" , "print a simplified, more readable environment"+    , \ opts -> opts { dbDumpSimple = True                      })++  ] ++ map toDescr dumpLevel+  where+  toDescr (flag, name, desc)+    = (name , "dump code after " ++ desc+        , \ opts -> opts { dbDumpLevels = addFlag flag (dbDumpLevels opts)})++optimizeDescriptions :: OptErrTable OptimizationOpts+optimizeDescriptions =+  [ ( "desugar-newtypes"        , "desugars newtypes in FlatCurry"+    , \ opts -> opts { optDesugarNewtypes     = True    })+  , ( "inline-dictionaries"     , "inlines type class dictionaries"+    , \ opts -> opts { optInlineDictionaries  = True    })+  , ( "remove-unused-imports"   , "removes unused imports"+    , \ opts -> opts { optRemoveUnusedImports = True    })+  , ( "no-desugar-newtypes"     , "prevents desugaring of newtypes in FlatCurry"+    , \ opts -> opts { optDesugarNewtypes     = False   })+  , ( "no-inline-dictionaries"  , "prevents inlining of type class dictionaries"+    , \ opts -> opts { optInlineDictionaries  = False   })+  , ( "no-remove-unused-imports", "prevents removing of unused imports"+    , \ opts -> opts { optRemoveUnusedImports = False   })+  ]++addFlag :: Eq a => a -> [a] -> [a]+addFlag o opts = nub $ o : opts++removeFlag :: Eq a => a -> [a] -> [a]+removeFlag o = filter (/= o)++-- |Update the 'Options' record by the parsed and processed arguments+updateOpts :: Options -> [String] -> (Options, [String], [String])+updateOpts opts args = (opts', files, errs ++ errs2 ++ checkOpts opts files)+  where+  (opts', errs2) = foldl (flip ($)) (opts, []) optErrs+  (optErrs, files, errs) = getOpt Permute options args++-- |Parse the command line arguments+parseOpts :: [String] -> (Options, [String], [String])+parseOpts = updateOpts defaultOptions++-- |Check options and files and return a list of error messages+checkOpts :: Options -> [String] -> [String]+checkOpts opts _+  = [ "The option '--htmldir' is only valid for HTML generation mode"+    | isJust (optHtmlDir opts) && Html `notElem` optTargetTypes opts ]++-- |Print the usage information of the command line tool.+usage :: String -> String+usage prog = usageInfo header options+  where header = "usage: " ++ prog ++ " [OPTION] ... MODULES ..."++-- |Retrieve the compiler 'Options'+getCompilerOpts :: IO (String, Options, [String], [String])+getCompilerOpts = do+  args <- getArgs+  prog <- getProgName+  let (opts, files, errs) = parseOpts args+  return (prog, opts, files, errs)
+ src/CondCompile.hs view
@@ -0,0 +1,26 @@+{- |+    Module      :  $Header$+    Description :  Conditional compilation+    Copyright   :  (c)        2017 Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  fte@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    TODO+-}++module CondCompile (condCompile) where++import Curry.Base.Monad+import Curry.CondCompile.Transform (condTransform)++import CompilerOpts (CppOpts (..))++condCompile :: CppOpts -> FilePath -> String -> CYIO String+condCompile opts fn p+  | not (cppRun opts) = return p+  | otherwise         = either (failMessages . (: []))+                               ok+                               (condTransform (cppDefinitions opts) fn p)
+ src/Curry/AbstractCurry.hs view
@@ -0,0 +1,30 @@+{- |+    Module      :  $Header$+    Description :  Library to support meta-programming in Curry+    Copyright   :  Michael Hanus  , 2004+                   Martin Engelke , 2005+                   Björn Peemöller, 2013+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This library contains a definition for representing Curry programs+    in Haskell by the type 'CurryProg' and I/O actions to read Curry programs+    and transform them into this abstract representation as well as+    write them to a file.++    Note that this defines a slightly new format for AbstractCurry+    in comparison to the first proposal of 2003.++    /Assumption:/ An AbstractCurry program @Prog@ is stored in a file with+    the file extension @acy@, i.e. in a file @Prog.acy@.+-}+module Curry.AbstractCurry+  ( module Curry.AbstractCurry.Type+  , module Curry.AbstractCurry.Files+  ) where++import Curry.AbstractCurry.Type+import Curry.AbstractCurry.Files
+ src/Curry/AbstractCurry/Files.hs view
@@ -0,0 +1,61 @@+{- |+    Module      :  $Header$+    Description :  Library to support meta-programming in Curry+    Copyright   :  (c) Michael Hanus  , 2004+                       Martin Engelke , 2005+                       Björn Peemöller, 2014+                       Finn Teegen    , 2016+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This library contains I/O actions to read Curry programs+    and transform them into this abstract representation as well as+    write them to a file.+-}+module Curry.AbstractCurry.Files+  ( readCurry, writeCurry, showCurry+  ) where++import qualified Control.Exception        as C (catch)+import           Data.List                     (intercalate)++import           Curry.Files.PathUtils         ( writeModule, readModule+                                               , addVersion, checkVersion)++import           Curry.AbstractCurry.Type++-- ---------------------------------------------------------------------------+-- Reading and writing AbstractCurry terms+-- ---------------------------------------------------------------------------++-- |Read an AbstractCurry file and return the corresponding AbstractCurry+--  program term of type 'CurryProg'+readCurry :: FilePath -> IO (Maybe CurryProg)+readCurry fn = do+  mbSrc <- readModule fn+  return $ case mbSrc of+    Nothing  -> Nothing+    Just src -> case checkVersion version src of+      Left  _  -> Nothing+      Right ac -> Just (read ac)++-- |Write an AbstractCurry program term into a file.+writeCurry :: FilePath -> CurryProg -> IO ()+writeCurry fn p = C.catch (writeModule fn $ addVersion version $ showCurry p)+                  ioError++-- |Show an AbstractCurry program in a nicer way+showCurry :: CurryProg -> String+showCurry (CurryProg mname imps dflt clss insts types funcs ops)+  =  "CurryProg " ++ show mname ++ "\n"+  ++ show imps ++ "\n"+  ++ showsPrec 11 dflt "\n"+  ++ wrapList clss+  ++ wrapList insts+  ++ wrapList types+  ++ wrapList funcs+  ++ wrapList ops+  where wrapList xs = " [" ++ intercalate ",\n  " (map show xs) ++ "]\n"
+ src/Curry/AbstractCurry/Type.hs view
@@ -0,0 +1,329 @@+{- |+    Module      :  $Header$+    Description :  Library to support meta-programming in Curry+    Copyright   :  Michael Hanus  , 2004+                   Martin Engelke , 2005+                   Björn Peemöller, 2015+                   Finn Teegen    , 2016+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This library contains a definition for representing Curry programs+    in Haskell by the type 'CurryProg' and I/O actions to read Curry programs+    and transform them into this abstract representation as well as+    write them to a file.++    Note that this defines a slightly new format for AbstractCurry+    in comparison to the first proposal of 2003.+-}+module Curry.AbstractCurry.Type+  ( CurryProg (..), MName, QName, CVisibility (..), CTVarIName+  , CDefaultDecl (..), CClassDecl (..), CInstanceDecl (..)+  , CTypeDecl (..), CConsDecl (..), CFieldDecl (..)+  , CConstraint, CContext (..), CTypeExpr (..), CQualTypeExpr (..)+  , COpDecl (..), CFixity (..), Arity, CFuncDecl (..), CRhs (..), CRule (..)+  , CLocalDecl (..), CVarIName, CExpr (..), CCaseType (..), CStatement (..)+  , CPattern (..), CLiteral (..), CField, version+  ) where++-- ---------------------------------------------------------------------------+-- Abstract syntax+-- ---------------------------------------------------------------------------++-- |Current version of AbstractCurry+version :: String+version = "AbstractCurry 3.0"++-- |A module name.+type MName = String++-- |A qualified name.+-- In AbstractCurry all names are qualified to avoid name clashes.+-- The first component is the module name and the second component the+-- unqualified name as it occurs in the source program.+type QName = (MName, String)++-- |Data type to specify the visibility of various entities.+data CVisibility+  = Public    -- ^ exported entity+  | Private   -- ^ private entity+    deriving (Eq, Read, Show)++-- |A Curry module in the intermediate form. A value of this type has the form+-- @+-- CurryProg modname imports dfltdecl clsdecls instdecls typedecls funcdecls opdecls+-- @+-- where+-- [@modname@]   Name of this module+-- [@imports@]   List of modules names that are imported+-- [@dfltdecl@]  Optional default declaration+-- [@clsdecls@]  Class declarations+-- [@instdecls@] Instance declarations+-- [@typedecls@] Type declarations+-- [@funcdecls@] Function declarations+-- [@opdecls@]   Operator precedence declarations+data CurryProg = CurryProg MName [MName] (Maybe CDefaultDecl) [CClassDecl]+                           [CInstanceDecl] [CTypeDecl] [CFuncDecl] [COpDecl]+    deriving (Eq, Read, Show)++-- |Default declaration.+data CDefaultDecl = CDefaultDecl [CTypeExpr]+    deriving (Eq, Read, Show)++-- |Definitions of type classes.+-- A type class definition of the form+-- @+-- class cx => c a where { ...;f :: t;... }+-- @+-- is represented by the Curry term+-- @+-- (CClass c v cx tv [...(CFunc f ar v t [...,CRule r,...])...])+-- @+-- where @tv@ is the index of the type variable @a@ and @v@ is the+-- visibility of the type class resp. method.+-- /Note:/ The type variable indices are unique inside each class+--         declaration and are usually numbered from 0.+--         The methods' types share the type class' type variable index+--         as the class variable has to occur in a method's type signature.+--         The list of rules for a method's declaration may be empty if+--         no default implementation is provided. The arity @ar@ is+--         determined by a given default implementation or 0.+--         Regardless of whether typed or untyped abstract curry is generated,+--         the methods' declarations are always typed.+data CClassDecl = CClass QName CVisibility CContext CTVarIName [CFuncDecl]+    deriving (Eq, Read, Show)++-- |Definitions of instances.+-- An instance definition of the form+-- @+-- instance cx => c ty where { ...;fundecl;... }+-- @+-- is represented by the Curry term+-- @+-- (CInstance c cx ty [...fundecl...])+-- @+-- /Note:/ The type variable indices are unique inside each instance+--         declaration and are usually numbered from 0.+--         The methods' types use the instance's type variable indices+--         (if typed abstract curry is generated).+data CInstanceDecl = CInstance QName CContext CTypeExpr [CFuncDecl]+    deriving (Eq, Read, Show)++-- |Definitions of algebraic data types and type synonyms.+-- A data type definition of the form+-- @+-- data t x1...xn = ...| forall y1...ym . cx => c t1....tkc |...+--   deriving (d1,...,dp)+-- @+-- is represented by the Curry term+-- @+-- (CType t v [i1,...,in] [...(CCons [l1,...,lm] cx c kc v [t1,...,tkc])...]+--        [d1,...,dp])+-- @+-- where each @ij@ is the index of the type variable @xj@, each @lj@ is the+-- index of the existentially quantified type variable @yj@ and @v@ is the+-- visibility of the type resp. constructor.+-- /Note:/ The type variable indices are unique inside each type declaration+--         and are usually numbered from 0.+-- Thus, a data type declaration consists of the name of the data type,+-- a list of type parameters and a list of constructor declarations.+data CTypeDecl+    -- |algebraic data type+  = CType    QName CVisibility [CTVarIName] [CConsDecl] [QName]+    -- |type synonym+  | CTypeSyn QName CVisibility [CTVarIName] CTypeExpr+    -- |renaming type, may have only exactly one type expression+    -- in the constructor declaration and no existentially type variables and+    -- no context+  | CNewType QName CVisibility [CTVarIName] CConsDecl [QName]+    deriving (Eq, Read, Show)++-- |The type for representing type variables.+-- They are represented by @(i,n)@ where @i@ is a type variable index+-- which is unique inside a function and @n@ is a name (if possible,+-- the name written in the source program).+type CTVarIName = (Int, String)++-- |A constructor declaration consists of the name of the constructor+-- and a list of the argument types of the constructor.+-- The arity equals the number of types.+data CConsDecl+  = CCons   QName CVisibility [CTypeExpr]+  | CRecord QName CVisibility [CFieldDecl]+    deriving (Eq, Read, Show)++-- |A record field declaration consists of the name of the+-- the label, the visibility and its corresponding type.+data CFieldDecl = CField QName CVisibility CTypeExpr+  deriving (Eq, Read, Show)++-- |The type for representing a class constraint.+type CConstraint = (QName, CTypeExpr)++-- |The type for representing a context.+data CContext = CContext [CConstraint]+  deriving (Eq, Read, Show)++-- |Type expression.+-- A type expression is either a type variable, a function type,+-- a type constructor or a type application.+data CTypeExpr+    -- |Type variable+  = CTVar CTVarIName+    -- |Function type @t1 -> t2@+  | CFuncType CTypeExpr CTypeExpr+    -- |Type constructor+  | CTCons QName+    -- |Type application+  | CTApply CTypeExpr CTypeExpr+    deriving (Eq, Read, Show)++-- |Qualified type expression.+data CQualTypeExpr = CQualType CContext CTypeExpr+    deriving (Eq, Read, Show)++-- |Labeled record fields+type CField a = (QName, a)++-- |Operator precedence declaration.+-- An operator precedence declaration @fix p n@ in Curry corresponds to the+-- AbstractCurry term @(COp n fix p)@.+data COpDecl = COp QName CFixity Int+    deriving (Eq, Read, Show)++-- |Fixity declarations of infix operators+data CFixity+  = CInfixOp  -- ^ non-associative infix operator+  | CInfixlOp -- ^ left-associative infix operator+  | CInfixrOp -- ^ right-associative infix operator+    deriving (Eq, Read, Show)++-- |Function arity+type Arity = Int++-- |Data type for representing function declarations.+-- A function declaration in FlatCurry is a term of the form+-- @+-- (CFunc name arity visibility type (CRules eval [CRule rule1,...,rulek]))+-- @+-- and represents the function @name@ with definition+-- @+-- name :: type+-- rule1+-- ...+-- rulek+-- @+-- /Note:/ The variable indices are unique inside each rule.+-- External functions are represented as+-- @+-- (CFunc name arity type (CExternal s))+-- @+-- where s is the external name associated to this function.+-- Thus, a function declaration consists of the name, arity, type, and+-- a list of rules.+-- If the list of rules is empty, the function is considered+-- to be externally defined.+data CFuncDecl = CFunc QName Arity CVisibility CQualTypeExpr [CRule]+    deriving (Eq, Read, Show)++-- |The general form of a function rule. It consists of a list of patterns+-- (left-hand side), a list of guards (@success@ if not present in the+-- source text) with their corresponding right-hand sides, and+-- a list of local declarations.+data CRule = CRule [CPattern] CRhs+    deriving (Eq, Read, Show)++-- |Right-hand-side of a 'CRule' or an @case@ expression+data CRhs+  = CSimpleRhs  CExpr            [CLocalDecl] -- @expr where decls@+  | CGuardedRhs [(CExpr, CExpr)] [CLocalDecl] -- @| cond = expr where decls@+    deriving (Eq, Read, Show)++-- | Local (let/where) declarations+data CLocalDecl+  = CLocalFunc CFuncDecl     -- ^ local function declaration+  | CLocalPat  CPattern CRhs -- ^ local pattern declaration+  | CLocalVars [CVarIName]   -- ^ local free variable declarations+    deriving (Eq, Read, Show)++-- |Variable names.+-- Object variables occurring in expressions are represented by @(Var i)@+-- where @i@ is a variable index.+type CVarIName = (Int, String)++-- |Pattern expressions.+data CPattern+    -- |pattern variable (unique index / name)+  = CPVar CVarIName+    -- |literal (Integer/Float/Char constant)+  | CPLit CLiteral+    -- |application @(m.c e1 ... en)@ of n-ary constructor @m.c@+    --  (@CPComb (m,c) [e1,...,en]@)+  | CPComb QName [CPattern]+    -- |as-pattern (extended Curry)+  | CPAs CVarIName CPattern+    -- |functional pattern (extended Curry)+  | CPFuncComb QName [CPattern]+    -- |lazy pattern (extended Curry)+  | CPLazy CPattern+    -- |record pattern (extended curry)+  | CPRecord QName [CField CPattern]+    deriving (Eq, Read, Show)++-- | Curry expressions.+data CExpr+    -- |variable (unique index / name)+  = CVar       CVarIName+    -- |literal (Integer/Float/Char/String constant)+  | CLit       CLiteral+    -- |a defined symbol with module and name, i.e., a function or a constructor+  | CSymbol    QName+    -- |application (e1 e2)+  | CApply     CExpr CExpr+    -- |lambda abstraction+  | CLambda    [CPattern] CExpr+    -- |local let declarations+  | CLetDecl   [CLocalDecl] CExpr+    -- |do block+  | CDoExpr    [CStatement]+    -- |list comprehension+  | CListComp  CExpr [CStatement]+    -- |case expression+  | CCase      CCaseType CExpr [(CPattern, CRhs)]+    -- |typed expression+  | CTyped     CExpr CQualTypeExpr+    -- |record construction (extended Curry)+  | CRecConstr QName [CField CExpr]+    -- |record update (extended Curry)+  | CRecUpdate CExpr [CField CExpr]+    deriving (Eq, Read, Show)++-- |Literals occurring in an expression or a pattern,+-- either an integer, a float, a character, or a string constant.+-- /Note:/ The constructor definition of 'CIntc' differs from the original+-- PAKCS definition. It uses Haskell type 'Integer' instead of 'Int'+-- to provide an unlimited range of integer numbers. Furthermore,+-- float values are represented with Haskell type 'Double' instead of+-- 'Float' to gain double precision.+data CLiteral+  = CIntc    Integer -- ^ Int literal+  | CFloatc  Double  -- ^ Float literal+  | CCharc   Char    -- ^ Char literal+  | CStringc String  -- ^ String literal+    deriving (Eq, Read, Show)++-- |Statements in do expressions and list comprehensions.+data CStatement+  = CSExpr CExpr          -- ^ an expression (I/O action or boolean)+  | CSPat  CPattern CExpr -- ^ a pattern definition+  | CSLet  [CLocalDecl]   -- ^ a local let declaration+    deriving (Eq, Read, Show)++-- |Type of case expressions+data CCaseType+  = CRigid -- ^ rigid case expression+  | CFlex  -- ^ flexible case expression+    deriving (Eq, Read, Show)
+ src/Curry/Base/Ident.hs view
@@ -0,0 +1,1036 @@+{- |+    Module      :  $Header$+    Description :  Identifiers+    Copyright   :  (c) 1999 - 2004, Wolfgang Lux+                       2011 - 2013, Björn Peemöller+                       2016       , Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module provides the implementation of identifiers and some+    utility functions for identifiers.++    Identifiers comprise the name of the denoted entity and an /id/,+    which can be used for renaming identifiers, e.g., in order to resolve+    name conflicts between identifiers from different scopes. An+    identifier with an /id/ @0@ is considered as not being renamed+    and, hence, its /id/ will not be shown.++    Qualified identifiers may optionally be prefixed by a module name.+-}+{-# LANGUAGE CPP #-}+module Curry.Base.Ident+  ( -- * Module identifiers+    ModuleIdent (..), mkMIdent, moduleName, escModuleName+  , fromModuleName, isValidModuleName, addPositionModuleIdent, mIdentLength++    -- * Local identifiers+  , Ident (..), mkIdent, showIdent, escName, identSupply+  , globalScope, hasGlobalScope, isRenamed, renameIdent, unRenameIdent+  , updIdentName, addPositionIdent, isInfixOp, identLength++    -- * Qualified identifiers+  , QualIdent (..), qualName, escQualName, isQInfixOp, qualify+  , qualifyWith, qualQualify, qualifyLike, isQualified, unqualify, qualUnqualify+  , localIdent, isLocalIdent, updQualIdent, qIdentLength++    -- * Predefined simple identifiers+    -- ** Identifiers for modules+  , emptyMIdent, mainMIdent, preludeMIdent+    -- ** Identifiers for types+  , arrowId, unitId, boolId, charId, intId, floatId, listId, ioId, successId+    -- ** Identifiers for type classes+  , eqId, ordId, enumId, boundedId, readId, showId+  , numId, fractionalId+  , monadId, monadFailId+  , dataId+    -- ** Identifiers for constructors+  , trueId, falseId, nilId, consId, tupleId, isTupleId, tupleArity+    -- ** Identifiers for values+  , mainId, minusId, fminusId, applyId, errorId, failedId, idId+  , succId, predId, toEnumId, fromEnumId, enumFromId, enumFromThenId+  , enumFromToId, enumFromThenToId+  , maxBoundId, minBoundId+  , lexId, readsPrecId, readParenId+  , showsPrecId, showParenId, showStringId+  , andOpId, eqOpId, leqOpId, ltOpId, orOpId, appendOpId, dotOpId+  , aValueId, dataEqId+  , anonId, isAnonId++    -- * Predefined qualified identifiers+    -- ** Identifiers for types+  , qArrowId, qUnitId, qBoolId, qCharId, qIntId, qFloatId, qListId, qIOId+  , qSuccessId, isPrimTypeId+    -- ** Identifiers for type classes+  , qEqId, qOrdId, qEnumId, qBoundedId, qReadId, qShowId+  , qNumId, qFractionalId+  , qMonadId, qMonadFailId+  , qDataId+    -- ** Identifiers for constructors+  , qTrueId, qFalseId, qNilId, qConsId, qTupleId, isQTupleId, qTupleArity+    -- ** Identifiers for values+  , qApplyId, qErrorId, qFailedId, qIdId+  , qFromEnumId, qEnumFromId, qEnumFromThenId, qEnumFromToId, qEnumFromThenToId+  , qMaxBoundId, qMinBoundId+  , qLexId, qReadsPrecId, qReadParenId+  , qShowsPrecId, qShowParenId, qShowStringId+  , qAndOpId, qEqOpId, qLeqOpId, qLtOpId, qOrOpId, qAppendOpId, qDotOpId+  , qAValueId, qDataEqId++    -- * Extended functionality+    -- ** Functional patterns+  , fpSelectorId, isFpSelectorId, isQualFpSelectorId+    -- ** Records+  , recSelectorId, qualRecSelectorId, recUpdateId, qualRecUpdateId+  , recordExt, recordExtId, isRecordExtId, fromRecordExtId+  , labelExt, labelExtId, isLabelExtId, fromLabelExtId+  , renameLabel, mkLabelIdent+  ) where++import Prelude hiding ((<>))+import Data.Char           (isAlpha, isAlphaNum)+import Data.Function       (on)+import Data.List           (intercalate, isInfixOf, isPrefixOf)+import Data.Maybe          (isJust, fromMaybe)+import Data.Binary+import Control.Monad++import Curry.Base.Position+import Curry.Base.Span hiding (file)+import Curry.Base.SpanInfo+import Curry.Base.Pretty++-- ---------------------------------------------------------------------------+-- Module identifier+-- ---------------------------------------------------------------------------++-- | Module identifier+data ModuleIdent = ModuleIdent+  { midSpanInfo   :: SpanInfo -- ^ source code 'SpanInfo'+  , midQualifiers :: [String] -- ^ hierarchical idenfiers+  } deriving (Read, Show)++instance Eq ModuleIdent where+  (==) = (==) `on` midQualifiers++instance Ord ModuleIdent where+  compare = compare `on` midQualifiers++instance HasSpanInfo ModuleIdent where+  getSpanInfo = midSpanInfo+  setSpanInfo spi a = a { midSpanInfo = spi }+  updateEndPos i =+    setEndPosition (incr (getPosition i) (mIdentLength i - 1)) i++instance HasPosition ModuleIdent where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance Pretty ModuleIdent where+  pPrint = hcat . punctuate dot . map text . midQualifiers++instance Binary ModuleIdent where+  put (ModuleIdent sp qs) = put sp >> put qs+  get = liftM2 ModuleIdent get get++mIdentLength :: ModuleIdent -> Int+mIdentLength a = length (concat (midQualifiers a))+               + length (midQualifiers a)++-- |Construct a 'ModuleIdent' from a list of 'String's forming the+--  the hierarchical module name.+mkMIdent :: [String] -> ModuleIdent+mkMIdent = ModuleIdent NoSpanInfo++-- |Retrieve the hierarchical name of a module+moduleName :: ModuleIdent -> String+moduleName = intercalate "." . midQualifiers++-- |Show the name of an 'ModuleIdent' escaped by ticks+escModuleName :: ModuleIdent -> String+escModuleName m = '`' : moduleName m ++ "'"++-- |Add a source code 'Position' to a 'ModuleIdent'+addPositionModuleIdent :: Position -> ModuleIdent -> ModuleIdent+addPositionModuleIdent = setPosition++-- |Check whether a 'String' is a valid module name.+--+-- Valid module names must satisfy the following conditions:+--+--  * The name must not be empty+--  * The name must consist of one or more single identifiers,+--    seperated by dots+--  * Each single identifier must be non-empty, start with a letter and+--    consist of letter, digits, single quotes or underscores only+isValidModuleName :: String -> Bool+isValidModuleName [] = False -- Module names may not be empty+isValidModuleName qs = all isModuleIdentifier $ splitIdentifiers qs+  where+  -- components of a module identifier may not be null+  isModuleIdentifier []     = False+  -- components of a module identifier must start with a letter and consist+  -- of letter, digits, underscores or single quotes+  isModuleIdentifier (c:cs) = isAlpha c && all isIdent cs+  isIdent c                 = isAlphaNum c || c `elem` "'_"++-- |Resemble the hierarchical module name from a 'String' by splitting+-- the 'String' at inner dots.+--+-- /Note:/ This function does not check the 'String' to be a valid module+-- identifier, use isValidModuleName for this purpose.+fromModuleName :: String -> ModuleIdent+fromModuleName = mkMIdent . splitIdentifiers++-- Auxiliary function to split a hierarchical module identifier at the dots+splitIdentifiers :: String -> [String]+splitIdentifiers s = let (pref, rest) = break (== '.') s in+  pref : case rest of+    []     -> []+    (_:s') -> splitIdentifiers s'++-- ---------------------------------------------------------------------------+-- Simple identifier+-- ---------------------------------------------------------------------------++-- |Simple identifier+data Ident = Ident+  { idSpanInfo :: SpanInfo -- ^ Source code 'SpanInfo'+  , idName     :: String   -- ^ Name of the identifier+  , idUnique   :: Integer  -- ^ Unique number of the identifier+  } deriving (Read, Show)++instance Eq Ident where+  Ident _ m i == Ident _ n j = (m, i) == (n, j)++instance Ord Ident where+  Ident _ m i `compare` Ident _ n j = (m, i) `compare` (n, j)++instance HasSpanInfo Ident where+  getSpanInfo = idSpanInfo+  setSpanInfo spi a = a { idSpanInfo = spi }+  updateEndPos i@(Ident (SpanInfo _ [_,ss]) _ _) =+    setEndPosition (end ss) i+  updateEndPos i =+    setEndPosition (incr (getPosition i) (identLength i - 1)) i++instance HasPosition Ident where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance Pretty Ident where+  pPrint (Ident _ x n) | n == globalScope = text x+                       | otherwise        = text x <> dot <> integer n++instance Binary Ident where+  put (Ident sp qs i) = put sp >> put qs >> put i+  get = liftM3 Ident get get get++identLength :: Ident -> Int+identLength a = length (idName a)++-- |Global scope for renaming+globalScope :: Integer+globalScope = 0++-- |Construct an 'Ident' from a 'String'+mkIdent :: String -> Ident+mkIdent x = Ident NoSpanInfo x globalScope++-- |Infinite list of different 'Ident's+identSupply :: [Ident]+identSupply = [ mkNewIdent c i | i <- [0 ..] :: [Integer], c <- ['a'..'z'] ]+  where mkNewIdent c 0 = mkIdent [c]+        mkNewIdent c n = mkIdent $ c : show n++-- |Show function for an 'Ident'+showIdent :: Ident -> String+showIdent (Ident _ x n) | n == globalScope = x+                        | otherwise        = x ++ '.' : show n++-- |Show the name of an 'Ident' escaped by ticks+escName :: Ident -> String+escName i = '`' : idName i ++ "'"++-- |Has the identifier global scope?+hasGlobalScope :: Ident -> Bool+hasGlobalScope = (== globalScope) . idUnique++-- |Is the 'Ident' renamed?+isRenamed :: Ident -> Bool+isRenamed = (/= globalScope) . idUnique++-- |Rename an 'Ident' by changing its unique number+renameIdent :: Ident -> Integer -> Ident+renameIdent ident n = ident { idUnique = n }++-- |Revert the renaming of an 'Ident' by resetting its unique number+unRenameIdent :: Ident -> Ident+unRenameIdent ident = renameIdent ident globalScope++-- |Change the name of an 'Ident' using a renaming function+updIdentName :: (String -> String) -> Ident -> Ident+updIdentName f (Ident p n i) = Ident p (f n) i++-- |Add a 'Position' to an 'Ident'+addPositionIdent :: Position -> Ident -> Ident+addPositionIdent = setPosition++-- |Check whether an 'Ident' identifies an infix operation+isInfixOp :: Ident -> Bool+isInfixOp (Ident _ ('<' : c : cs) _) =+  last (c : cs) /= '>' || not (isAlphaNum c) && c `notElem` "_(["+isInfixOp (Ident _ (c : _) _)    = not (isAlphaNum c) && c `notElem` "_(["+isInfixOp Ident{}                = False -- error "Zero-length identifier"++-- ---------------------------------------------------------------------------+-- Qualified identifier+-- ---------------------------------------------------------------------------++-- |Qualified identifier+data QualIdent = QualIdent+  { qidSpanInfo :: SpanInfo          -- ^ Source code 'SpanInfo'+  , qidModule   :: Maybe ModuleIdent -- ^ optional module identifier+  , qidIdent    :: Ident             -- ^ identifier itself+  } deriving (Read, Show)++instance Eq QualIdent where+  QualIdent _ m i == QualIdent _ n j = (m, i) == (n, j)++instance Ord QualIdent where+  QualIdent _ m i `compare` QualIdent _ n j = (m, i) `compare` (n, j)++instance HasSpanInfo QualIdent where+  getSpanInfo = qidSpanInfo+  setSpanInfo spi a = a { qidSpanInfo = spi }+  updateEndPos i@(QualIdent (SpanInfo _ [_,ss]) _ _) =+    setEndPosition (end ss) i+  updateEndPos i =+    setEndPosition (incr (getPosition i) (qIdentLength i - 1)) i++instance HasPosition QualIdent where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance Pretty QualIdent where+  pPrint = text . qualName++instance Binary QualIdent where+  put (QualIdent sp mid idt) = put sp >> put mid >> put idt+  get = liftM3 QualIdent get get get++qIdentLength :: QualIdent -> Int+qIdentLength (QualIdent _ (Just m) i) = identLength i + mIdentLength m+qIdentLength (QualIdent _ Nothing  i) = identLength i++-- |show function for qualified identifiers)=+qualName :: QualIdent -> String+qualName (QualIdent _ Nothing  x) = idName x+qualName (QualIdent _ (Just m) x) = moduleName m ++ "." ++ idName x++-- |Show the name of an 'QualIdent' escaped by ticks+escQualName :: QualIdent -> String+escQualName qn = '`' : qualName qn ++ "'"++-- |Check whether an 'QualIdent' identifies an infix operation+isQInfixOp :: QualIdent -> Bool+isQInfixOp = isInfixOp . qidIdent++-- ---------------------------------------------------------------------------+-- The functions \texttt{qualify} and \texttt{qualifyWith} convert an+-- unqualified identifier into a qualified identifier (without and with a+-- given module prefix, respectively).+-- ---------------------------------------------------------------------------++-- | Convert an 'Ident' to a 'QualIdent'+qualify :: Ident -> QualIdent+qualify i = QualIdent (fromSrcSpan (getSrcSpan i)) Nothing i++-- | Convert an 'Ident' to a 'QualIdent' with a given 'ModuleIdent'+qualifyWith :: ModuleIdent -> Ident -> QualIdent+qualifyWith mid i = updateEndPos $+  QualIdent (fromSrcSpan (getSrcSpan mid)) (Just mid) i++-- | Convert an 'QualIdent' to a new 'QualIdent' with a given 'ModuleIdent'.+--   If the original 'QualIdent' already contains an 'ModuleIdent' it+--   remains unchanged.+qualQualify :: ModuleIdent -> QualIdent -> QualIdent+qualQualify m (QualIdent _ Nothing x) = qualifyWith m x+qualQualify _ x = x++-- |Qualify an 'Ident' with the 'ModuleIdent' of the given 'QualIdent',+-- if present.+qualifyLike :: QualIdent -> Ident -> QualIdent+qualifyLike (QualIdent _ Nothing  _) x = qualify x+qualifyLike (QualIdent _ (Just m) _) x = qualifyWith m x++-- | Check whether a 'QualIdent' contains a 'ModuleIdent'+isQualified :: QualIdent -> Bool+isQualified = isJust . qidModule++-- | Remove the qualification of an 'QualIdent'+unqualify :: QualIdent -> Ident+unqualify = qidIdent++-- | Remove the qualification with a specific 'ModuleIdent'. If the+--   original 'QualIdent' has no 'ModuleIdent' or a different one, it+--   remains unchanged.+qualUnqualify :: ModuleIdent -> QualIdent -> QualIdent+qualUnqualify _ qid@(QualIdent _   Nothing   _) = qid+qualUnqualify m     (QualIdent spi (Just m') x) = QualIdent spi m'' x+  where m'' | m == m'   = Nothing+            | otherwise = Just m'++-- | Extract the 'Ident' of an 'QualIdent' if it is local to the+--   'ModuleIdent', i.e. if the 'Ident' is either unqualified or qualified+--   with the given 'ModuleIdent'.+localIdent :: ModuleIdent -> QualIdent -> Maybe Ident+localIdent _ (QualIdent _ Nothing   x) = Just x+localIdent m (QualIdent _ (Just m') x)+  | m == m'   = Just x+  | otherwise = Nothing++-- |Check whether the given 'QualIdent' is local to the given 'ModuleIdent'.+isLocalIdent :: ModuleIdent -> QualIdent -> Bool+isLocalIdent mid qid = isJust (localIdent mid qid)++-- | Update a 'QualIdent' by applying functions to its components+updQualIdent :: (ModuleIdent -> ModuleIdent) -> (Ident -> Ident)+             -> QualIdent -> QualIdent+updQualIdent f g (QualIdent spi m x) = QualIdent spi (fmap f m) (g x)++-- ---------------------------------------------------------------------------+-- A few identifiers are predefined here.+-- ---------------------------------------------------------------------------+-- | 'ModuleIdent' for the empty module+emptyMIdent :: ModuleIdent+emptyMIdent = ModuleIdent NoSpanInfo []++-- | 'ModuleIdent' for the main module+mainMIdent :: ModuleIdent+mainMIdent = ModuleIdent NoSpanInfo ["main"]++-- | 'ModuleIdent' for the Prelude+preludeMIdent :: ModuleIdent+preludeMIdent = ModuleIdent NoSpanInfo ["Prelude"]++-- ---------------------------------------------------------------------------+-- Identifiers for types+-- ---------------------------------------------------------------------------++-- | 'Ident' for the type '(->)'+arrowId :: Ident+arrowId = mkIdent "(->)"++-- | 'Ident' for the type/value unit ('()')+unitId :: Ident+unitId = mkIdent "()"++-- | 'Ident' for the type 'Bool'+boolId :: Ident+boolId = mkIdent "Bool"++-- | 'Ident' for the type 'Char'+charId :: Ident+charId = mkIdent "Char"++-- | 'Ident' for the type 'Int'+intId :: Ident+intId = mkIdent "Int"++-- | 'Ident' for the type 'Float'+floatId :: Ident+floatId = mkIdent "Float"++-- | 'Ident' for the type '[]'+listId :: Ident+listId = mkIdent "[]"++-- | 'Ident' for the type 'IO'+ioId :: Ident+ioId = mkIdent "IO"++-- | 'Ident' for the type 'Success'+successId :: Ident+successId = mkIdent "Success"++-- | Construct an 'Ident' for an n-ary tuple where n > 1+tupleId :: Int -> Ident+tupleId n+  | n > 1     = mkIdent $ '(' : replicate (n - 1) ',' ++ ")"+  | otherwise = error $ "Curry.Base.Ident.tupleId: wrong arity " ++ show n++-- | Check whether an 'Ident' is an identifier for an tuple type+isTupleId :: Ident -> Bool+isTupleId (Ident _ x _) = n > 1 && x == idName (tupleId n)+  where n = length x - 1++-- | Compute the arity of a tuple identifier+tupleArity :: Ident -> Int+tupleArity i@(Ident _ x _)+  | n > 1 && x == idName (tupleId n) = n+  | otherwise                        = error $+      "Curry.Base.Ident.tupleArity: no tuple identifier: " ++ showIdent i+  where n = length x - 1++-- ---------------------------------------------------------------------------+-- Identifiers for type classes+-- ---------------------------------------------------------------------------++-- | 'Ident' for the 'Eq' class+eqId :: Ident+eqId = mkIdent "Eq"++-- | 'Ident' for the 'Ord' class+ordId :: Ident+ordId = mkIdent "Ord"++-- | 'Ident' for the 'Enum' class+enumId :: Ident+enumId = mkIdent "Enum"++-- | 'Ident' for the 'Bounded' class+boundedId :: Ident+boundedId = mkIdent "Bounded"++-- | 'Ident' for the 'Read' class+readId :: Ident+readId = mkIdent "Read"++-- | 'Ident' for the 'Show' class+showId :: Ident+showId = mkIdent "Show"++-- | 'Ident' for the 'Num' class+numId :: Ident+numId = mkIdent "Num"++-- | 'Ident' for the 'Fractional' class+fractionalId :: Ident+fractionalId = mkIdent "Fractional"++-- | 'Ident' for the 'Monad' class+monadId :: Ident+monadId = mkIdent "Monad"++-- | 'Ident' for the 'MonadFail' class+monadFailId :: Ident+monadFailId = mkIdent "MonadFail"++-- | 'Ident' for the 'Data' class+dataId :: Ident+dataId = mkIdent "Data"++-- ---------------------------------------------------------------------------+-- Identifiers for constructors+-- ---------------------------------------------------------------------------++-- | 'Ident' for the value 'True'+trueId :: Ident+trueId = mkIdent "True"++-- | 'Ident' for the value 'False'+falseId :: Ident+falseId = mkIdent "False"++-- | 'Ident' for the value '[]'+nilId :: Ident+nilId = mkIdent "[]"++-- | 'Ident' for the function ':'+consId :: Ident+consId = mkIdent ":"++-- ---------------------------------------------------------------------------+-- Identifiers for values+-- ---------------------------------------------------------------------------++-- | 'Ident' for the main function+mainId :: Ident+mainId = mkIdent "main"++-- | 'Ident' for the minus function+minusId :: Ident+minusId = mkIdent "-"++-- | 'Ident' for the minus function for Floats+fminusId :: Ident+fminusId = mkIdent "-."++-- | 'Ident' for the apply function+applyId :: Ident+applyId = mkIdent "apply"++-- | 'Ident' for the error function+errorId :: Ident+errorId = mkIdent "error"++-- | 'Ident' for the failed function+failedId :: Ident+failedId = mkIdent "failed"++-- | 'Ident' for the id function+idId :: Ident+idId = mkIdent "id"++-- | 'Ident' for the maxBound function+maxBoundId :: Ident+maxBoundId = mkIdent "maxBound"++-- | 'Ident' for the minBound function+minBoundId :: Ident+minBoundId = mkIdent "minBound"++-- | 'Ident' for the pred function+predId :: Ident+predId = mkIdent "pred"++-- | 'Ident' for the succ function+succId :: Ident+succId = mkIdent "succ"++-- | 'Ident' for the toEnum function+toEnumId :: Ident+toEnumId = mkIdent "toEnum"++-- | 'Ident' for the fromEnum function+fromEnumId :: Ident+fromEnumId = mkIdent "fromEnum"++-- | 'Ident' for the enumFrom function+enumFromId :: Ident+enumFromId = mkIdent "enumFrom"++-- | 'Ident' for the enumFromThen function+enumFromThenId :: Ident+enumFromThenId = mkIdent "enumFromThen"++-- | 'Ident' for the enumFromTo function+enumFromToId :: Ident+enumFromToId = mkIdent "enumFromTo"++-- | 'Ident' for the enumFromThenTo function+enumFromThenToId :: Ident+enumFromThenToId = mkIdent "enumFromThenTo"++-- | 'Ident' for the lex function+lexId :: Ident+lexId = mkIdent "lex"++-- | 'Ident' for the readsPrec function+readsPrecId :: Ident+readsPrecId = mkIdent "readsPrec"++-- | 'Ident' for the readParen function+readParenId :: Ident+readParenId = mkIdent "readParen"++-- | 'Ident' for the showsPrec function+showsPrecId :: Ident+showsPrecId = mkIdent "showsPrec"++-- | 'Ident' for the showParen function+showParenId :: Ident+showParenId = mkIdent "showParen"++-- | 'Ident' for the showString function+showStringId :: Ident+showStringId = mkIdent "showString"++-- | 'Ident' for the '&&' operator+andOpId :: Ident+andOpId = mkIdent "&&"++-- | 'Ident' for the '==' operator+eqOpId :: Ident+eqOpId = mkIdent "=="++-- | 'Ident' for the '<=' operator+leqOpId :: Ident+leqOpId = mkIdent "<="++-- | 'Ident' for the '<' operator+ltOpId :: Ident+ltOpId = mkIdent "<"++-- | 'Ident' for the '||' operator+orOpId :: Ident+orOpId = mkIdent "||"++-- | 'Ident' for the '++' operator+appendOpId :: Ident+appendOpId = mkIdent "++"++-- | 'Ident' for the '.' operator+dotOpId :: Ident+dotOpId = mkIdent "."++aValueId :: Ident+aValueId = mkIdent "aValue"++dataEqId :: Ident+dataEqId = mkIdent "==="++-- | 'Ident' for anonymous variable+anonId :: Ident+anonId = mkIdent "_"++-- |Check whether an 'Ident' represents an anonymous identifier ('anonId')+isAnonId :: Ident -> Bool+isAnonId = (== anonId) . unRenameIdent++-- ---------------------------------------------------------------------------+-- Qualified Identifiers for types+-- ---------------------------------------------------------------------------++-- | Construct a 'QualIdent' for an 'Ident' using the module prelude+qPreludeIdent :: Ident -> QualIdent+qPreludeIdent = qualifyWith preludeMIdent++-- | 'QualIdent' for the type '(->)'+qArrowId :: QualIdent+qArrowId = qualify arrowId++-- | 'QualIdent' for the type/value unit ('()')+qUnitId :: QualIdent+qUnitId = qualify unitId++-- | 'QualIdent' for the type '[]'+qListId :: QualIdent+qListId = qualify listId++-- | 'QualIdent' for the type 'Bool'+qBoolId :: QualIdent+qBoolId = qPreludeIdent boolId++-- | 'QualIdent' for the type 'Char'+qCharId :: QualIdent+qCharId = qPreludeIdent charId++-- | 'QualIdent' for the type 'Int'+qIntId :: QualIdent+qIntId = qPreludeIdent intId++-- | 'QualIdent' for the type 'Float'+qFloatId :: QualIdent+qFloatId = qPreludeIdent floatId++-- | 'QualIdent' for the type 'IO'+qIOId :: QualIdent+qIOId = qPreludeIdent ioId++-- | 'QualIdent' for the type 'Success'+qSuccessId :: QualIdent+qSuccessId = qPreludeIdent successId++-- | Check whether an 'QualIdent' is an primary type constructor+isPrimTypeId :: QualIdent -> Bool+isPrimTypeId tc = tc `elem` [qArrowId, qUnitId, qListId] || isQTupleId tc++-- ---------------------------------------------------------------------------+-- Qualified Identifiers for type classes+-- ---------------------------------------------------------------------------++-- | 'QualIdent' for the 'Eq' class+qEqId :: QualIdent+qEqId = qPreludeIdent eqId++-- | 'QualIdent' for the 'Ord' class+qOrdId :: QualIdent+qOrdId = qPreludeIdent ordId++-- | 'QualIdent' for the 'Enum' class+qEnumId :: QualIdent+qEnumId = qPreludeIdent enumId++-- | 'QualIdent' for the 'Bounded' class+qBoundedId :: QualIdent+qBoundedId = qPreludeIdent boundedId++-- | 'QualIdent' for the 'Read' class+qReadId :: QualIdent+qReadId = qPreludeIdent readId++-- | 'QualIdent' for the 'Show' class+qShowId :: QualIdent+qShowId = qPreludeIdent showId++-- | 'QualIdent' for the 'Num' class+qNumId :: QualIdent+qNumId = qPreludeIdent numId++-- | 'QualIdent' for the 'Fractional' class+qFractionalId :: QualIdent+qFractionalId = qPreludeIdent fractionalId++-- | 'QualIdent' for the 'Monad' class+qMonadId :: QualIdent+qMonadId = qPreludeIdent monadId++-- | 'QualIdent' for the 'MonadFail' class+qMonadFailId :: QualIdent+qMonadFailId = qPreludeIdent monadFailId++-- | 'QualIdent' for the 'Data' class+qDataId :: QualIdent+qDataId = qPreludeIdent dataId++-- ---------------------------------------------------------------------------+-- Qualified Identifiers for constructors+-- ---------------------------------------------------------------------------++-- | 'QualIdent' for the constructor 'True'+qTrueId :: QualIdent+qTrueId = qPreludeIdent trueId++-- | 'QualIdent' for the constructor 'False'+qFalseId :: QualIdent+qFalseId = qPreludeIdent falseId++-- | 'QualIdent' for the constructor '[]'+qNilId :: QualIdent+qNilId = qualify nilId++-- | 'QualIdent' for the constructor ':'+qConsId :: QualIdent+qConsId = qualify consId++-- | 'QualIdent' for the type of n-ary tuples+qTupleId :: Int -> QualIdent+qTupleId = qualify . tupleId++-- | Check whether an 'QualIdent' is an identifier for an tuple type+isQTupleId :: QualIdent -> Bool+isQTupleId = isTupleId . unqualify++-- | Compute the arity of an qualified tuple identifier+qTupleArity :: QualIdent -> Int+qTupleArity = tupleArity . unqualify++-- ---------------------------------------------------------------------------+-- Qualified Identifiers for values+-- ---------------------------------------------------------------------------++-- | 'QualIdent' for the apply function+qApplyId :: QualIdent+qApplyId = qPreludeIdent applyId++-- | 'QualIdent' for the error function+qErrorId :: QualIdent+qErrorId = qPreludeIdent errorId++-- | 'QualIdent' for the failed function+qFailedId :: QualIdent+qFailedId = qPreludeIdent failedId++-- | 'QualIdent' for the id function+qIdId :: QualIdent+qIdId = qPreludeIdent idId++-- | 'QualIdent' for the maxBound function+qMaxBoundId :: QualIdent+qMaxBoundId = qPreludeIdent maxBoundId++-- | 'QualIdent' for the minBound function+qMinBoundId :: QualIdent+qMinBoundId = qPreludeIdent minBoundId++-- | 'QualIdent' for the fromEnum function+qFromEnumId :: QualIdent+qFromEnumId = qPreludeIdent fromEnumId++-- | 'QualIdent' for the enumFrom function+qEnumFromId :: QualIdent+qEnumFromId = qPreludeIdent enumFromId++-- | 'QualIdent' for the enumFromThen function+qEnumFromThenId :: QualIdent+qEnumFromThenId = qPreludeIdent enumFromThenId++-- | 'QualIdent' for the enumFromTo function+qEnumFromToId :: QualIdent+qEnumFromToId = qPreludeIdent enumFromToId++-- | 'QualIdent' for the enumFromThenTo function+qEnumFromThenToId :: QualIdent+qEnumFromThenToId = qPreludeIdent enumFromThenToId++-- | 'QualIdent' for the lex function+qLexId :: QualIdent+qLexId = qPreludeIdent lexId++-- | 'QualIdent' for the readsPrec function+qReadsPrecId :: QualIdent+qReadsPrecId = qPreludeIdent readsPrecId++-- | 'QualIdent' for the readParen function+qReadParenId :: QualIdent+qReadParenId = qPreludeIdent readParenId++-- | 'QualIdent' for the showsPrec function+qShowsPrecId :: QualIdent+qShowsPrecId = qPreludeIdent showsPrecId++-- | 'QualIdent' for the showParen function+qShowParenId :: QualIdent+qShowParenId = qPreludeIdent showParenId++-- | 'QualIdent' for the showString function+qShowStringId :: QualIdent+qShowStringId = qPreludeIdent showStringId++-- | 'QualIdent' for the '&&' operator+qAndOpId :: QualIdent+qAndOpId = qPreludeIdent andOpId++-- | 'QualIdent' for the '==' operator+qEqOpId :: QualIdent+qEqOpId = qPreludeIdent eqOpId++-- | 'QualIdent' for the '<=' operator+qLeqOpId :: QualIdent+qLeqOpId = qPreludeIdent leqOpId++-- | 'QualIdent' for the '<' operator+qLtOpId :: QualIdent+qLtOpId = qPreludeIdent ltOpId++-- | 'QualIdent' for the '||' operator+qOrOpId :: QualIdent+qOrOpId = qPreludeIdent orOpId++-- | 'QualIdent' for the '.' operator+qDotOpId :: QualIdent+qDotOpId = qPreludeIdent dotOpId++qAValueId :: QualIdent+qAValueId = qPreludeIdent aValueId++qDataEqId :: QualIdent+qDataEqId = qPreludeIdent dataEqId++-- | 'QualIdent' for the '++' operator+qAppendOpId :: QualIdent+qAppendOpId = qPreludeIdent appendOpId++-- ---------------------------------------------------------------------------+-- Micellaneous functions for generating and testing extended identifiers+-- ---------------------------------------------------------------------------++-- Functional patterns++-- | Annotation for function pattern identifiers+fpSelExt :: String+fpSelExt = "_#selFP"++-- | Construct an 'Ident' for a functional pattern+fpSelectorId :: Int -> Ident+fpSelectorId n = mkIdent $ fpSelExt ++ show n++-- | Check whether an 'Ident' is an identifier for a functional pattern+isFpSelectorId :: Ident -> Bool+isFpSelectorId = (fpSelExt `isInfixOf`) . idName++-- | Check whether an 'QualIdent' is an identifier for a function pattern+isQualFpSelectorId :: QualIdent -> Bool+isQualFpSelectorId = isFpSelectorId . unqualify++-- Record selection++-- | Annotation for record selection identifiers+recSelExt :: String+recSelExt = "_#selR@"++-- | Construct an 'Ident' for a record selection pattern+recSelectorId :: QualIdent -- ^ identifier of the record+              -> Ident     -- ^ identifier of the label+              -> Ident+recSelectorId = mkRecordId recSelExt++-- | Construct a 'QualIdent' for a record selection pattern+qualRecSelectorId :: ModuleIdent -- ^ default module+                  -> QualIdent   -- ^ record identifier+                  -> Ident       -- ^ label identifier+                  -> QualIdent+qualRecSelectorId m r l = qualRecordId m r $ recSelectorId r l++-- Record update++-- | Annotation for record update identifiers+recUpdExt :: String+recUpdExt = "_#updR@"++-- | Construct an 'Ident' for a record update pattern+recUpdateId :: QualIdent -- ^ record identifier+            -> Ident     -- ^ label identifier+            -> Ident+recUpdateId = mkRecordId recUpdExt++-- | Construct a 'QualIdent' for a record update pattern+qualRecUpdateId :: ModuleIdent -- ^ default module+                -> QualIdent   -- ^ record identifier+                -> Ident       -- ^ label identifier+                -> QualIdent+qualRecUpdateId m r l = qualRecordId m r $ recUpdateId r l++-- Auxiliary function to construct a selector/update identifier+mkRecordId :: String -> QualIdent -> Ident -> Ident+mkRecordId ann r l = mkIdent $ concat+  [ann, idName (unqualify r), ".", idName l]++-- Auxiliary function to qualify a selector/update identifier+qualRecordId :: ModuleIdent -> QualIdent -> Ident -> QualIdent+qualRecordId m r = qualifyWith (fromMaybe m $ qidModule r)++-- Record tyes++-- | Annotation for record identifiers+recordExt :: String+recordExt = "_#Rec:"++-- | Construct an 'Ident' for a record+recordExtId :: Ident -> Ident+recordExtId r = mkIdent $ recordExt ++ idName r++-- | Check whether an 'Ident' is an identifier for a record+isRecordExtId :: Ident -> Bool+isRecordExtId = (recordExt `isPrefixOf`) . idName++-- | Retrieve the 'Ident' from a record identifier+fromRecordExtId :: Ident -> Ident+fromRecordExtId r+  | p == recordExt = mkIdent r'+  | otherwise      = r+ where (p, r') = splitAt (length recordExt) (idName r)++-- Record labels++-- | Annotation for record label identifiers+labelExt :: String+labelExt = "_#Lab:"++-- | Construct an 'Ident' for a record label+labelExtId :: Ident -> Ident+labelExtId l = mkIdent $ labelExt ++ idName l++-- | Check whether an 'Ident' is an identifier for a record label+isLabelExtId :: Ident -> Bool+isLabelExtId = (labelExt `isPrefixOf`) . idName++-- | Retrieve the 'Ident' from a record label identifier+fromLabelExtId :: Ident -> Ident+fromLabelExtId l+  | p == labelExt = mkIdent l'+  | otherwise     = l+ where (p, l') = splitAt (length labelExt) (idName l)++-- | Construct an 'Ident' for a record label+mkLabelIdent :: String -> Ident+mkLabelIdent c = renameIdent (mkIdent c) (-1)++-- | Rename an 'Ident' for a record label+renameLabel :: Ident -> Ident+renameLabel l = renameIdent l (-1)
+ src/Curry/Base/LLParseComb.hs view
@@ -0,0 +1,380 @@+{- |+    Module      :  $Header$+    Description :  Parser combinators+    Copyright   :  (c) 1999-2004, Wolfgang Lux+                       2016     , Jan Tikovsky+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    The parsing combinators implemented in this module are based on the+    LL(1) parsing combinators developed by Swierstra and Duponcheel.+    They have been adapted to using continuation passing style in order to+    work with the lexing combinators described in the previous section.+    In addition, the facilities for error correction are omitted+    in this implementation.++    The two functions 'applyParser' and 'prefixParser' use the specified+    parser for parsing a string. When 'applyParser' is used, an error is+    reported if the parser does not consume the whole string,+    whereas 'prefixParser' discards the rest of the input string in this case.+-}+{-# LANGUAGE CPP #-}++module Curry.Base.LLParseComb+  ( -- * Data types+    Parser++    -- * Parser application+  , fullParser, prefixParser++    -- * Basic parsers+  , position, spanPosition, succeed, failure, symbol++    -- *  parser combinators+  , (<?>), (<|>), (<|?>), (<*>), (<\>), (<\\>)+  , (<$>), (<$->), (<*->), (<-*>), (<**>), (<??>), (<.>)+  , opt, choice, flag, optional, option, many, many1, sepBy, sepBy1+  , sepBySp, sepBy1Sp+  , chainr, chainr1, chainl, chainl1, between, ops++    -- * Layout combinators+  , layoutOn, layoutOff, layoutEnd+  ) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative (Applicative, (<*>), (<$>), pure)+#endif+import Control.Monad+import qualified Data.Map as Map+import Data.Maybe+import qualified Data.Set as Set++import Curry.Base.LexComb+import Curry.Base.Position+import Curry.Base.Span (span2Pos, Span, startCol, setDistance)++infixl 5 <\>, <\\>+infixl 4 <$->, <*->, <-*>, <**>, <??>, <.>+infixl 3 <|>, <|?>+infixl 2 <?>, `opt`++-- ---------------------------------------------------------------------------+-- Parser types+-- ---------------------------------------------------------------------------++-- |Parsing function+type ParseFun a s b  = (b -> SuccessP s a) -> FailP a -> SuccessP s a++-- |CPS-Parser type+data Parser a s b = Parser+  -- Parsing function for empty word+  (Maybe (ParseFun a s b))+  -- Lookup table (continuations for 'Symbol's recognized by the parser)+  (Map.Map s (Lexer s a -> ParseFun a s b))++instance Symbol s => Functor (Parser a s) where+  fmap f p = succeed f <*> p++instance Symbol s => Applicative (Parser a s) where+  pure = succeed++  -- |Apply the result function of the first parser to the result of the+  --  second parser.+  Parser Nothing   ps1 <*> p2                  = Parser Nothing+    (fmap (`seqPP` p2) ps1)+  Parser (Just p1) ps1 <*> ~p2@(Parser e2 ps2) = Parser (fmap (seqEE p1) e2)+    (Map.union (fmap (`seqPP` p2) ps1) (fmap (seqEP p1) ps2))++instance Show s => Show (Parser a s b) where+  showsPrec p (Parser e ps) = showParen (p >= 10) $+    showString "Parser " . shows (isJust e) .+    showChar ' ' . shows (Map.keysSet ps)++-- ---------------------------------------------------------------------------+-- Parser application+-- ---------------------------------------------------------------------------++-- |Apply a parser and lexer to a 'String', whereas the 'FilePath' is used+-- to identify the origin of the 'String' in case of parsing errors.+fullParser :: Symbol s => Parser a s a -> Lexer s a -> FilePath -> String+           -> CYM a+fullParser p lexer = parse (lexer (choose p lexer successP failP) failP)+  where successP x pos s+          | isEOF s   = returnP x+          | otherwise = failP pos (unexpected s)++-- |Apply a parser and lexer to parse the beginning of a 'String'.+-- The 'FilePath' is used to identify the origin of the 'String' in case of+-- parsing errors.+prefixParser :: Symbol s => Parser a s a -> Lexer s a -> FilePath -> String+             -> CYM a+prefixParser p lexer = parse (lexer (choose p lexer discardP failP) failP)+  where discardP x _ _ = returnP x++-- |Choose the appropriate parsing function w.r.t. to the next 'Symbol'.+choose :: Symbol s => Parser a s b -> Lexer s a -> ParseFun a s b+choose (Parser e ps) lexer success failp pos s = case Map.lookup s ps of+  Just p  -> p lexer success failp pos s+  Nothing -> case e of+    Just p  -> p success failp pos s+    Nothing -> failp pos (unexpected s)++-- |Fail on an unexpected 'Symbol'+unexpected :: Symbol s => s -> String+unexpected s+  | isEOF s   = "Unexpected end-of-file"+  | otherwise = "Unexpected token " ++ show s++-- ---------------------------------------------------------------------------+-- Basic parsers+-- ---------------------------------------------------------------------------++-- |Return the current position without consuming the input+position :: Parser a s Position+position = Parser (Just p) Map.empty+  where p success _ sp = success (span2Pos sp) sp++spanPosition :: Symbol s => Parser a s Span+spanPosition = Parser (Just p) Map.empty+  where p success _ sp s = success (setDistance sp (dist (startCol sp) s)) sp s++-- |Always succeeding parser+succeed :: b -> Parser a s b+succeed x = Parser (Just p) Map.empty+  where p success _ = success x++-- |Always failing parser with a given message+failure :: String -> Parser a s b+failure msg = Parser (Just p) Map.empty+  where p _ failp pos _ = failp pos msg++-- |Create a parser accepting the given 'Symbol'+symbol :: s -> Parser a s s+symbol s = Parser Nothing (Map.singleton s p)+  where p lexer success failp _ s' = lexer (success s') failp++-- ---------------------------------------------------------------------------+-- Parser combinators+-- ---------------------------------------------------------------------------++-- |Behave like the given parser, but use the given 'String' as the error+-- message if the parser fails+(<?>) :: Symbol s => Parser a s b -> String -> Parser a s b+p <?> msg = p <|> failure msg++-- |Deterministic choice between two parsers.+-- The appropriate parser is chosen based on the next 'Symbol'+(<|>) :: Symbol s => Parser a s b -> Parser a s b -> Parser a s b+Parser e1 ps1 <|> Parser e2 ps2+  | isJust e1 && isJust e2 = failure "Ambiguous parser for empty word"+  | not (Set.null common)  = failure $ "Ambiguous parser for " ++ show common+  | otherwise              = Parser (e1 `mplus` e2) (Map.union ps1 ps2)+  where common = Map.keysSet ps1 `Set.intersection` Map.keysSet ps2++-- |Non-deterministic choice between two parsers.+--+-- The other parsing combinators require that the grammar being parsed+-- is LL(1). In some cases it may be difficult or even+-- impossible to transform a grammar into LL(1) form. As a remedy, we+-- include a non-deterministic version of the choice combinator in+-- addition to the deterministic combinator adapted from the paper. For+-- every symbol from the intersection of the parser's first sets, the+-- combinator '(<|?>)' applies both parsing functions to the input+-- stream and uses that one which processes the longer prefix of the+-- input stream irrespective of whether it succeeds or fails. If both+-- functions recognize the same prefix, we choose the one that succeeds+-- and report an ambiguous parse error if both succeed.+(<|?>) :: Symbol s => Parser a s b -> Parser a s b -> Parser a s b+Parser e1 ps1 <|?> Parser e2 ps2+  | isJust e1 && isJust e2 = failure "Ambiguous parser for empty word"+  | otherwise              = Parser (e1 `mplus` e2) (Map.union ps1' ps2)+  where+  ps1' = Map.fromList [ (s, maybe p (try p) (Map.lookup s ps2))+                      | (s, p) <- Map.toList ps1+                      ]+  try p1 p2 lexer success failp pos s =+    closeP1 p2s `thenP` \p2s' ->+    closeP1 p2f `thenP` \p2f' ->+    parse' p1 (retry p2s') (retry p2f')+    where p2s r1 = parse' p2       (select True   r1) (select False r1)+          p2f r1 = parse' p2 (flip (select False) r1) (select False r1)+          parse' p psucc pfail =+            p lexer (successK psucc) (failK pfail) pos s+          successK k x pos' s' = k (pos', success x pos' s')+          failK k pos' msg = k (pos', failp pos' msg)+          retry k (pos',p) = closeP0 p `thenP` curry k pos'+  select suc (pos1, p1) (pos2, p2) = case pos1 `compare` pos2 of+    GT -> p1+    EQ | suc       -> failP pos1 $ "Ambiguous parse before " ++ showPosition (span2Pos pos1)+       | otherwise -> p1+    LT -> p2++seqEE :: ParseFun a s (b -> c) -> ParseFun a s b -> ParseFun a s c+seqEE p1 p2 success failp = p1 (\f -> p2 (success . f) failp) failp++seqEP :: ParseFun a s (b -> c) -> (Lexer s a -> ParseFun a s b)+      -> Lexer s a -> ParseFun a s c+seqEP p1 p2 lexer success failp = p1 (\f -> p2 lexer (success . f) failp) failp++seqPP :: Symbol s => (Lexer s a -> ParseFun a s (b -> c)) -> Parser a s b+      -> Lexer s a -> ParseFun a s c+seqPP p1 p2 lexer success failp =+  p1 lexer (\f -> choose p2 lexer (success . f) failp) failp++-- ---------------------------------------------------------------------------+-- The combinators \verb|<\\>| and \verb|<\>| can be used to restrict+-- the first set of a parser. This is useful for combining two parsers+-- with an overlapping first set with the deterministic combinator <|>.+-- ---------------------------------------------------------------------------++-- |Restrict the first parser by the first 'Symbol's of the second+(<\>) :: Symbol s => Parser a s b -> Parser a s c -> Parser a s b+p <\> Parser _ ps = p <\\> Map.keys ps++-- |Restrict a parser by a list of first 'Symbol's+(<\\>) :: Symbol s => Parser a s b -> [s] -> Parser a s b+Parser e ps <\\> xs = Parser e (foldr Map.delete ps xs)++-- ---------------------------------------------------------------------------+-- Other combinators+-- Note that some of these combinators have not been published in the+-- paper, but were taken from the implementation found on the web.+-- ---------------------------------------------------------------------------++-- |Replace the result of the parser with the first argument+(<$->) :: Symbol s => a -> Parser b s c -> Parser b s a+f <$-> p = f <$ p++-- |Apply two parsers in sequence, but return only the result of the first+-- parser+(<*->) :: Symbol s => Parser a s b -> Parser a s c -> Parser a s b+p <*-> q = const <$> p <*> q++-- |Apply two parsers in sequence, but return only the result of the second+-- parser+(<-*>) :: Symbol s => Parser a s b -> Parser a s c -> Parser a s c+p <-*> q = id <$ p <*> q++-- |Apply the parsers in sequence and apply the result function of the second+-- parse to the result of the first+(<**>) :: Symbol s => Parser a s b -> Parser a s (b -> c) -> Parser a s c+p <**> q = flip ($) <$> p <*> q++-- |Same as (<**>), but only applies the function if the second parser+-- succeeded.+(<??>) :: Symbol s => Parser a s b -> Parser a s (b -> b) -> Parser a s b+p <??> q = p <**> (q `opt` id)++-- |Flipped function composition on parsers+(<.>) :: Symbol s => Parser a s (b -> c) -> Parser a s (c -> d)+      -> Parser a s (b -> d)+p1 <.> p2 = p1 <**> ((.) <$> p2)++-- |Try the first parser, but return the second argument if it didn't succeed+opt :: Symbol s => Parser a s b -> b -> Parser a s b+p `opt` x = p <|> succeed x++-- |Choose the first succeeding parser from a non-empty list of parsers+choice :: Symbol s => [Parser a s b] -> Parser a s b+choice = foldr1 (<|>)++-- |Try to apply a given parser and return a boolean value if the parser+-- succeeded.+flag :: Symbol s => Parser a s b -> Parser a s Bool+flag p = True <$-> p `opt` False++-- |Try to apply a parser but forget if it succeeded+optional :: Symbol s => Parser a s b -> Parser a s ()+optional p = void p `opt` ()++-- |Try to apply a parser and return its result in a 'Maybe' type+option :: Symbol s => Parser a s b -> Parser a s (Maybe b)+option p = Just <$> p `opt` Nothing++-- |Repeatedly apply a parser for 0 or more occurences+many :: Symbol s => Parser a s b -> Parser a s [b]+many p = many1 p `opt` []++-- |Repeatedly apply a parser for 1 or more occurences+many1 :: Symbol s => Parser a s b -> Parser a s [b]+many1 p = (:) <$> p <*> many p++-- |Parse a list with is separated by a seperator+sepBy :: Symbol s => Parser a s b -> Parser a s c -> Parser a s [b]+p `sepBy` q = p `sepBy1` q `opt` []++-- |Parse a non-empty list with is separated by a seperator+sepBy1 :: Symbol s => Parser a s b -> Parser a s c -> Parser a s [b]+p `sepBy1` q = (:) <$> p <*> many (q <-*> p)++-- |Parse a list with is separated by a seperator+sepBySp :: Symbol s => Parser a s b -> Parser a s c -> Parser a s ([b], [Span])+p `sepBySp` q = p `sepBy1Sp` q `opt` ([], [])++sepBy1Sp :: Symbol s => Parser a s b -> Parser a s c -> Parser a s ([b], [Span])+p `sepBy1Sp` q = comb <$> p <*> many ((,) <$> spanPosition <*-> q <*> p)+  where comb x xs = let (ss, ys) = unzip xs+                    in (x:ys,ss)++-- |@chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.+-- Returns a value produced by a *right* associative application of all+-- functions returned by op. If there are no occurrences of @p@, @x@ is+-- returned.+chainr :: Symbol s+       => Parser a s b -> Parser a s (b -> b -> b) -> b -> Parser a s b+chainr p op x = chainr1 p op `opt` x++-- |Like 'chainr', but parses one or more occurrences of p.+chainr1 :: Symbol s => Parser a s b -> Parser a s (b -> b -> b) -> Parser a s b+chainr1 p op = r where r = p <**> (flip <$> op <*> r `opt` id)++-- |@chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.+-- Returns a value produced by a *left* associative application of all+-- functions returned by op. If there are no occurrences of @p@, @x@ is+-- returned.+chainl :: Symbol s+       => Parser a s b -> Parser a s (b -> b -> b) -> b -> Parser a s b+chainl p op x = chainl1 p op `opt` x++-- |Like 'chainl', but parses one or more occurrences of p.+chainl1 :: Symbol s => Parser a s b -> Parser a s (b -> b -> b) -> Parser a s b+chainl1 p op = foldF <$> p <*> many (flip <$> op <*> p)+  where foldF x []     = x+        foldF x (f:fs) = foldF (f x) fs++-- |Parse an expression between an opening and a closing part.+between :: Symbol s => Parser a s b -> Parser a s c -> Parser a s b+        -> Parser a s c+between open p close = open <-*> p <*-> close++-- |Parse one of the given operators+ops :: Symbol s => [(s, b)] -> Parser a s b+ops []              = failure "Curry.Base.LLParseComb.ops: empty list"+ops [(s, x)]        = x <$-> symbol s+ops ((s, x) : rest) = x <$-> symbol s <|> ops rest++-- ---------------------------------------------------------------------------+-- Layout combinators+-- Note that the layout functions grab the next token (and its position).+-- After modifying the layout context, the continuation is called with+-- the same token and an undefined result.+-- ---------------------------------------------------------------------------++-- |Disable layout-awareness for the following+layoutOff :: Symbol s => Parser a s b+layoutOff = Parser (Just off) Map.empty+  where off success _ pos = pushContext (-1) . success undefined pos++-- |Add a new scope for layout+layoutOn :: Symbol s => Parser a s b+layoutOn = Parser (Just on) Map.empty+  where on success _ pos = pushContext (column (span2Pos pos)) . success undefined pos++-- |End the current layout scope (or re-enable layout-awareness if it is+-- currently disabled+layoutEnd :: Symbol s => Parser a s b+layoutEnd = Parser (Just end) Map.empty+  where end success _ pos = popContext . success undefined pos
+ src/Curry/Base/LexComb.hs view
@@ -0,0 +1,179 @@+{- |+    Module      :  $Header$+    Description :  Lexer combinators+    Copyright   :  (c) 1999 - 2004, Wolfgang Lux+                       2012 - 2013, Björn Peemöller+                       2016       , Jan Tikovsky+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module provides the basic types and combinators to implement the+    lexers. The combinators use continuation passing code in a monadic style.++    The first argument of the continuation function is the current span,+    and the second is the string to be parsed. The third argument is a flag+    which signals the lexer that it is lexing the beginning of a line and+    therefore has to check for layout tokens. The fourth argument is a stack+    of indentations that is used to handle nested layout groups.+-}+module Curry.Base.LexComb+  ( -- * Types+    Symbol (..), Indent, Context, P, CYM, SuccessP, FailP, Lexer++    -- * Monadic functions+  , parse, applyLexer, returnP, thenP, thenP_, failP, warnP+  , liftP, closeP0, closeP1++    -- * Combinators for layout handling+  , pushContext, popContext++    -- * Conversion of numbers+  , convertSignedIntegral, convertSignedFloating+  , convertIntegral, convertFloating+  ) where++import Data.Char        (digitToInt)++import Curry.Base.Monad (CYM, failMessageAt, warnMessageAt)+import Curry.Base.Span  ( Distance, Span (..), startCol, fstSpan+                        , setDistance)+++infixl 1 `thenP`, `thenP_`++-- |Type class for symbols+class (Ord s, Show s) => Symbol s where+  -- |Does the 'Symbol' represent the end of the input?+  isEOF :: s -> Bool+  -- |Compute the distance of a 'Symbol'+  dist :: Int -> s -> Distance++-- |Type for indentations, necessary for the layout rule+type Indent = Int++-- |Type of context for representing layout grouping+type Context = [Indent]++-- |Basic lexer function+type P a = Span     -- ^ Current source code span+        -> String   -- ^ 'String' to be parsed+        -> Bool     -- ^ Flag whether the beginning of a line should be+                    --   parsed, which requires layout checking+        -> Context  -- ^ context as a stack of 'Indent's+        -> CYM a++-- |Apply a lexer on a 'String' to lex the content. The second parameter+-- requires a 'FilePath' to use in the 'Span'+parse :: P a -> FilePath -> String -> CYM a+parse p fn s = p (fstSpan fn) s True []++-- ---------------------------------------------------------------------------+-- CPS lexer+-- ---------------------------------------------------------------------------++-- |success continuation+type SuccessP s a = Span -> s -> P a++-- |failure continuation+type FailP a      = Span -> String -> P a++-- |A CPS lexer+type Lexer s a    = SuccessP s a -> FailP a -> P a++-- |Apply a lexer+applyLexer :: Symbol s => Lexer s [(Span, s)] -> P [(Span, s)]+applyLexer lexer = lexer successP failP+  where successP sp t | isEOF t   = returnP [(sp', t)]+                      | otherwise = ((sp', t) :) `liftP` lexer successP failP+          where sp' = setDistance sp (dist (startCol sp) t)++-- ---------------------------------------------------------------------------+-- Monadic functions for the lexer.+-- ---------------------------------------------------------------------------++-- |Lift a value into the lexer type+returnP :: a -> P a+returnP x _ _ _ _ = return x++-- |Apply the first lexer and then apply the second one, based on the result+-- of the first lexer.+thenP :: P a -> (a -> P b) -> P b+thenP lexer k sp s bol ctxt+  = lexer sp s bol ctxt >>= \x -> k x sp s bol ctxt++-- |Apply the first lexer and then apply the second one, ignoring the first+-- result.+thenP_ :: P a -> P b -> P b+p1 `thenP_` p2 = p1 `thenP` const p2++-- |Fail to lex on a 'Span', given an error message+failP :: Span -> String -> P a+failP sp msg _ _ _ _ = failMessageAt sp msg++-- |Warn on a 'Span', given a warning message+warnP :: Span -> String -> P a -> P a+warnP warnSpan msg lexer sp s bol ctxt+  = warnMessageAt warnSpan msg >> lexer sp s bol ctxt++-- |Apply a pure function to the lexers result+liftP :: (a -> b) -> P a -> P b+liftP f p = p `thenP` returnP . f++-- |Lift a lexer into the 'P' monad, returning the lexer when evaluated.+closeP0 :: P a -> P (P a)+closeP0 lexer sp s bol ctxt = return (\_ _ _ _ -> lexer sp s bol ctxt)++-- |Lift a lexer-generating function into the 'P' monad, returning the+--  function when evaluated.+closeP1 :: (a -> P b) -> P (a -> P b)+closeP1 f sp s bol ctxt = return (\x _ _ _ _ -> f x sp s bol ctxt)++-- ---------------------------------------------------------------------------+-- Combinators for handling layout.+-- ---------------------------------------------------------------------------++-- |Push an 'Indent' to the context, increasing the levels of indentation+pushContext :: Indent -> P a -> P a+pushContext col cont sp s bol ctxt = cont sp s bol (col : ctxt)++-- |Pop an 'Indent' from the context, decreasing the levels of indentation+popContext :: P a -> P a+popContext cont sp s bol (_ : ctxt) = cont sp s bol ctxt+popContext _    sp _ _   []         = failMessageAt sp $+  "Parse error: popping layout from empty context stack. " +++  "Perhaps you have inserted too many '}'?"++-- ---------------------------------------------------------------------------+-- Conversions from 'String's into numbers.+-- ---------------------------------------------------------------------------++-- |Convert a String into a signed intergral using a given base+convertSignedIntegral :: Num a => a -> String -> a+convertSignedIntegral b ('+':s) =   convertIntegral b s+convertSignedIntegral b ('-':s) = - convertIntegral b s+convertSignedIntegral b s       =   convertIntegral b s++-- |Convert a String into an unsigned intergral using a given base+convertIntegral :: Num a => a -> String -> a+convertIntegral b = foldl op 0+  where m `op` n = b * m + fromIntegral (digitToInt n)++-- |Convert a mantissa, a fraction part and an exponent into a signed+-- floating value+convertSignedFloating :: Fractional a => String -> String -> Int -> a+convertSignedFloating ('+':m) f e =   convertFloating m f e+convertSignedFloating ('-':m) f e = - convertFloating m f e+convertSignedFloating m       f e =   convertFloating m f e++-- |Convert a mantissa, a fraction part and an exponent into an unsigned+-- floating value+convertFloating :: Fractional a => String -> String -> Int -> a+convertFloating m f e+  | e' == 0   = m'+  | e' >  0   = m' * 10 ^ e'+  | otherwise = m' / 10 ^ (- e')+  where m' = convertIntegral 10 (m ++ f)+        e' = e - length f
+ src/Curry/Base/Message.hs view
@@ -0,0 +1,114 @@+{- |+    Module      :  $Header$+    Description :  Monads for message handling+    Copyright   :  2009        Holger Siegel+                   2012 - 2015 Björn Peemöller+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    The type message represents a compiler message with an optional source+    code position.+-}+{-# LANGUAGE CPP #-}+module Curry.Base.Message+  ( Message (..), message, posMessage, spanMessage, spanInfoMessage+  , showWarning, showError+  , ppMessage, ppWarning, ppError, ppMessages, ppMessagesWithPreviews+  ) where++#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif++import Curry.Base.Position+import Curry.Base.Pretty+import Curry.Base.Span+import Curry.Base.SpanInfo++-- ---------------------------------------------------------------------------+-- Message+-- ---------------------------------------------------------------------------++-- |Compiler message+data Message = Message+  { msgSpanInfo :: SpanInfo -- ^ span in the source code+  , msgTxt      :: Doc      -- ^ the message itself+  }++instance Eq Message where+  Message s1 t1 == Message s2 t2 = (s1, show t1) == (s2, show t2)++instance Ord Message where+  Message s1 t1 `compare` Message s2 t2 = compare (s1, show t1) (s2, show t2)++instance Show Message where+  showsPrec _ = shows . ppMessage++instance HasPosition Message where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasSpanInfo Message where+  getSpanInfo       = msgSpanInfo+  setSpanInfo spi m = m { msgSpanInfo = spi }++instance Pretty Message where+  pPrint = ppMessage++-- |Construct a 'Message' without a 'SpanInfo'+message :: Doc -> Message+message = Message NoSpanInfo++-- |Construct a message from a position.+posMessage :: HasPosition p => p -> Doc -> Message+posMessage p = spanMessage $ pos2Span $ getPosition p++-- |Construct a message from a span and a text+spanMessage :: Span -> Doc -> Message+spanMessage s = spanInfoMessage $ fromSrcSpan s++-- |Construct a message from an entity with a 'SpanInfo' and a text+spanInfoMessage :: HasSpanInfo s => s -> Doc -> Message+spanInfoMessage s msg = Message (getSpanInfo s) msg++-- |Show a 'Message' as a warning+showWarning :: Message -> String+showWarning = show . ppWarning++-- |Show a 'Message' as an error+showError :: Message -> String+showError = show . ppError++-- |Pretty print a 'Message'+ppMessage :: Message -> Doc+ppMessage = ppAs ""++-- |Pretty print a 'Message' as a warning+ppWarning :: Message -> Doc+ppWarning = ppAs "Warning"++-- |Pretty print a 'Message' as an error+ppError :: Message -> Doc+ppError = ppAs "Error"++-- |Pretty print a 'Message' with a given key+ppAs :: String -> Message -> Doc+ppAs key (Message mbSpanInfo txt) = (hsep $ filter (not . isEmpty) [spanPP, keyPP]) $$ nest 4 txt+  where+  spanPP = ppCompactSpan $ getSrcSpan $ mbSpanInfo+  keyPP = if null key then empty else text key <> colon++-- |Pretty print a list of 'Message's by vertical concatenation+ppMessages :: (Message -> Doc) -> [Message] -> Doc+ppMessages ppFun = foldr (\m ms -> text "" $+$ m $+$ ms) empty . map ppFun++-- |Pretty print a list of 'Message's with previews by vertical concatenation+ppMessagesWithPreviews :: (Message -> Doc) -> [Message] -> IO Doc+ppMessagesWithPreviews ppFun = (fmap $ foldr (\m ms -> text "" $+$ m $+$ ms) empty) . mapM ppFunWithPreview+  where ppFunWithPreview m = do preview <- case m of+                                  Message (SpanInfo sp _) _ -> ppSpanPreview sp+                                  _                         -> return empty+                                return $ ppFun m $+$ preview
+ src/Curry/Base/Monad.hs view
@@ -0,0 +1,95 @@+{- |+    Module      :  $Header$+    Description :  Monads for message handling+    Copyright   :  2014 - 2016 Björn Peemöller+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental++    The monads defined in this module provide a common way to stop execution+    when some errors occur. They are used to integrate different compiler passes+    smoothly.+-}++module Curry.Base.Monad+  ( CYIO, CYM, CYT, failMessages, failMessageAt, warnMessages, warnMessageAt+  , ok, runCYIO, runCYM, runCYIOIgnWarn, runCYMIgnWarn, liftCYM, silent+  ) where++import Control.Monad.Identity+import Control.Monad.Trans.Except (ExceptT, mapExceptT, runExceptT, throwE)+import Control.Monad.Writer++import Curry.Base.Message  (Message, spanMessage)+import Curry.Base.Span (Span)+import Curry.Base.Pretty   (text)++-- |Curry compiler monad transformer+type CYT m a = WriterT [Message] (ExceptT [Message] m) a++-- |Curry compiler monad based on the `IO` monad+type CYIO a = CYT IO a++-- |Pure Curry compiler monad+type CYM a = CYT Identity a++-- |Run an `IO`-based Curry compiler action in the `IO` monad,+-- yielding either a list of errors or a result in case of success+-- consisting of the actual result and a (possibly empty) list of warnings+runCYIO :: CYIO a -> IO (Either [Message] (a, [Message]))+runCYIO = runExceptT . runWriterT++-- |Run an pure Curry compiler action,+-- yielding either a list of errors or a result in case of success+-- consisting of the actual result and a (possibly empty) list of warnings+runCYM :: CYM a -> Either [Message] (a, [Message])+runCYM = runIdentity . runExceptT . runWriterT++-- |Run an `IO`-based Curry compiler action in the `IO` monad,+-- yielding either a list of errors or a result in case of success.+runCYIOIgnWarn :: CYIO a -> IO (Either [Message] a)+runCYIOIgnWarn = runExceptT . (liftM fst) . runWriterT++-- |Run an pure Curry compiler action,+-- yielding either a list of errors or a result in case of success.+runCYMIgnWarn :: CYM a -> Either [Message] a+runCYMIgnWarn = runIdentity . runExceptT . (liftM fst) . runWriterT++-- |Failing action with a message describing the cause of failure.+failMessage :: Monad m => Message -> CYT m a+failMessage msg = failMessages [msg]++-- |Failing action with a list of messages describing the cause(s) of failure.+failMessages :: Monad m => [Message] -> CYT m a+failMessages = lift . throwE++-- |Failing action with a source code span and a `String` indicating+-- the cause of failure.+failMessageAt :: Monad m => Span -> String -> CYT m a+failMessageAt sp s = failMessage $ spanMessage sp $ text s++-- |Warning with a message describing the cause of the warning.+warnMessage :: Monad m => Message -> CYT m ()+warnMessage msg = warnMessages [msg]++-- |Warning with a list of messages describing the cause(s) of the warnings.+warnMessages :: Monad m => [Message] -> CYT m ()+warnMessages msgs = tell msgs++-- |Execute a monadic action, but ignore any warnings it issues+silent :: Monad m => CYT m a -> CYT m a+silent act = censor (const []) act++-- |Warning with a source code position and a `String` indicating+-- the cause of the warning.+warnMessageAt :: Monad m => Span -> String -> CYT m ()+warnMessageAt sp s = warnMessage $ spanMessage sp $ text s++-- |Lift a value into the `CYT m` monad, same as `return`.+ok :: Monad m => a -> CYT m a+ok = return++-- |Lift a pure action into an action based on another monad.+liftCYM :: Monad m => CYM a -> CYT m a+liftCYM = mapWriterT (mapExceptT (return . runIdentity))
+ src/Curry/Base/Position.hs view
@@ -0,0 +1,128 @@+{- |+    Module      :  $Header$+    Description :  Positions in a source file+    Copyright   :  (c) Wolfgang Lux+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module implements a data type for positions in a source file and+    respective functions to operate on them. A source file position consists+    of a filename, a line number, and a column number. A tab stop is assumed+    at every eighth column.+-}+module Curry.Base.Position+  ( -- * Source code position+    HasPosition (..), Position (..), (@>)+  , showPosition, ppPosition, ppCompactLine, ppLine, showLine+  , first, next, incr, tab, tabWidth, nl+  ) where++import Prelude hiding ((<>))+import Data.Binary+import Control.Monad+import System.FilePath++import Curry.Base.Pretty++-- |Type class for entities which have a source code 'Position'+class HasPosition a where+  -- |Get the 'Position'+  getPosition :: a -> Position+  getPosition _ = NoPos++  -- |Set the 'Position'+  setPosition :: Position -> a -> a+  setPosition _ = id++-- | @x \@> y@ returns @x@ with the position obtained from @y@+(@>) :: (HasPosition a, HasPosition b) => a -> b -> a+x @> y = setPosition (getPosition y) x++-- |Source code positions+data Position+  -- |Normal source code position+  = Position+    { file   :: FilePath -- ^ 'FilePath' of the source file+    , line   :: Int      -- ^ line number, beginning at 1+    , column :: Int      -- ^ column number, beginning at 1+    }+  -- |no position+  | NoPos+    deriving (Eq, Ord, Read, Show)++instance HasPosition Position where+  getPosition = id+  setPosition = const++instance Pretty Position where+  pPrint = ppPosition++instance Binary Position where+  put (Position _ l c) = putWord8 0 >> put l >> put c+  put NoPos            = putWord8 1++  get = do+    x <- getWord8+    case x of+      0 -> liftM2 (Position "") get get+      1 -> return NoPos+      _ -> fail "Not a valid encoding for a Position"++-- |Show a 'Position' as a 'String'+showPosition :: Position -> String+showPosition = show . ppPosition++-- |Pretty print a 'Position'+ppPosition :: Position -> Doc+ppPosition p@(Position f _ _)+  | null f    = lineCol+  | otherwise = text (normalise f) <> comma <+> lineCol+  where lineCol = ppLine p+ppPosition _  = empty++-- |Pretty print a compact representation of a 'Position''s line/column+ppCompactLine :: Position -> Doc+ppCompactLine (Position _ l c) = text (show l)+                                 <> if c == 0 then empty else (colon <> text (show c))+ppCompactLine _ = empty++-- |Pretty print the line and column of a 'Position'+ppLine :: Position -> Doc+ppLine (Position _ l c) = text "line" <+> text (show l)+                          <> if c == 0 then empty else text ('.' : show c)+ppLine _                = empty++-- |Show the line and column of a 'Position'+showLine :: Position -> String+showLine = show . ppLine++-- | Absolute first position of a file+first :: FilePath -> Position+first fn = Position fn 1 1++-- |Next position to the right+next :: Position -> Position+next = flip incr 1++-- |Increment a position by a number of columns+incr :: Position -> Int -> Position+incr p@Position { column = c } n = p { column = c + n }+incr p _ = p++-- |Number of spaces for a tabulator+tabWidth :: Int+tabWidth = 8++-- |First position after the next tabulator+tab :: Position -> Position+tab p@Position { column = c }+  = p { column = c + tabWidth - (c - 1) `mod` tabWidth }+tab p = p++-- |First position of the next line+nl :: Position -> Position+nl p@Position { line = l } = p { line = l + 1, column = 1 }+nl p = p
+ src/Curry/Base/Pretty.hs view
@@ -0,0 +1,209 @@+{- |+    Module      :  $Header$+    Description :  Pretty printing+    Copyright   :  (c) 2013 - 2014 Björn Peemöller+                       2016        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  stable+    Portability :  portable++    This module re-exports the well known pretty printing combinators+    from Hughes and Peyton-Jones. In addition, it re-exports the type class+    'Pretty' for pretty printing arbitrary types.+-}+{-# LANGUAGE CPP #-}+module Curry.Base.Pretty+  ( module Curry.Base.Pretty+  , module Text.PrettyPrint+  ) where++import Prelude hiding ((<>))++import Text.PrettyPrint++-- | Pretty printing class.+-- The precedence level is used in a similar way as in the 'Show' class.+-- Minimal complete definition is either 'pPrintPrec' or 'pPrint'.+class Pretty a where+  -- | Pretty-print something in isolation.+  pPrint :: a -> Doc+  pPrint = pPrintPrec 0++  -- | Pretty-print something in a precedence context.+  pPrintPrec :: Int -> a -> Doc+  pPrintPrec _ = pPrint++  -- |Pretty-print a list.+  pPrintList :: [a] -> Doc+  pPrintList = brackets . fsep . punctuate comma . map (pPrintPrec 0)++#if __GLASGOW_HASKELL__ >= 707+  {-# MINIMAL pPrintPrec | pPrint #-}+#endif++-- | Pretty print a value to a 'String'.+prettyShow :: Pretty a => a -> String+prettyShow = render . pPrint++-- | Parenthesize an value if the boolean is true.+parenIf :: Bool -> Doc -> Doc+parenIf False = id+parenIf True  = parens++-- | Pretty print a value if the boolean is true+ppIf :: Bool -> Doc -> Doc+ppIf True  = id+ppIf False = const empty++-- | Pretty print a 'Maybe' value for the 'Just' constructor only+maybePP :: (a -> Doc) -> Maybe a -> Doc+maybePP = maybe empty++-- | A blank line.+blankLine :: Doc+blankLine = text ""++-- |Above with a blank line in between. If one of the documents is empty,+-- then the other document is returned.+($++$) :: Doc -> Doc -> Doc+d1 $++$ d2 | isEmpty d1 = d2+           | isEmpty d2 = d1+           | otherwise  = d1 $+$ blankLine $+$ d2++-- |Above with overlapping, but with a space in between. If one of the+-- documents is empty, then the other document is returned.+($-$) :: Doc -> Doc -> Doc+d1 $-$ d2 | isEmpty d1 = d2+          | isEmpty d2 = d1+          | otherwise  = d1 $$ space $$ d2++-- | Seperate a list of 'Doc's by a 'blankLine'.+sepByBlankLine :: [Doc] -> Doc+sepByBlankLine = foldr ($++$) empty++-- |A '.' character.+dot :: Doc+dot = char '.'++-- |Precedence of function application+appPrec :: Int+appPrec = 10++-- |A left arrow @<-@.+larrow :: Doc+larrow = text "<-"++-- |A right arrow @->@.+rarrow :: Doc+rarrow = text "->"++-- |A double arrow @=>@.+darrow :: Doc+darrow = text "=>"++-- |A back quote @`@.+backQuote :: Doc+backQuote = char '`'++-- |A backslash @\@.+backsl :: Doc+backsl = char '\\'++-- |A vertical bar @|@.+vbar :: Doc+vbar = char '|'++-- |Set a document in backquotes.+bquotes :: Doc -> Doc+bquotes doc = backQuote <> doc <> backQuote++-- |Set a document in backquotes if the condition is @True@.+bquotesIf :: Bool -> Doc -> Doc+bquotesIf b doc = if b then bquotes doc else doc++-- |Seperate a list of documents by commas+list :: [Doc] -> Doc+list = fsep . punctuate comma . filter (not . isEmpty)++-- | Instance for 'Int'+instance Pretty Int      where pPrint = int++-- | Instance for 'Integer'+instance Pretty Integer  where pPrint = integer++-- | Instance for 'Float'+instance Pretty Float    where pPrint = float++-- | Instance for 'Double'+instance Pretty Double   where pPrint = double++-- | Instance for '()'+instance Pretty ()       where pPrint _ = text "()"++-- | Instance for 'Bool'+instance Pretty Bool     where pPrint = text . show++-- | Instance for 'Ordering'+instance Pretty Ordering where pPrint = text . show++-- | Instance for 'Char'+instance Pretty Char where+  pPrint     = char+  pPrintList = text . show++-- | Instance for 'Maybe'+instance (Pretty a) => Pretty (Maybe a) where+  pPrintPrec _ Nothing  = text "Nothing"+  pPrintPrec p (Just x) = parenIf (p > appPrec)+                        $ text "Just" <+> pPrintPrec (appPrec + 1) x++-- | Instance for 'Either'+instance (Pretty a, Pretty b) => Pretty (Either a b) where+  pPrintPrec p (Left  x) = parenIf (p > appPrec)+                         $ text "Left" <+> pPrintPrec (appPrec + 1) x+  pPrintPrec p (Right x) = parenIf (p > appPrec)+                         $ text "Right" <+> pPrintPrec (appPrec + 1) x++-- | Instance for '[]'+instance (Pretty a) => Pretty [a] where+  pPrintPrec _ = pPrintList++-- | Instance for '(,)'+instance (Pretty a, Pretty b) => Pretty (a, b) where+  pPrintPrec _ (a, b) = parens $ fsep $ punctuate comma [pPrint a, pPrint b]++-- | Instance for '(,,)'+instance (Pretty a, Pretty b, Pretty c) => Pretty (a, b, c) where+  pPrintPrec _ (a, b, c) = parens $ fsep $ punctuate comma+    [pPrint a, pPrint b, pPrint c]++-- | Instance for '(,,,)'+instance (Pretty a, Pretty b, Pretty c, Pretty d) => Pretty (a, b, c, d) where+  pPrintPrec _ (a, b, c, d) = parens $ fsep $ punctuate comma+    [pPrint a, pPrint b, pPrint c, pPrint d]++-- | Instance for '(,,,,)'+instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e)+  => Pretty (a, b, c, d, e) where+  pPrintPrec _ (a, b, c, d, e) = parens $ fsep $ punctuate comma+    [pPrint a, pPrint b, pPrint c, pPrint d, pPrint e]++-- | Instance for '(,,,,,)'+instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f)+  => Pretty (a, b, c, d, e, f) where+  pPrintPrec _ (a, b, c, d, e, f) = parens $ fsep $ punctuate comma+    [pPrint a, pPrint b, pPrint c, pPrint d, pPrint e, pPrint f]++-- | Instance for '(,,,,,,)'+instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g)+  => Pretty (a, b, c, d, e, f, g) where+  pPrintPrec _ (a, b, c, d, e, f, g) = parens $ fsep $ punctuate comma+    [pPrint a, pPrint b, pPrint c, pPrint d, pPrint e, pPrint f, pPrint g]++-- | Instance for '(,,,,,,,)'+instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h)+  => Pretty (a, b, c, d, e, f, g, h) where+  pPrintPrec _ (a, b, c, d, e, f, g, h) = parens $ fsep $ punctuate comma+    [pPrint a, pPrint b, pPrint c, pPrint d, pPrint e, pPrint f, pPrint g, pPrint h]
+ src/Curry/Base/Span.hs view
@@ -0,0 +1,180 @@+{- |+    Module      :  $Header$+    Description :  Spans in a source file+    Copyright   :  (c) 2016 Jan Tikovsky+                       2016 Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  jrt@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module implements a data type for span information in a source file and+    respective functions to operate on them. A source file span consists+    of a filename, a start position and an end position.++    In addition, the type 'SrcRef' identifies the path to an expression in+    the abstract syntax tree by argument positions, which is used for+    debugging purposes.+-}+module Curry.Base.Span where++import Prelude hiding ((<>))++import Data.Binary+import Data.List (transpose)+import Control.Monad+import System.FilePath++import Curry.Base.Position hiding (file)+import Curry.Base.Pretty++data Span+  -- |Normal source code span+  = Span+    { file     :: FilePath -- ^ 'FilePath' of the source file+    , start    :: Position -- ^ start position+    , end      :: Position -- ^ end position+    }+  -- |no span+  | NoSpan+    deriving (Eq, Ord, Read, Show)++instance Pretty Span where+  pPrint = ppSpan++instance HasPosition Span where+  setPosition p NoSpan       = Span "" p NoPos+  setPosition p (Span f _ e) = Span f p e++  getPosition NoSpan       = NoPos+  getPosition (Span _ p _) = p++instance Binary Span where+  put (Span _ s e) = putWord8 0 >> put s >> put e+  put NoSpan       = putWord8 1++  get = do+    x <- getWord8+    case x of+      0 -> liftM2 (Span "") get get+      1 -> return NoSpan+      _ -> fail "Not a valid encoding for a Span"++-- |Show a 'Span' as a 'String'+showSpan :: Span -> String+showSpan = show . ppSpan++-- |Pretty print a 'Span'+ppSpan :: Span -> Doc+ppSpan s@(Span f _ _)+  | null f    = startEnd+  | otherwise = text (normalise f) <> comma <+> startEnd+  where startEnd = ppPositions s+ppSpan _ = empty++-- |Pretty print a span with it's file path and position compactly.+ppCompactSpan :: Span -> Doc+ppCompactSpan s@(Span f _ _)+  | null f    = ppCompactPositions s+  | otherwise = text (normalise f) <> colon <> ppCompactPositions s+ppCompactSpan _ = empty++-- |Pretty print a source preview of a span+ppSpanPreview :: Span -> IO Doc+ppSpanPreview (Span f (Position _ sl sc) (Position _ el ec))+  | null f    = return empty+  | otherwise = do+      fileContents <- readFile f++      let lns = lines fileContents+          lnContent | sl <= 0 || sl > length lns = ""+                    | otherwise = lns !! (sl - 1)+          lnNum = text <$> lPadStr lnNumWidth <$> (vPad ++ [show sl] ++ vPad)+          ec' = if isMultiline then length lnContent else ec+          gutter = text <$> replicate (1 + 2 * vPadCount) "|"+          highlight = replicate (sc - 1) ' ' ++ replicate (1 + ec' - sc) '^' ++ if isMultiline then "..." else ""+          previews = text <$> (vPad ++ [lnContent, highlight] ++ replicate (vPadCount - 1) "")+      +      return $ vcat $ map hsep $ transpose [lnNum, gutter, previews]+  where vPadCount = 1 -- Number of padding lines at the top and bottom+        isMultiline = el - sl > 0+        numWidth = length . show+        lnNumWidth = 1 + numWidth el+        vPad = replicate vPadCount ""+        lPadStr n s = replicate (n - length s) ' ' ++ s+ppSpanPreview _ = return empty++-- |Pretty print the positions compactly.+ppCompactPositions :: Span -> Doc+ppCompactPositions (Span _ s e) | s == e    = ppCompactLine s+                                | otherwise = ppCompactLine s <> text "-" <> ppCompactLine e+ppCompactPositions _            = empty++-- |Pretty print the start and end position of a 'Span'+ppPositions :: Span -> Doc+ppPositions (Span _ s e) =  text "startPos:" <+> ppLine s <> comma+                        <+> text "endPos:"   <+> ppLine e+ppPositions _            = empty++fstSpan :: FilePath -> Span+fstSpan fn = Span fn (first fn) (first fn)++-- |Compute the column of the start position of a 'Span'+startCol :: Span -> Int+startCol (Span _ p _) = column p+startCol _            = 0++nextSpan :: Span -> Span+nextSpan sp = incrSpan sp 1++incrSpan :: Span -> Int -> Span+incrSpan (Span fn s e) n = Span fn (incr s n) (incr e n)+incrSpan sp            _ = sp++-- TODO: Rename to tab and nl as soon as positions are completely replaced by spans++-- |Convert a position to a single character span.+pos2Span :: Position -> Span+pos2Span p@(Position f _ _) = Span f p p+pos2Span _                  = NoSpan++-- |Convert a span to a (start) position+-- TODO: This function should be removed as soon as positions are completely replaced by spans+-- in the frontend+span2Pos :: Span -> Position+span2Pos (Span _ p _) = p+span2Pos NoSpan       = NoPos++combineSpans :: Span -> Span -> Span+combineSpans sp1 sp2 = Span f s e+  where s = start sp1+        e = end sp2+        f = file sp1++-- |First position after the next tabulator+tabSpan :: Span -> Span+tabSpan (Span fn s e) = Span fn (tab s) (tab e)+tabSpan sp            = sp++-- |First position of the next line+nlSpan :: Span -> Span+nlSpan (Span fn s e) = Span fn (nl s) (nl e)+nlSpan sp            = sp++addSpan :: Span -> (a, [Span]) -> (a, [Span])+addSpan sp (a, ss) = (a, sp:ss)++-- |Distance of a span, i.e. the line and column distance between start+-- and end position+type Distance = (Int, Int)++-- |Set the distance of a span, i.e. update its end position+setDistance :: Span -> Distance -> Span+setDistance (Span fn p _) d = Span fn p (p `moveBy` d)+setDistance s             _ = s++-- |Move position by given distance+moveBy :: Position -> Distance -> Position+moveBy (Position fn l c) (ld, cd) = Position fn (l + ld) (c + cd)+moveBy p                 _        = p
+ src/Curry/Base/SpanInfo.hs view
@@ -0,0 +1,139 @@+{- |+    Module      :  $Header$+    Description :  SpansInfo for entities+    Copyright   :  (c) 2017 Kai-Oliver Prott+    License     :  BSD-3-clause++    Maintainer  :  fte@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module implements a data type for span information for entities from a+    source file and function to operate on them. A span info consists of the+    span of the entity and a list of sub-spans whith additional information+    about location of keywords, e.g.+-}+module Curry.Base.SpanInfo+  ( SpanInfo(..), spanInfo, LayoutInfo(..), HasSpanInfo(..)+  , fromSrcSpan, fromSrcSpanBoth, getSrcSpan, setSrcSpan, spanInfoLike+  , fromSrcInfoPoints, getSrcInfoPoints, setSrcInfoPoints+  , getStartPosition, getSrcSpanEnd, setStartPosition, setEndPosition+  , spanInfo2Pos+  ) where++import Data.Binary+import Control.Monad++import Curry.Base.Position+import Curry.Base.Span++data SpanInfo = SpanInfo+    { srcSpan        :: Span+    , srcInfoPoints  :: [Span]+    }+    | NoSpanInfo+  deriving (Eq, Ord, Read, Show)++spanInfo :: Span -> [Span] -> SpanInfo+spanInfo sp sps = SpanInfo sp sps++data LayoutInfo = ExplicitLayout [Span]+                | WhitespaceLayout+  deriving (Eq, Read, Show)++class HasPosition a => HasSpanInfo a where++  getSpanInfo :: a -> SpanInfo++  setSpanInfo :: SpanInfo -> a -> a++  updateEndPos :: a -> a+  updateEndPos = id++  getLayoutInfo :: a -> LayoutInfo+  getLayoutInfo = const WhitespaceLayout++instance HasSpanInfo SpanInfo where+  getSpanInfo = id+  setSpanInfo = const++instance HasPosition SpanInfo where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance Binary SpanInfo where+  put (SpanInfo sp ss) = putWord8 0 >> put sp >> put ss+  put NoSpanInfo       = putWord8 1++  get = do+    x <- getWord8+    case x of+      0 -> liftM2 SpanInfo get get+      1 -> return NoSpanInfo+      _ -> fail "Not a valid encoding for a SpanInfo"++instance Binary LayoutInfo where+  put (ExplicitLayout ss) = putWord8 0 >> put ss+  put WhitespaceLayout = putWord8 1++  get = do+    x <- getWord8+    case x of+      0 -> fmap ExplicitLayout get+      1 -> return WhitespaceLayout+      _ -> fail "Not a valid encoding for a LayoutInfo"++fromSrcSpan :: Span -> SpanInfo+fromSrcSpan sp = SpanInfo sp []++fromSrcSpanBoth :: Span -> SpanInfo+fromSrcSpanBoth sp = SpanInfo sp [sp]++getSrcSpan :: HasSpanInfo a => a -> Span+getSrcSpan a = case getSpanInfo a of+  NoSpanInfo   -> NoSpan+  SpanInfo s _ -> s++setSrcSpan :: HasSpanInfo a => Span -> a -> a+setSrcSpan s a = case getSpanInfo a of+  NoSpanInfo     -> setSpanInfo (SpanInfo s [] ) a+  SpanInfo _ inf -> setSpanInfo (SpanInfo s inf) a++fromSrcInfoPoints :: [Span] -> SpanInfo+fromSrcInfoPoints = SpanInfo NoSpan++getSrcInfoPoints :: HasSpanInfo a => a -> [Span]+getSrcInfoPoints a = case getSpanInfo a of+  NoSpanInfo    -> []+  SpanInfo _ xs -> xs++setSrcInfoPoints :: HasSpanInfo a => [Span] -> a -> a+setSrcInfoPoints inf a = case getSpanInfo a of+  NoSpanInfo    -> setSpanInfo (SpanInfo NoSpan inf) a+  SpanInfo s _  -> setSpanInfo (SpanInfo s      inf) a++getStartPosition :: HasSpanInfo a => a -> Position+getStartPosition a =  case getSrcSpan a of+  NoSpan     -> NoPos+  Span _ s _ -> s++getSrcSpanEnd :: HasSpanInfo a => a -> Position+getSrcSpanEnd a = case getSpanInfo a of+  NoSpanInfo   -> NoPos+  SpanInfo s _ -> end s++setStartPosition :: HasSpanInfo a => Position -> a -> a+setStartPosition p a = case getSrcSpan a of+  NoSpan     -> setSrcSpan (Span "" p NoPos) a+  Span f _ e -> setSrcSpan (Span f  p     e) a++setEndPosition :: HasSpanInfo a => Position -> a -> a+setEndPosition e a = case getSrcSpan a of+  NoSpan     -> setSrcSpan (Span "" NoPos e) a+  Span f p _ -> setSrcSpan (Span f  p     e) a++spanInfo2Pos :: HasSpanInfo a => a -> Position+spanInfo2Pos = getStartPosition++spanInfoLike :: (HasSpanInfo a, HasSpanInfo b) => a -> b -> a+spanInfoLike a b = setSpanInfo (getSpanInfo b) a
+ src/Curry/CondCompile/Parser.hs view
@@ -0,0 +1,90 @@+{- |+    Module      :  $Header$+    Description :  Parser for conditional compiling+    Copyright   :  (c) 2017        Kai-Oliver Prott+                       2017        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  fte@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    TODO+-}+{-# LANGUAGE CPP #-}+module Curry.CondCompile.Parser where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>), (<*>), (*>), (<*))+#endif++import Text.Parsec++import Curry.CondCompile.Type++type Parser a = Parsec String () a++program :: Parser Program+program = statement `sepBy` eol <* eof++statement :: Parser Stmt+statement =  ifElse "if" condition If+         <|> ifElse "ifdef" identifier IfDef+         <|> ifElse "ifndef" identifier IfNDef+         <|> define+         <|> undef+         <|> line++ifElse :: String -> Parser a -> (a -> [Stmt] -> [Elif] -> Else -> Stmt)+       -> Parser Stmt+ifElse k p c = c <$> (try (many sp *> keyword k *> many1 sp) *> p <* many sp <* eol)+                 <*> many (statement <* eol)+                 <*> many (Elif <$> ((,) <$> (try (many sp *> keyword "elif" *> many1 sp) *> condition <* many sp <* eol)+                                         <*> many (statement <* eol)))+                 <*> (Else <$> optionMaybe+                                 (try (many sp *> keyword "else" *> many sp) *> eol *> many (statement <* eol)))+                 <*  try (many sp <* keyword "endif" <* many sp)++define :: Parser Stmt+define = Define <$> (try (many sp *> keyword "define" *> many1 sp) *> identifier <* many1 sp)+                <*> value <* many sp++undef :: Parser Stmt+undef = Undef <$> (try (many sp *> keyword "undef" *> many1 sp) *> identifier <* many sp)++line :: Parser Stmt+line = do+  sps <- many sp+  try $  ((char '#' <?> "") *> fail "unknown directive")+     <|> ((Line . (sps ++)) <$> manyTill anyChar (try (lookAhead (eol <|> eof))))++keyword :: String -> Parser String+keyword = string . ('#' :)++condition :: Parser Cond+condition =  (Defined  <$> (try (string  "defined(") *> many sp *> identifier <* many sp <* char ')'))+         <|> (NDefined <$> (try (string "!defined(") *> many sp *> identifier <* many sp <* char ')'))+         <|> (Comp <$> (identifier <* many sp) <*> operator <*> (many sp *> value) <?> "condition")++identifier :: Parser String+identifier = (:) <$> firstChar <*> many (firstChar <|> digit) <?> "identifier"+  where firstChar = letter <|> char '_'++operator :: Parser Op+operator = choice [ Leq <$ try (string "<=")+                  , Lt  <$ try (string "<")+                  , Geq <$ try (string ">=")+                  , Gt  <$ try (string ">")+                  , Neq <$ try (string "!=")+                  , Eq  <$ string "=="+                  ] <?> "operator"++value :: Parser Int+value = fmap read (many1 digit)++eol :: Parser ()+eol = endOfLine *> return ()++sp :: Parser Char+sp = try $  lookAhead (eol *> unexpected "end of line" <?> "")+        <|> space
+ src/Curry/CondCompile/Transform.hs view
@@ -0,0 +1,116 @@+{- |+    Module      :  $Header$+    Description :  Conditional compiling transformation+    Copyright   :  (c) 2017        Kai-Oliver Prott+                       2017        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  fte@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    TODO+-}+module Curry.CondCompile.Transform (condTransform) where++import           Control.Monad.State+import           Control.Monad.Extra        (concatMapM)+import qualified Data.Map            as Map+import           Data.Maybe                 (fromMaybe)+import           Text.Parsec                             hiding (State)+import           Text.Parsec.Error          ()++import Curry.Base.Message+import Curry.Base.Position+import Curry.Base.Pretty++import Curry.CondCompile.Parser+import Curry.CondCompile.Type++type CCState = Map.Map String Int++type CCM = State CCState++condTransform :: CCState -> FilePath -> String -> Either Message String+condTransform s fn p = either (Left . convertError)+                              (Right . transformWith s)+                              (parse program fn p)++transformWith :: CCState -> Program -> String+transformWith s p = show $ pPrint $ evalState (transform p) s++convertError :: ParseError -> Message+convertError err = posMessage pos $+  foldr ($+$) empty $ map text $ tail $ lines $ show err+  where pos = Position (sourceName src) (sourceLine src) (sourceColumn src)+        src = errorPos err++class CCTransform a where+  transform :: a -> CCM [Stmt]++instance CCTransform Stmt where+  transform (Line              s) = return [Line s]+  transform (If     c stmts is e) = do+    s <- get+    if checkCond c s+      then do stmts' <- transform stmts+              return (blank : stmts' ++ fill is ++ fill e ++ [blank])+      else case is of+             []                        -> do+               stmts' <- transform e+               return (blank : fill stmts ++ stmts' ++ [blank])+             (Elif (c', stmts') : is') -> do+               stmts'' <- transform (If c' stmts' is' e)+               return (blank : fill stmts ++ stmts'')+  transform (IfDef  v stmts is e) = transform (If (Defined  v) stmts is e)+  transform (IfNDef v stmts is e) = transform (If (NDefined v) stmts is e)+  transform (Define          v i) = modify (Map.insert v i) >> return [blank]+  transform (Undef           v  ) = modify (Map.delete v) >> return [blank]++instance CCTransform a => CCTransform [a] where+  transform = concatMapM transform++instance CCTransform Else where+  transform (Else (Just p)) = (blank :) <$> transform p+  transform (Else Nothing ) = return []++checkCond :: Cond -> CCState -> Bool+checkCond (Comp v op i) = flip (compareOp op) i . fromMaybe 0 . Map.lookup v+checkCond (Defined   v) = Map.member v+checkCond (NDefined  v) = Map.notMember v++compareOp :: Ord a => Op -> a -> a -> Bool+compareOp Eq  = (==)+compareOp Neq = (/=)+compareOp Lt  = (<)+compareOp Leq = (<=)+compareOp Gt  = (>)+compareOp Geq = (>=)++class FillLength a where+  fillLength :: a -> Int++instance FillLength Stmt where+  fillLength (Line   _           ) = 1+  fillLength (Define _ _         ) = 1+  fillLength (Undef  _           ) = 1+  fillLength (If     _ stmts is e) =+    3 + fillLength stmts + fillLength e + fillLength is+  fillLength (IfDef  v stmts is e) = fillLength (If (Defined  v) stmts is e)+  fillLength (IfNDef v stmts is e) = fillLength (If (NDefined v) stmts is e)++instance FillLength a => FillLength [a] where+  fillLength = foldr ((+) . fillLength) 0++instance FillLength Else where+  fillLength (Else (Just stmts)) = 1 + fillLength stmts+  fillLength (Else Nothing     ) = 0++instance FillLength Elif where+  fillLength (Elif (_, stmts)) = 1 + fillLength stmts++fill :: FillLength a => a -> [Stmt]+fill p = replicate (fillLength p) blank++blank :: Stmt+blank = Line ""
+ src/Curry/CondCompile/Type.hs view
@@ -0,0 +1,88 @@+{- |+    Module      :  $Header$+    Description :  Abstract syntax for conditional compiling+    Copyright   :  (c) 2017        Kai-Oliver Prott+                       2017        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  fte@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    TODO+-}+{-# LANGUAGE CPP #-}+module Curry.CondCompile.Type+  ( Program, Stmt (..), Else (..), Elif (..), Cond (..), Op (..)+  ) where++#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif++import Curry.Base.Pretty++type Program = [Stmt]++data Stmt = If Cond [Stmt] [Elif] Else+          | IfDef String [Stmt] [Elif] Else+          | IfNDef String [Stmt] [Elif] Else+          | Define String Int+          | Undef String+          | Line String+  deriving Show++newtype Else = Else (Maybe [Stmt])+  deriving Show++newtype Elif = Elif (Cond, [Stmt])+  deriving Show++data Cond = Comp String Op Int+          | Defined String+          | NDefined String+  deriving Show++data Op = Eq+        | Neq+        | Lt+        | Leq+        | Gt+        | Geq+  deriving Show++instance Pretty Stmt where+  pPrint (If     c stmts is e) = prettyIf "#if"     (pPrint c) stmts is e+  pPrint (IfDef  v stmts is e) = prettyIf "#ifdef"  (text v)   stmts is e+  pPrint (IfNDef v stmts is e) = prettyIf "#ifndef" (text v)   stmts is e+  pPrint (Define v i         ) = text "#define" <+> text v <+> int i+  pPrint (Undef  v           ) = text "#undef"  <+> text v+  pPrint (Line   s           ) = text s++  pPrintList = foldr (($+$) . pPrint) empty++instance Pretty Elif where+  pPrint (Elif (c, stmts)) = text "#elif" <+> pPrint c $+$ pPrint stmts++  pPrintList = foldr (($+$) . pPrint) empty++instance Pretty Else where+  pPrint (Else (Just stmts)) = text "#else" $+$ pPrint stmts+  pPrint (Else Nothing)      = empty++prettyIf :: String -> Doc -> [Stmt] -> [Elif] -> Else -> Doc+prettyIf k doc stmts is e = foldr ($+$) empty+  [text k <+> doc, pPrint stmts, pPrint is, pPrint e, text "#endif"]++instance Pretty Cond where+  pPrint (Comp v op i) = text v <+> pPrint op <+> int i+  pPrint (Defined  v ) = text "defined("  <> text v <> char ')'+  pPrint (NDefined v ) = text "!defined(" <> text v <> char ')'++instance Pretty Op where+  pPrint Eq  = text "=="+  pPrint Neq = text "/="+  pPrint Lt  = text "<"+  pPrint Leq = text "<="+  pPrint Gt  = text ">"+  pPrint Geq = text ">="
− src/Curry/Files/CymakePath.hs 
@@ -1,15 +0,0 @@-module Curry.Files.CymakePath (getCymake,cymakeVersion) where--import Data.Version-import System.FilePath-import Paths_curry_frontend---- | Retrieve the version number of cymake-cymakeVersion :: String-cymakeVersion = showVersion version---- | Retrieve the location of the cymake executable-getCymake :: IO String-getCymake     = do-  cymakeDir <- getBinDir-  return (cymakeDir </> "cymake")
+ src/Curry/Files/Filenames.hs view
@@ -0,0 +1,256 @@+{- |+    Module      :  $Header$+    Description :  File names for several intermediate file formats.+    Copyright   :  (c) 2009        Holger Siegel+                       2013 - 2014 Björn Peemöller+                       2018        Kai-Oliver Prott+    License     :  BSD-3-clause++    Maintainer  :  fte@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    The functions in this module were collected from several compiler modules+    in order to provide a unique accessing point for this functionality.+-}+module Curry.Files.Filenames+  ( -- * Re-exports from 'System.FilePath'+    FilePath, takeBaseName, dropExtension, takeExtension, takeFileName++    -- * Conversion between 'ModuleIdent' and 'FilePath'+  , moduleNameToFile, fileNameToModule, splitModuleFileName, isCurryFilePath++    -- * Curry sub-directory+  , defaultOutDir, hasOutDir, addOutDir, addOutDirModule+  , ensureOutDir++    -- * File name extensions+    -- ** Curry files+  , curryExt, lcurryExt, icurryExt++    -- ** FlatCurry files+  , annotatedFlatExt, typedFlatExt, flatExt, flatIntExt++    -- ** AbstractCurry files+  , acyExt, uacyExt++    -- ** Source and object files+  , sourceRepExt, sourceExts, moduleExts++    -- * Functions for computing file names+  , interfName, typedFlatName, annotatedFlatName, flatName, flatIntName+  , acyName, uacyName, sourceRepName, tokensName, commentsName+  , astName, shortASTName, htmlName+  ) where++import System.FilePath++import Curry.Base.Ident++-- -----------------------------------------------------------------------------+-- Conversion between ModuleIdent and FilePath+-- -----------------------------------------------------------------------------++-- |Create a 'FilePath' from a 'ModuleIdent' using the hierarchical module+-- system+moduleNameToFile :: ModuleIdent -> FilePath+moduleNameToFile = foldr1 (</>) . midQualifiers++-- |Extract the 'ModuleIdent' from a 'FilePath'+fileNameToModule :: FilePath -> ModuleIdent+fileNameToModule = mkMIdent . splitDirectories . dropExtension . dropDrive++-- |Split a 'FilePath' into a prefix directory part and those part that+-- corresponds to the 'ModuleIdent'. This is especially useful for+-- hierarchically module names.+splitModuleFileName :: ModuleIdent -> FilePath -> (FilePath, FilePath)+splitModuleFileName m fn = case midQualifiers m of+  [_] -> splitFileName fn+  ms  -> let (base, ext) = splitExtension fn+             dirs        = splitDirectories base+             (pre, suf)  = splitAt (length dirs - length ms) dirs+             path        = if null pre then ""+                                       else addTrailingPathSeparator (joinPath pre)+         in  (path, joinPath suf <.> ext)++-- |Checks whether a 'String' represents a 'FilePath' to a Curry module+isCurryFilePath :: String -> Bool+isCurryFilePath str =  isValid str+                    && takeExtension str `elem` ("" : moduleExts)++-- -----------------------------------------------------------------------------+-- Curry sub-directory+-- -----------------------------------------------------------------------------++-- |The standard hidden subdirectory for curry files+defaultOutDir :: String+defaultOutDir = ".curry"++-- |Does the given 'FilePath' contain the 'outDir'+-- as its last directory component?+hasOutDir :: String -> FilePath -> Bool+hasOutDir outDir f = not (null dirs) && last dirs == outDir+  where dirs = splitDirectories $ takeDirectory f++-- |Add the 'outDir' to the given 'FilePath' if the flag is 'True' and+-- the path does not already contain it, otherwise leave the path untouched.+addOutDir :: Bool -> String -> FilePath -> FilePath+addOutDir b outDir fn = if b then ensureOutDir outDir fn else fn++-- |Add the 'outDir' to the given 'FilePath' if the flag is 'True' and+-- the path does not already contain it, otherwise leave the path untouched.+addOutDirModule :: Bool -> String -> ModuleIdent -> FilePath -> FilePath+addOutDirModule b outDir m fn+  | b         = let (pre, file) = splitModuleFileName m fn+                in  ensureOutDir outDir pre </> file+  | otherwise = fn++-- | Ensure that the 'outDir' is the last component of the+-- directory structure of the given 'FilePath'. If the 'FilePath' already+-- contains the sub-directory, it remains unchanged.+ensureOutDir :: String   -- ^ the 'outDir'+             -> FilePath -- ^ original 'FilePath'+             -> FilePath -- ^ new 'FilePath'+ensureOutDir outDir fn = normalise $ addSub (splitDirectories d) </> f+  where+  (d, f) = splitFileName fn+  addSub dirs | null dirs           = outDir+              | last dirs == outDir = joinPath dirs+              | otherwise           = joinPath dirs </> outDir++-- -----------------------------------------------------------------------------+-- File name extensions+-- -----------------------------------------------------------------------------++-- |Filename extension for non-literate curry files+curryExt :: String+curryExt = ".curry"++-- |Filename extension for literate curry files+lcurryExt :: String+lcurryExt = ".lcurry"++-- |Filename extension for curry interface files+icurryExt :: String+icurryExt = ".icurry"++-- |Filename extension for curry source files.+--+-- /Note:/ The order of the extensions defines the order in which source files+-- should be searched for, i.e. given a module name @M@, the search order+-- should be the following:+--+-- 1. @M.curry@+-- 2. @M.lcurry@+--+sourceExts :: [String]+sourceExts = [curryExt, lcurryExt]++-- |Filename extension for curry module files+-- TODO: Is the order correct?+moduleExts :: [String]+moduleExts = sourceExts ++ [icurryExt]++-- |Filename extension for typed flat-curry files+typedFlatExt :: String+typedFlatExt = ".tfcy"++-- |Filename extension for type-annotated flat-curry files+annotatedFlatExt :: String+annotatedFlatExt = ".tafcy"++-- |Filename extension for flat-curry files+flatExt :: String+flatExt = ".fcy"++-- |Filename extension for extended-flat-curry interface files+flatIntExt :: String+flatIntExt = ".fint"++-- |Filename extension for abstract-curry files+acyExt :: String+acyExt = ".acy"++-- |Filename extension for untyped-abstract-curry files+uacyExt :: String+uacyExt = ".uacy"++-- |Filename extension for curry source representation files+sourceRepExt :: String+sourceRepExt = ".cy"++-- |Filename extension for token files+tokensExt :: String+tokensExt = ".tokens"++-- |Filename extension for comment token files+commentsExt :: String+commentsExt = ".cycom"++-- |Filename extension for AST files+astExt :: String+astExt = ".ast"++-- |Filename extension for shortened AST files+shortASTExt :: String+shortASTExt = ".sast"++-- ---------------------------------------------------------------------------+-- Computation of file names for a given source file+-- ---------------------------------------------------------------------------++-- |Compute the filename of the interface file for a source file+interfName :: FilePath -> FilePath+interfName = replaceExtensionWith icurryExt++-- |Compute the filename of the typed flat curry file for a source file+typedFlatName :: FilePath -> FilePath+typedFlatName = replaceExtensionWith typedFlatExt++-- |Compute the filename of the typed flat curry file for a source file+annotatedFlatName :: FilePath -> FilePath+annotatedFlatName = replaceExtensionWith annotatedFlatExt++-- |Compute the filename of the flat curry file for a source file+flatName :: FilePath -> FilePath+flatName = replaceExtensionWith flatExt++-- |Compute the filename of the flat curry interface file for a source file+flatIntName :: FilePath -> FilePath+flatIntName = replaceExtensionWith flatIntExt++-- |Compute the filename of the abstract curry file for a source file+acyName :: FilePath -> FilePath+acyName = replaceExtensionWith acyExt++-- |Compute the filename of the untyped abstract curry file for a source file+uacyName :: FilePath -> FilePath+uacyName = replaceExtensionWith uacyExt++-- |Compute the filename of the source representation file for a source file+sourceRepName :: FilePath -> FilePath+sourceRepName = replaceExtensionWith sourceRepExt++-- |Compute the filename of the tokens file for a source file+tokensName :: FilePath -> FilePath+tokensName = replaceExtensionWith tokensExt++-- |Compute the filename of the comment tokens file for a source file+commentsName :: FilePath -> FilePath+commentsName = replaceExtensionWith commentsExt++-- |Compute the filename of the ast file for a source file+astName :: FilePath -> FilePath+astName = replaceExtensionWith astExt++-- |Compute the filename of the ast file for a source file+shortASTName :: FilePath -> FilePath+shortASTName = replaceExtensionWith shortASTExt++-- |Compute the filename of the HTML file for a source file+htmlName :: ModuleIdent -> String+htmlName m = moduleName m ++ "_curry.html"++-- |Replace a filename extension with a new extension+replaceExtensionWith :: String -> FilePath -> FilePath+replaceExtensionWith = flip replaceExtension
+ src/Curry/Files/PathUtils.hs view
@@ -0,0 +1,206 @@+{- |+    Module      :  $Header$+    Description :  Utility functions for reading and writing files+    Copyright   :  (c) 1999 - 2003, Wolfgang Lux+                       2011 - 2014, Björn Peemöller (bjp@informatik.uni-kiel.de)+                       2017       , Finn Teegen (fte@informatik.uni-kiel.de)+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable+-}++{-# LANGUAGE CPP #-}++module Curry.Files.PathUtils+  ( -- * Retrieving curry files+    lookupCurryFile+  , lookupCurryModule+  , lookupCurryInterface+  , lookupFile++    -- * Reading and writing modules from files+  , getModuleModTime+  , writeModule+  , readModule+  , writeBinaryModule+  , addVersion+  , checkVersion+  ) where++import qualified Control.Exception    as C (IOException, handle)+import           Control.Monad             (liftM)+import           Data.List                 (isPrefixOf, isSuffixOf)+import qualified Data.ByteString.Lazy as B (ByteString, writeFile)+import           System.FilePath+import           System.Directory+import           System.IO++#if MIN_VERSION_directory(1,2,0)+import Data.Time                        (UTCTime)+#else+import System.Time                      (ClockTime)+#endif++import Curry.Base.Ident+import Curry.Files.Filenames++-- ---------------------------------------------------------------------------+-- Searching for files+-- ---------------------------------------------------------------------------++-- |Search in the given list of paths for the given 'FilePath' and eventually+-- return the file name of the found file.+--+-- - If the file name already contains a directory, then the paths to search+--   in are ignored.+-- - If the file name has no extension, then a source file extension is+--   assumed.+lookupCurryFile :: [FilePath] -> FilePath -> IO (Maybe FilePath)+lookupCurryFile paths fn = lookupFile paths exts fn+  where+  exts  | null fnExt = sourceExts+        | otherwise  = [fnExt]+  fnExt              = takeExtension fn++-- |Search for a given curry module in the given source file and+-- library paths. Note that the current directory is always searched first.+-- Returns the path of the found file.+lookupCurryModule :: [FilePath]          -- ^ list of paths to source files+                  -> [FilePath]          -- ^ list of paths to library files+                  -> ModuleIdent         -- ^ module identifier+                  -> IO (Maybe FilePath)+lookupCurryModule paths libPaths m =+  lookupFile (paths ++ libPaths) moduleExts (moduleNameToFile m)++-- |Search for an interface file in the import search path using the+-- interface extension 'icurryExt'. Note that the current directory is+-- always searched first.+lookupCurryInterface :: [FilePath]          -- ^ list of paths to search in+                     -> ModuleIdent         -- ^ module identifier+                     -> IO (Maybe FilePath) -- ^ the file path if found+lookupCurryInterface paths m = lookupFile paths [icurryExt] (moduleNameToFile m)++-- |Search in the given directories for the file with the specified file+-- extensions and eventually return the 'FilePath' of the file.+lookupFile :: [FilePath]          -- ^ Directories to search in+           -> [String]            -- ^ Accepted file extensions+           -> FilePath            -- ^ Initial file name+           -> IO (Maybe FilePath) -- ^ 'FilePath' of the file if found+lookupFile paths exts file = lookup' files+  where+  files     = [ normalise (p </> f) | p <- paths, f <- baseNames ]+  baseNames = map (replaceExtension file) exts++  lookup' []       = return Nothing+  lookup' (f : fs) = do+    exists <- doesFileExist f+    if exists then return (Just f) else lookup' fs++-- ---------------------------------------------------------------------------+-- Reading and writing files+-- ---------------------------------------------------------------------------++-- | Write the content to a file in the given directory.+writeModule :: FilePath -- ^ original path+            -> String   -- ^ file content+            -> IO ()+writeModule fn contents = do+  createDirectoryIfMissing True $ takeDirectory fn+  tryWriteFile fn contents++-- | Write the content in binary to a file in the given directory.+writeBinaryModule :: FilePath -- ^ original path+                  -> B.ByteString   -- ^ file content+                  -> IO ()+writeBinaryModule fn contents = do+  createDirectoryIfMissing True $ takeDirectory fn+  tryWriteBinaryFile (fn ++ "-bin") contents++-- | Read the specified module and returns either 'Just String' if+-- reading was successful or 'Nothing' otherwise.+readModule :: FilePath -> IO (Maybe String)+readModule = tryOnExistingFile readFileUTF8+ where+  readFileUTF8 :: FilePath -> IO String+  readFileUTF8 fn = do+    hdl <- openFile fn ReadMode+    hSetEncoding hdl utf8+    hGetContents hdl++-- | Get the modification time of a file, if existent+#if MIN_VERSION_directory(1,2,0)+getModuleModTime :: FilePath -> IO (Maybe UTCTime)+#else+getModuleModTime :: FilePath -> IO (Maybe ClockTime)+#endif+getModuleModTime = tryOnExistingFile getModificationTime++-- |Add the given version string to the file content+addVersion :: String -> String -> String+addVersion v content = "{- " ++ v ++ " -}\n" ++ content++-- |Check a source file for the given version string+checkVersion :: String -> String -> Either String String+checkVersion expected src = case lines src of+  [] -> Left "empty file"+  (l:ls) -> case getVersion l of+    Just v | v == expected -> Right (unlines ls)+           | otherwise     -> Left $ "Expected version `" ++ expected+                                     ++ "', but found version `" ++ v ++ "'"+    _                      -> Left $ "No version found"++  where+    getVersion s | "{- " `isPrefixOf` s && " -}" `isSuffixOf` s+                 = Just (reverse $ drop 3 $ reverse $ drop 3 s)+                 | otherwise+                 = Nothing++-- ---------------------------------------------------------------------------+-- Helper functions+-- ---------------------------------------------------------------------------++tryOnExistingFile :: (FilePath -> IO a) -> FilePath -> IO (Maybe a)+tryOnExistingFile action fn = C.handle ignoreIOException $ do+  exists <- doesFileExist fn+  if exists then Just `liftM` action fn+            else return Nothing++ignoreIOException :: C.IOException -> IO (Maybe a)+ignoreIOException _ = return Nothing++-- | Try to write a file. If it already exists and is not writable,+-- a warning is issued. This solves some file dependency problems+-- in global installations.+tryWriteFile :: FilePath -- ^ original path+             -> String   -- ^ file content+             -> IO ()+tryWriteFile fn contents = do+  exists <- doesFileExist fn+  if exists then C.handle issueWarning (writeFileUTF8 fn contents)+            else writeFileUTF8 fn contents+ where+  issueWarning :: C.IOException -> IO ()+  issueWarning _ = do+    putStrLn $ "*** Warning: cannot update file `" ++ fn ++ "' (update ignored)"+    return ()+  writeFileUTF8 :: FilePath -> String -> IO ()+  writeFileUTF8 fn' str =+    withFile fn' WriteMode (\hdl -> hSetEncoding hdl utf8 >> hPutStr hdl str)++-- | Try to write a file. If it already exists and is not writable,+-- a warning is issued. This solves some file dependency problems+-- in global installations.+tryWriteBinaryFile :: FilePath -- ^ original path+                   -> B.ByteString   -- ^ file content+                   -> IO ()+tryWriteBinaryFile fn contents = do+  exists <- doesFileExist fn+  if exists then C.handle issueWarning (B.writeFile fn contents)+            else B.writeFile fn contents+ where+  issueWarning :: C.IOException -> IO ()+  issueWarning _ = do+    putStrLn $ "*** Warning: cannot update file `" ++ fn ++ "' (update ignored)"+    return ()
+ src/Curry/Files/Unlit.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE ViewPatterns #-}+{- |+    Module      :  $Header$+    Description :  Handling of literate Curry files+    Copyright   :  (c) 2009         Holger Siegel+                       2012  - 2014 Björn Peemöller+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    Since version 0.7 of the language report, Curry accepts literate+    source programs. In a literate source, all program lines must begin+    with a greater sign in the first column. All other lines are assumed+    to be documentation. In order to avoid some common errors with+    literate programs, Curry requires at least one program line to be+    present in the file. In addition, every block of program code must be+    preceded by a blank line and followed by a blank line.++    It is also possible to use "\begin{code}" and "\end{code}"+    to mark code segments. Both styles can be used in mixed fashion.+-}++module Curry.Files.Unlit (isLiterate, unlit) where++import Control.Monad         (when, unless, zipWithM)+import Data.Char             (isSpace)+import Data.List             (stripPrefix)++import Curry.Base.Monad      (CYM, failMessageAt)+import Curry.Base.Span       (pos2Span)+import Curry.Base.Position   (Position (..), first)+import Curry.Files.Filenames (lcurryExt, takeExtension)++-- |Check whether a 'FilePath' represents a literate Curry module+isLiterate :: FilePath -> Bool+isLiterate = (== lcurryExt) . takeExtension++-- |Data type representing different kind of lines in a literate source+data Line+  = ProgramStart !Int        -- ^ \begin{code}+  | ProgramEnd   !Int        -- ^ \end{code}+  | Program      !Int String -- ^ program line with a line number and content+  | Comment      !Int String -- ^ comment line+  | Blank        !Int        -- ^ blank line++-- |Process a curry program into error messages (if any) and the+-- corresponding non-literate program.+unlit :: FilePath -> String -> CYM String+unlit fn cy+  | isLiterate fn = do+      let cyl = lines cy+      ls <- progLines fn =<<+            normalize fn (length cyl) False (zipWith classify [1 .. ] cyl)+      when (all null ls) $ failMessageAt (pos2Span $ first fn) "No code in literate script"+      return (unlines ls)+  | otherwise     = return cy++-- |Classification of a single program line+classify :: Int -> String -> Line+classify l s@('>' : _) = Program l s+classify l s@(stripPrefix "\\begin{code}" -> Just cs)+  | all isSpace cs = ProgramStart l+  | otherwise      = Comment l s+classify l s@(stripPrefix "\\end{code}" -> Just cs)+  | all isSpace cs = ProgramEnd l+  | otherwise      = Comment l s+classify l s+  | all isSpace s = Blank l+  | otherwise     = Comment l s++-- |Check that ProgramStart and ProgramEnd match and desugar them.+normalize :: FilePath -> Int -> Bool -> [Line] -> CYM [Line]+normalize _  _ False [] = return []+normalize fn n True  [] = reportMissingEnd fn n+normalize fn n b (ProgramStart l : rest) = do+  when b $ reportSpurious fn l "\\begin{code}"+  norm <- normalize fn n True rest+  return (Blank l : norm)+normalize fn n b (ProgramEnd   l : rest) = do+  unless b $ reportSpurious fn l "\\end{code}"+  norm <- normalize fn n False rest+  return (Blank l : norm)+normalize fn n b (Comment l s : rest) = do+  let cons = if b then Program l s else Comment l s+  norm <- normalize fn n b rest+  return (cons : norm)+normalize fn n b (Program l s : rest) = do+  let cons = if b then Program l s else Program l (drop 1 s)+  norm <- normalize fn n b rest+  return (cons : norm)+normalize fn n b (Blank   l   : rest) = do+  let cons = if b then Program l "" else Blank l+  norm <- normalize fn n b rest+  return (cons : norm)++-- |Check that each program line is not adjacent to a comment line.+progLines :: FilePath -> [Line] -> CYM [String]+progLines fn cs = zipWithM checkAdjacency (Blank 0 : cs) cs where+  checkAdjacency (Program p _) (Comment _ _) = reportBlank fn p "followed"+  checkAdjacency (Comment _ _) (Program p _) = reportBlank fn p "preceded"+  checkAdjacency _             (Program _ s) = return s+  checkAdjacency _             _             = return ""++-- |Compute an appropiate error message+reportBlank :: FilePath -> Int -> String -> CYM a+reportBlank f l cause = failMessageAt (pos2Span $ Position f l 1) msg+  where msg = concat [ "When reading literate source: "+                     , "Program line is " ++ cause ++ " by comment line."+                     ]++reportMissingEnd :: FilePath -> Int -> CYM a+reportMissingEnd f l = failMessageAt (pos2Span $ Position f (l+1) 1) msg+  where msg = concat [ "When reading literate source: "+                     , "Missing '\\end{code}' at the end of file."+                     ]+++reportSpurious :: FilePath -> Int -> String -> CYM a+reportSpurious f l cause = failMessageAt (pos2Span $ Position f l 1) msg+  where msg = concat [ "When reading literate source: "+                     , "Spurious '" ++ cause ++ "'."+                     ]
+ src/Curry/FlatCurry.hs view
@@ -0,0 +1,19 @@+{- |+    Module      :  $Header$+    Description :  Interface for reading and manipulating FlatCurry source code+    Copyright   :  (c) 2014 Björn Peemöller+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable+-}+module Curry.FlatCurry+  ( module Curry.FlatCurry.Type+  , module Curry.FlatCurry.Pretty+  , module Curry.FlatCurry.Files+  ) where++import Curry.FlatCurry.Files+import Curry.FlatCurry.Pretty+import Curry.FlatCurry.Type
+ src/Curry/FlatCurry/Annotated/Goodies.hs view
@@ -0,0 +1,685 @@+{- |+    Module      : $Header$+    Description : Utility functions for working with annotated FlatCurry.+    Copyright   : (c) 2016 - 2017 Finn Teegen+    License     : BSD-3-clause++    Maintainer  : fte@informatik.uni-kiel.de+    Stability   : experimental+    Portability : portable++    This library provides selector functions, test and update operations+    as well as some useful auxiliary functions for AnnotatedFlatCurry data terms.+    Most of the provided functions are based on general transformation+    functions that replace constructors with user-defined+    functions. For recursive datatypes the transformations are defined+    inductively over the term structure. This is quite usual for+    transformations on AnnotatedFlatCurry terms,+    so the provided functions can be used to implement specific transformations+    without having to explicitly state the recursion. Essentially, the tedious+    part of such transformations - descend in fairly complex term structures -+    is abstracted away, which hopefully makes the code more clear and brief.+-}++module Curry.FlatCurry.Annotated.Goodies+  ( module Curry.FlatCurry.Annotated.Goodies+  , module Curry.FlatCurry.Goodies+  ) where++import Curry.FlatCurry.Goodies ( Update+                               , trType, typeName, typeVisibility, typeParams+                               , typeConsDecls, typeSyn, isTypeSyn+                               , isDataTypeDecl, isExternalType, isPublicType+                               , updType, updTypeName, updTypeVisibility+                               , updTypeParams, updTypeConsDecls, updTypeSynonym+                               , updQNamesInType+                               , trCons, consName, consArity, consVisibility+                               , isPublicCons, consArgs, updCons, updConsName+                               , updConsArity, updConsVisibility, updConsArgs+                               , updQNamesInConsDecl+                               , trNewCons, newConsName, newConsVisibility+                               , isPublicNewCons, newConsArg+                               , updNewCons, updNewConsName+                               , updNewConsVisibility, updNewConsArg+                               , updQNamesInNewConsDecl+                               , tVarIndex, domain, range, tConsName, tConsArgs+                               , trTypeExpr, isTVar, isTCons, isFuncType+                               , updTVars, updTCons, updFuncTypes, argTypes+                               , typeArity, resultType, allVarsInTypeExpr+                               , allTypeCons, rnmAllVarsInTypeExpr+                               , updQNamesInTypeExpr+                               , trOp, opName, opFixity, opPrecedence, updOp+                               , updOpName, updOpFixity, updOpPrecedence+                               , trCombType, isCombTypeFuncCall+                               , isCombTypeFuncPartCall, isCombTypeConsCall+                               , isCombTypeConsPartCall+                               , isPublic+                               )++import Curry.FlatCurry.Annotated.Type++-- AProg ----------------------------------------------------------------------++-- |transform program+trAProg :: (String -> [String] -> [TypeDecl] -> [AFuncDecl a] -> [OpDecl] -> b)+        -> AProg a -> b+trAProg prog (AProg name imps types funcs ops) = prog name imps types funcs ops++-- Selectors++-- |get name from program+aProgName :: AProg a -> String+aProgName = trAProg (\name _ _ _ _ -> name)++-- |get imports from program+aProgImports :: AProg a -> [String]+aProgImports = trAProg (\_ imps _ _ _ -> imps)++-- |get type declarations from program+aProgTypes :: AProg a -> [TypeDecl]+aProgTypes = trAProg (\_ _ types _ _ -> types)++-- |get functions from program+aProgAFuncs :: AProg a -> [AFuncDecl a]+aProgAFuncs = trAProg (\_ _ _ funcs _ -> funcs)++-- |get infix operators from program+aProgOps :: AProg a -> [OpDecl]+aProgOps = trAProg (\_ _ _ _ ops -> ops)++-- Update Operations++-- |update program+updAProg :: (String -> String) ->+            ([String] -> [String]) ->+            ([TypeDecl] -> [TypeDecl]) ->+            ([AFuncDecl a] -> [AFuncDecl a]) ->+            ([OpDecl] -> [OpDecl]) -> AProg a -> AProg a+updAProg fn fi ft ff fo = trAProg prog+ where+  prog name imps types funcs ops+    = AProg (fn name) (fi imps) (ft types) (ff funcs) (fo ops)++-- |update name of program+updAProgName :: Update (AProg a) String+updAProgName f = updAProg f id id id id++-- |update imports of program+updAProgImports :: Update (AProg a) [String]+updAProgImports f = updAProg id f id id id++-- |update type declarations of program+updAProgTypes :: Update (AProg a) [TypeDecl]+updAProgTypes f = updAProg id id f id id++-- |update functions of program+updAProgAFuncs :: Update (AProg a) [AFuncDecl a]+updAProgAFuncs f = updAProg id id id f id++-- |update infix operators of program+updAProgOps :: Update (AProg a) [OpDecl]+updAProgOps = updAProg id id id id++-- Auxiliary Functions++-- |get all program variables (also from patterns)+allVarsInAProg :: AProg a -> [(VarIndex, a)]+allVarsInAProg = concatMap allVarsInAFunc . aProgAFuncs++-- |lift transformation on expressions to program+updAProgAExps :: Update (AProg a) (AExpr a)+updAProgAExps = updAProgAFuncs . map . updAFuncBody++-- |rename programs variables+rnmAllVarsInAProg :: Update (AProg a) VarIndex+rnmAllVarsInAProg = updAProgAFuncs . map . rnmAllVarsInAFunc++-- |update all qualified names in program+updQNamesInAProg :: Update (AProg a) QName+updQNamesInAProg f = updAProg id id+  (map (updQNamesInType f)) (map (updQNamesInAFunc f)) (map (updOpName f))++-- |rename program (update name of and all qualified names in program)+rnmAProg :: String -> AProg a -> AProg a+rnmAProg name p = updAProgName (const name) (updQNamesInAProg rnm p)+ where+  rnm (m, n) | m == aProgName p = (name, n)+             | otherwise = (m, n)++-- AFuncDecl ------------------------------------------------------------------++-- |transform function+trAFunc :: (QName -> Int -> Visibility -> TypeExpr -> ARule a -> b) -> AFuncDecl a -> b+trAFunc func (AFunc name arity vis t rule) = func name arity vis t rule++-- Selectors++-- |get name of function+aFuncName :: AFuncDecl a -> QName+aFuncName = trAFunc (\name _ _ _ _ -> name)++-- |get arity of function+aFuncArity :: AFuncDecl a -> Int+aFuncArity = trAFunc (\_ arity _ _ _ -> arity)++-- |get visibility of function+aFuncVisibility :: AFuncDecl a -> Visibility+aFuncVisibility = trAFunc (\_ _ vis _ _ -> vis)++-- |get type of function+aFuncType :: AFuncDecl a -> TypeExpr+aFuncType = trAFunc (\_ _ _ t _ -> t)++-- |get rule of function+aFuncARule :: AFuncDecl a -> ARule a+aFuncARule = trAFunc (\_ _ _ _ rule -> rule)++-- Update Operations++-- |update function+updAFunc :: (QName -> QName) ->+            (Int -> Int) ->+            (Visibility -> Visibility) ->+            (TypeExpr -> TypeExpr) ->+            (ARule a -> ARule a) -> AFuncDecl a -> AFuncDecl a+updAFunc fn fa fv ft fr = trAFunc func+ where+  func name arity vis t rule+    = AFunc (fn name) (fa arity) (fv vis) (ft t) (fr rule)++-- |update name of function+updAFuncName :: Update (AFuncDecl a) QName+updAFuncName f = updAFunc f id id id id++-- |update arity of function+updAFuncArity :: Update (AFuncDecl a) Int+updAFuncArity f = updAFunc id f id id id++-- |update visibility of function+updAFuncVisibility :: Update (AFuncDecl a) Visibility+updAFuncVisibility f = updAFunc id id f id id++-- |update type of function+updFuncType :: Update (AFuncDecl a) TypeExpr+updFuncType f = updAFunc id id id f id++-- |update rule of function+updAFuncARule :: Update (AFuncDecl a) (ARule a)+updAFuncARule = updAFunc id id id id++-- Auxiliary Functions++-- |is function public?+isPublicAFunc :: AFuncDecl a -> Bool+isPublicAFunc = isPublic . aFuncVisibility++-- |is function externally defined?+isExternal :: AFuncDecl a -> Bool+isExternal = isARuleExternal . aFuncARule++-- |get variable names in a function declaration+allVarsInAFunc :: AFuncDecl a -> [(VarIndex, a)]+allVarsInAFunc = allVarsInARule . aFuncARule++-- |get arguments of function, if not externally defined+aFuncArgs :: AFuncDecl a -> [(VarIndex, a)]+aFuncArgs = aRuleArgs . aFuncARule++-- |get body of function, if not externally defined+aFuncBody :: AFuncDecl a -> AExpr a+aFuncBody = aRuleBody . aFuncARule++-- |get the right-hand-sides of a 'FuncDecl'+aFuncRHS :: AFuncDecl a -> [AExpr a]+aFuncRHS f | not (isExternal f) = orCase (aFuncBody f)+           | otherwise = []+ where+  orCase e+    | isAOr e = concatMap orCase (orExps e)+    | isACase e = concatMap orCase (map aBranchAExpr (caseBranches e))+    | otherwise = [e]++-- |rename all variables in function+rnmAllVarsInAFunc :: Update (AFuncDecl a) VarIndex+rnmAllVarsInAFunc = updAFunc id id id id . rnmAllVarsInARule++-- |update all qualified names in function+updQNamesInAFunc :: Update (AFuncDecl a) QName+updQNamesInAFunc f = updAFunc f id id (updQNamesInTypeExpr f) (updQNamesInARule f)++-- |update arguments of function, if not externally defined+updAFuncArgs :: Update (AFuncDecl a) [(VarIndex, a)]+updAFuncArgs = updAFuncARule . updARuleArgs++-- |update body of function, if not externally defined+updAFuncBody :: Update (AFuncDecl a) (AExpr a)+updAFuncBody = updAFuncARule . updARuleBody++-- ARule ----------------------------------------------------------------------++-- |transform rule+trARule :: (a -> [(VarIndex, a)] -> AExpr a -> b) -> (a -> String -> b) -> ARule a -> b+trARule rule _ (ARule a args e) = rule a args e+trARule _ ext (AExternal a s) = ext a s++-- Selectors++-- |get rules annotation+aRuleAnnot :: ARule a -> a+aRuleAnnot = trARule (\a _ _ -> a) (\a _ -> a)++-- |get rules arguments if it's not external+aRuleArgs :: ARule a -> [(VarIndex, a)]+aRuleArgs = trARule (\_ args _ -> args) undefined++-- |get rules body if it's not external+aRuleBody :: ARule a -> AExpr a+aRuleBody = trARule (\_ _ e -> e) undefined++-- |get rules external declaration+aRuleExtDecl :: ARule a -> String+aRuleExtDecl = trARule undefined (\_ s -> s)++-- Test Operations++-- |is rule external?+isARuleExternal :: ARule a -> Bool+isARuleExternal = trARule (\_ _ _ -> False) (\_ _ -> True)++-- Update Operations++-- |update rule+updARule :: (a -> b) ->+            ([(VarIndex, a)] -> [(VarIndex, b)]) ->+            (AExpr a -> AExpr b) ->+            (String -> String) -> ARule a -> ARule b+updARule fannot fa fe fs = trARule rule ext+ where+  rule a args e = ARule (fannot a) (fa args) (fe e)+  ext a s = AExternal (fannot a) (fs s)++-- |update rules annotation+updARuleAnnot :: Update (ARule a) a+updARuleAnnot f = updARule f id id id++-- |update rules arguments+updARuleArgs :: Update (ARule a) [(VarIndex, a)]+updARuleArgs f = updARule id f id id++-- |update rules body+updARuleBody :: Update (ARule a) (AExpr a)+updARuleBody f = updARule id id f id++-- |update rules external declaration+updARuleExtDecl :: Update (ARule a) String+updARuleExtDecl f = updARule id id id f++-- Auxiliary Functions++-- |get variable names in a functions rule+allVarsInARule :: ARule a -> [(VarIndex, a)]+allVarsInARule = trARule (\_ args body -> args ++ allVars body) (\_ _ -> [])++-- |rename all variables in rule+rnmAllVarsInARule :: Update (ARule a) VarIndex+rnmAllVarsInARule f = updARule id (map (\(a, b) -> (f a, b))) (rnmAllVars f) id++-- |update all qualified names in rule+updQNamesInARule :: Update (ARule a) QName+updQNamesInARule = updARuleBody . updQNames++-- AExpr ----------------------------------------------------------------------++-- Selectors++-- |get annoation of an expression+annot :: AExpr a -> a+annot (AVar   a _    ) = a+annot (ALit   a _    ) = a+annot (AComb  a _ _ _) = a+annot (ALet   a _ _  ) = a+annot (AFree  a _ _  ) = a+annot (AOr    a _ _  ) = a+annot (ACase  a _ _ _) = a+annot (ATyped a _ _  ) = a++-- |get internal number of variable+varNr :: AExpr a -> VarIndex+varNr (AVar _ n) = n+varNr _          = error "Curry.FlatCurry.Annotated.Goodies.varNr: no variable"++-- |get literal if expression is literal expression+literal :: AExpr a -> Literal+literal (ALit _ l) = l+literal _          = error "Curry.FlatCurry.Annotated.Goodies.literal: no literal"++-- |get combination type of a combined expression+combType :: AExpr a -> CombType+combType (AComb _ ct _ _) = ct+combType _                = error $ "Curry.FlatCurry.Annotated.Goodies.combType: " +++                                    "no combined expression"++-- |get name of a combined expression+combName :: AExpr a -> (QName, a)+combName (AComb _ _ name _) = name+combName _                  = error $ "Curry.FlatCurry.Annotated.Goodies.combName: " +++                                      "no combined expression"++-- |get arguments of a combined expression+combArgs :: AExpr a -> [AExpr a]+combArgs (AComb _ _ _ args) = args+combArgs _                  = error $ "Curry.FlatCurry.Annotated.Goodies.combArgs: " +++                                      "no combined expression"++-- |get number of missing arguments if expression is combined+missingCombArgs :: AExpr a -> Int+missingCombArgs = missingArgs . combType+  where+  missingArgs :: CombType -> Int+  missingArgs = trCombType 0 id 0 id++-- |get indices of varoables in let declaration+letBinds :: AExpr a -> [((VarIndex, a), AExpr a)]+letBinds (ALet _ vs _) = vs+letBinds _             = error $ "Curry.FlatCurry.Annotated.Goodies.letBinds: " +++                                 "no let expression"++-- |get body of let declaration+letBody :: AExpr a -> AExpr a+letBody (ALet _ _ e) = e+letBody _            = error $ "Curry.FlatCurry.Annotated.Goodies.letBody: " +++                               "no let expression"++-- |get variable indices from declaration of free variables+freeVars :: AExpr a -> [(VarIndex, a)]+freeVars (AFree _ vs _) = vs+freeVars _              = error $ "Curry.FlatCurry.Annotated.Goodies.freeVars: " +++                                  "no declaration of free variables"++-- |get expression from declaration of free variables+freeExpr :: AExpr a -> AExpr a+freeExpr (AFree _ _ e) = e+freeExpr _             = error $ "Curry.FlatCurry.Annotated.Goodies.freeExpr: " +++                                 "no declaration of free variables"++-- |get expressions from or-expression+orExps :: AExpr a -> [AExpr a]+orExps (AOr _ e1 e2) = [e1, e2]+orExps _             = error $ "Curry.FlatCurry.Annotated.Goodies.orExps: " +++                               "no or expression"++-- |get case-type of case expression+caseType :: AExpr a -> CaseType+caseType (ACase _ ct _ _) = ct+caseType _                = error $ "Curry.FlatCurry.Annotated.Goodies.caseType: " +++                                    "no case expression"++-- |get scrutinee of case expression+caseExpr :: AExpr a -> AExpr a+caseExpr (ACase _ _ e _) = e+caseExpr _               = error $ "Curry.FlatCurry.Annotated.Goodies.caseExpr: " +++                                   "no case expression"+++-- |get branch expressions from case expression+caseBranches :: AExpr a -> [ABranchExpr a]+caseBranches (ACase _ _ _ bs) = bs+caseBranches _                = error+  "Curry.FlatCurry.Annotated.Goodies.caseBranches: no case expression"++-- Test Operations++-- |is expression a variable?+isAVar :: AExpr a -> Bool+isAVar e = case e of+  AVar _ _ -> True+  _ -> False++-- |is expression a literal expression?+isALit :: AExpr a -> Bool+isALit e = case e of+  ALit _ _ -> True+  _ -> False++-- |is expression combined?+isAComb :: AExpr a -> Bool+isAComb e = case e of+  AComb _ _ _ _ -> True+  _ -> False++-- |is expression a let expression?+isALet :: AExpr a -> Bool+isALet e = case e of+  ALet _ _ _ -> True+  _ -> False++-- |is expression a declaration of free variables?+isAFree :: AExpr a -> Bool+isAFree e = case e of+  AFree _ _ _ -> True+  _ -> False++-- |is expression an or-expression?+isAOr :: AExpr a -> Bool+isAOr e = case e of+  AOr _ _ _ -> True+  _ -> False++-- |is expression a case expression?+isACase :: AExpr a -> Bool+isACase e = case e of+  ACase _ _ _ _ -> True+  _ -> False++-- |transform expression+trAExpr  :: (a -> VarIndex -> b)+         -> (a -> Literal -> b)+         -> (a -> CombType -> (QName, a) -> [b] -> b)+         -> (a -> [((VarIndex, a), b)] -> b -> b)+         -> (a -> [(VarIndex, a)] -> b -> b)+         -> (a -> b -> b -> b)+         -> (a -> CaseType -> b -> [c] -> b)+         -> (APattern a -> b -> c)+         -> (a -> b -> TypeExpr -> b)+         -> AExpr a+         -> b+trAExpr var lit comb lt fr oR cas branch typed expr = case expr of+  AVar a n             -> var a n+  ALit a l             -> lit a l+  AComb a ct name args -> comb a ct name (map f args)+  ALet a bs e          -> lt a (map (\(v, x) -> (v, f x)) bs) (f e)+  AFree a vs e         -> fr a vs (f e)+  AOr a e1 e2          -> oR a (f e1) (f e2)+  ACase a ct e bs      -> cas a ct (f e) (map (\ (ABranch p e') -> branch p (f e')) bs)+  ATyped a e ty        -> typed a (f e) ty+  where+  f = trAExpr var lit comb lt fr oR cas branch typed++-- |update all variables in given expression+updVars :: (a -> VarIndex -> AExpr a) -> AExpr a -> AExpr a+updVars var = trAExpr var ALit AComb ALet AFree AOr ACase ABranch ATyped++-- |update all literals in given expression+updLiterals :: (a -> Literal -> AExpr a) -> AExpr a -> AExpr a+updLiterals lit = trAExpr AVar lit AComb ALet AFree AOr ACase ABranch ATyped++-- |update all combined expressions in given expression+updCombs :: (a -> CombType -> (QName, a) -> [AExpr a] -> AExpr a) -> AExpr a -> AExpr a+updCombs comb = trAExpr AVar ALit comb ALet AFree AOr ACase ABranch ATyped++-- |update all let expressions in given expression+updLets :: (a -> [((VarIndex, a), AExpr a)] -> AExpr a -> AExpr a) -> AExpr a -> AExpr a+updLets lt = trAExpr AVar ALit AComb lt AFree AOr ACase ABranch ATyped++-- |update all free declarations in given expression+updFrees :: (a -> [(VarIndex, a)] -> AExpr a -> AExpr a) -> AExpr a -> AExpr a+updFrees fr = trAExpr AVar ALit AComb ALet fr AOr ACase ABranch ATyped++-- |update all or expressions in given expression+updOrs :: (a -> AExpr a -> AExpr a -> AExpr a) -> AExpr a -> AExpr a+updOrs oR = trAExpr AVar ALit AComb ALet AFree oR ACase ABranch ATyped++-- |update all case expressions in given expression+updCases :: (a -> CaseType -> AExpr a -> [ABranchExpr a] -> AExpr a) -> AExpr a -> AExpr a+updCases cas = trAExpr AVar ALit AComb ALet AFree AOr cas ABranch ATyped++-- |update all case branches in given expression+updBranches :: (APattern a -> AExpr a -> ABranchExpr a) -> AExpr a -> AExpr a+updBranches branch = trAExpr AVar ALit AComb ALet AFree AOr ACase branch ATyped++-- |update all typed expressions in given expression+updTypeds :: (a -> AExpr a -> TypeExpr -> AExpr a) -> AExpr a -> AExpr a+updTypeds = trAExpr AVar ALit AComb ALet AFree AOr ACase ABranch++-- Auxiliary Functions++-- |is expression a call of a function where all arguments are provided?+isFuncCall :: AExpr a -> Bool+isFuncCall e = isAComb e && isCombTypeFuncCall (combType e)++-- |is expression a partial function call?+isFuncPartCall :: AExpr a -> Bool+isFuncPartCall e = isAComb e && isCombTypeFuncPartCall (combType e)++-- |is expression a call of a constructor?+isConsCall :: AExpr a -> Bool+isConsCall e = isAComb e && isCombTypeConsCall (combType e)++-- |is expression a partial constructor call?+isConsPartCall :: AExpr a -> Bool+isConsPartCall e = isAComb e && isCombTypeConsPartCall (combType e)++-- |is expression fully evaluated?+isGround :: AExpr a -> Bool+isGround e+  = case e of+      AComb _ ConsCall _ args -> all isGround args+      _ -> isALit e++-- |get all variables (also pattern variables) in expression+allVars :: AExpr a -> [(VarIndex, a)]+allVars e = trAExpr var lit comb lt fr (const (.)) cas branch typ e []+ where+  var a v = (:) (v, a)+  lit = const (const id)+  comb _ _ _ = foldr (.) id+  lt _ bs e' = e' . foldr (.) id (map (\(n,ns) -> (n:) . ns) bs)+  fr _ vs e' = (vs++) . e'+  cas _ _ e' bs = e' . foldr (.) id bs+  branch pat e' = ((args pat)++) . e'+  typ _ = const+  args pat | isConsPattern pat = aPatArgs pat+           | otherwise = []++-- |rename all variables (also in patterns) in expression+rnmAllVars :: Update (AExpr a) VarIndex+rnmAllVars f = trAExpr var ALit AComb lt fr AOr ACase branch ATyped+ where+   var a = AVar a . f+   lt a = ALet a . map (\((n, b), e) -> ((f n, b), e))+   fr a = AFree a . map (\(b, c) -> (f b, c))+   branch = ABranch . updAPatArgs (map (\(a, b) -> (f a, b)))++-- |update all qualified names in expression+updQNames :: Update (AExpr a) QName+updQNames f = trAExpr AVar ALit comb ALet AFree AOr ACase branch ATyped+ where+  comb a ct (name, a') args = AComb a ct (f name, a') args+  branch = ABranch . updAPatCons (\(q, a) -> (f q, a))++-- ABranchExpr ----------------------------------------------------------------++-- |transform branch expression+trABranch :: (APattern a -> AExpr a -> b) -> ABranchExpr a -> b+trABranch branch (ABranch pat e) = branch pat e++-- Selectors++-- |get pattern from branch expression+aBranchAPattern :: ABranchExpr a -> APattern a+aBranchAPattern = trABranch (\pat _ -> pat)++-- |get expression from branch expression+aBranchAExpr :: ABranchExpr a -> AExpr a+aBranchAExpr = trABranch (\_ e -> e)++-- Update Operations++-- |update branch expression+updABranch :: (APattern a -> APattern a) -> (AExpr a -> AExpr a) -> ABranchExpr a -> ABranchExpr a+updABranch fp fe = trABranch branch+ where+  branch pat e = ABranch (fp pat) (fe e)++-- |update pattern of branch expression+updABranchAPattern :: Update (ABranchExpr a) (APattern a)+updABranchAPattern f = updABranch f id++-- |update expression of branch expression+updABranchAExpr :: Update (ABranchExpr a) (AExpr a)+updABranchAExpr = updABranch id++-- APattern -------------------------------------------------------------------++-- |transform pattern+trAPattern :: (a -> (QName, a) -> [(VarIndex, a)] -> b) -> (a -> Literal -> b) -> APattern a -> b+trAPattern pat _ (APattern a name args) = pat a name args+trAPattern _ lpat (ALPattern a l) = lpat a l++-- Selectors++-- |get annotation from pattern+aPatAnnot :: APattern a -> a+aPatAnnot = trAPattern (\a _ _ -> a) (\a _ -> a)++-- |get name from constructor pattern+aPatCons :: APattern a -> (QName, a)+aPatCons = trAPattern (\_ name _ -> name) undefined++-- |get arguments from constructor pattern+aPatArgs :: APattern a -> [(VarIndex, a)]+aPatArgs = trAPattern (\_ _ args -> args) undefined++-- |get literal from literal pattern+aPatLiteral :: APattern a -> Literal+aPatLiteral = trAPattern undefined (const id)++-- Test Operations++-- |is pattern a constructor pattern?+isConsPattern :: APattern a -> Bool+isConsPattern = trAPattern (\_ _ _ -> True) (\_ _ -> False)++-- Update Operations++-- |update pattern+updAPattern :: (a -> a) ->+               ((QName, a) -> (QName, a)) ->+               ([(VarIndex, a)] -> [(VarIndex, a)]) ->+               (Literal -> Literal) -> APattern a -> APattern a+updAPattern fannot fn fa fl = trAPattern pat lpat+ where+  pat a name args = APattern (fannot a) (fn name) (fa args)+  lpat a l = ALPattern (fannot a) (fl l)++-- |update annotation of pattern+updAPatAnnot :: (a -> a) -> APattern a -> APattern a+updAPatAnnot f = updAPattern f id id id++-- |update constructors name of pattern+updAPatCons :: ((QName, a) -> (QName, a)) -> APattern a -> APattern a+updAPatCons f = updAPattern id f id id++-- |update arguments of constructor pattern+updAPatArgs :: ([(VarIndex, a)] -> [(VarIndex, a)]) -> APattern a -> APattern a+updAPatArgs f = updAPattern id id f id++-- |update literal of pattern+updAPatLiteral :: (Literal -> Literal) -> APattern a -> APattern a+updAPatLiteral f = updAPattern id id id f++-- Auxiliary Functions++-- |build expression from pattern+aPatExpr :: APattern a -> AExpr a+aPatExpr = trAPattern (\a name -> AComb a ConsCall name . map (uncurry (flip AVar))) ALit
+ src/Curry/FlatCurry/Annotated/Type.hs view
@@ -0,0 +1,132 @@+{- |+    Module      : $Header$+    Description : Representation of annotated FlatCurry.+    Copyright   : (c) 2016 - 2017 Finn Teegen+    License     : BSD-3-clause++    Maintainer  : fte@informatik.uni-kiel.de+    Stability   : experimental+    Portability : portable++    TODO+-}++module Curry.FlatCurry.Annotated.Type+  ( module Curry.FlatCurry.Annotated.Type+  , module Curry.FlatCurry.Typeable+  , module Curry.FlatCurry.Type+  ) where++import Data.Binary+import Control.Monad++import Curry.FlatCurry.Typeable+import Curry.FlatCurry.Type ( QName, VarIndex, Visibility (..), TVarIndex+                            , TypeDecl (..), Kind (..), OpDecl (..), Fixity (..)+                            , TypeExpr (..), ConsDecl (..), NewConsDecl (..)+                            , Literal (..), CombType (..), CaseType (..)+                            )++data AProg a = AProg String [String] [TypeDecl] [AFuncDecl a] [OpDecl]+  deriving (Eq, Read, Show)++data AFuncDecl a = AFunc QName Int Visibility TypeExpr (ARule a)+  deriving (Eq, Read, Show)++data ARule a+  = ARule     a [(VarIndex, a)] (AExpr a)+  | AExternal a String+  deriving (Eq, Read, Show)++data AExpr a+  = AVar   a VarIndex+  | ALit   a Literal+  | AComb  a CombType (QName, a) [AExpr a]+  | ALet   a [((VarIndex, a), AExpr a)] (AExpr a)+  | AFree  a [(VarIndex, a)] (AExpr a)+  | AOr    a (AExpr a) (AExpr a)+  | ACase  a CaseType (AExpr a) [ABranchExpr a]+  | ATyped a (AExpr a) TypeExpr+  deriving (Eq, Read, Show)++data ABranchExpr a = ABranch (APattern a) (AExpr a)+  deriving (Eq, Read, Show)++data APattern a+  = APattern  a (QName, a) [(VarIndex, a)]+  | ALPattern a Literal+  deriving (Eq, Read, Show)++instance Typeable a => Typeable (AExpr a) where+  typeOf (AVar a _) = typeOf a+  typeOf (ALit a _) = typeOf a+  typeOf (AComb a _ _ _) = typeOf a+  typeOf (ALet a _ _) = typeOf a+  typeOf (AFree a _ _) = typeOf a+  typeOf (AOr a _ _) = typeOf a+  typeOf (ACase a _ _ _) = typeOf a+  typeOf (ATyped a _ _) = typeOf a++instance Typeable a => Typeable (APattern a) where+  typeOf (APattern a _ _) = typeOf a+  typeOf (ALPattern a _) = typeOf a++instance Binary a => Binary (AProg a) where+  put (AProg mid im tys fus ops) =+    put mid >> put im >> put tys >> put fus >> put ops+  get = AProg <$> get <*> get <*> get <*> get <*> get++instance Binary a => Binary (AFuncDecl a) where+  put (AFunc qid arity vis ty r) =+    put qid >> put arity >> put vis >> put ty >> put r+  get = AFunc <$> get <*> get <*> get <*> get <*> get++instance Binary a => Binary (ARule a) where+  put (ARule     a alts e) = putWord8 0 >> put a  >> put alts >> put e+  put (AExternal ty n    ) = putWord8 1 >> put ty >> put n++  get = do+    x <- getWord8+    case x of+      0 -> liftM3 ARule get get get+      1 -> liftM2 AExternal get get+      _ -> fail "Invalid encoding for TRule"++instance Binary a => Binary (AExpr a) where+  put (AVar a v) = putWord8 0 >> put a >> put v+  put (ALit a l) = putWord8 1 >> put a >> put l+  put (AComb a cty qid es) =+    putWord8 2 >> put a >> put cty >> put qid >> put es+  put (ALet  a bs e ) = putWord8 3 >> put a >> put bs >> put e+  put (AFree a vs e ) = putWord8 4 >> put a >> put vs >> put e+  put (AOr   a e1 e2) = putWord8 5 >> put a >> put e1 >> put e2+  put (ACase a cty ty as) = putWord8 6 >> put a >> put cty >> put ty >> put as+  put (ATyped a e ty) = putWord8 7 >> put a >> put e >> put ty++  get = do+    x <- getWord8+    case x of+      0 -> liftM2 AVar get get+      1 -> liftM2 ALit get get+      2 -> liftM4 AComb get get get get+      3 -> liftM3 ALet get get get+      4 -> liftM3 AFree get get get+      5 -> liftM3 AOr get get get+      6 -> liftM4 ACase get get get get+      7 -> liftM3 ATyped get get get+      _ -> fail "Invalid encoding for TExpr"++instance Binary a => Binary (ABranchExpr a) where+  put (ABranch p e) = put p >> put e+  get = liftM2 ABranch get get++instance Binary a => Binary (APattern a) where+  put (APattern  a qid vs) = putWord8 0 >> put a >> put qid >> put vs+  put (ALPattern a l     ) = putWord8 1 >> put a >> put l++  get = do+    x <- getWord8+    case x of+      0 -> liftM3 APattern get get get+      1 -> liftM2 ALPattern get get+      _ -> fail "Invalid encoding for TPattern"
+ src/Curry/FlatCurry/Files.hs view
@@ -0,0 +1,68 @@+{- |+    Module      : $Header$+    Description : Functions for reading and writing FlatCurry files+    Copyright   : (c) 2014        Björn Peemöller+                      2017        Finn Teegen+    License     : BSD-3-clause++    Maintainer  : bjp@informatik.uni-kiel.de+    Stability   : experimental+    Portability : portable++    This module contains functions for reading and writing FlatCurry files.+-}++module Curry.FlatCurry.Files+  ( readTypedFlatCurry, readFlatCurry, readFlatInterface+  , writeFlatCurry, writeBinaryFlatCurry+  ) where++import Data.Binary           (Binary, encode)+import Data.Char             (isSpace)++import Curry.Files.Filenames (typedFlatName, flatName, flatIntName)+import Curry.Files.PathUtils (writeModule, writeBinaryModule, readModule)++import Curry.FlatCurry.Type  (Prog)+import Curry.FlatCurry.Annotated.Type (AProg, TypeExpr)+++-- ---------------------------------------------------------------------------+-- Functions for reading and writing FlatCurry terms+-- ---------------------------------------------------------------------------++-- |Reads an typed FlatCurry file (extension ".tfcy") and eventually+-- returns the corresponding FlatCurry program term (type 'AProg').+readTypedFlatCurry :: FilePath -> IO (Maybe (AProg TypeExpr))+readTypedFlatCurry = readFlat . typedFlatName++-- |Reads a FlatCurry file (extension ".fcy") and eventually returns the+-- corresponding FlatCurry program term (type 'Prog').+readFlatCurry :: FilePath -> IO (Maybe Prog)+readFlatCurry = readFlat . flatName++-- |Reads a FlatInterface file (extension @.fint@) and returns the+-- corresponding term (type 'Prog') as a value of type 'Maybe'.+readFlatInterface :: FilePath -> IO (Maybe Prog)+readFlatInterface = readFlat . flatIntName++-- |Reads a Flat file and returns the corresponding term (type 'Prog' or+-- 'AProg') as a value of type 'Maybe'.+-- Due to compatibility with PAKCS it is allowed to have a commentary+-- at the beginning of the file enclosed in {- ... -}.+readFlat :: Read a => FilePath -> IO (Maybe a)+readFlat = fmap (fmap (read . skipComment)) . readModule where+  skipComment s = case dropWhile isSpace s of+      '{' : '-' : s' -> dropComment s'+      s'             -> s'+  dropComment ('-' : '}' : xs) = xs+  dropComment (_ : xs)         = dropComment xs+  dropComment []               = []++-- |Writes a FlatCurry program term into a file.+writeFlatCurry :: Show a => FilePath -> a -> IO ()+writeFlatCurry fn = writeModule fn . show++-- |Writes a FlatCurry program term into a normal and a binary file.+writeBinaryFlatCurry :: Binary a => FilePath -> a -> IO ()+writeBinaryFlatCurry fn = writeBinaryModule fn . encode
+ src/Curry/FlatCurry/Goodies.hs view
@@ -0,0 +1,1037 @@+{- |+    Module      : $Header$+    Description : Utility functions for working with FlatCurry.+    Copyright   : (c) Sebastian Fischer 2006+                      Björn Peemöller 2011+    License     : BSD-3-clause++    Maintainer  : bjp@informatik.uni-kiel.de+    Stability   : experimental+    Portability : portable++    This library provides selector functions, test and update operations+    as well as some useful auxiliary functions for FlatCurry data terms.+    Most of the provided functions are based on general transformation+    functions that replace constructors with user-defined functions. For+    recursive datatypes the transformations are defined inductively over the+    term structure. This is quite usual for transformations on FlatCurry+    terms, so the provided functions can be used to implement specific+    transformations without having to explicitly state the recursion.+    Essentially, the tedious part of such transformations - descend in fairly+    complex term structures - is abstracted away, which hopefully makes the+    code more clear and brief.+-}++module Curry.FlatCurry.Goodies where++import Curry.FlatCurry.Type++-- |Update of a type's component+type Update a b = (b -> b) -> a -> a++-- Prog ----------------------------------------------------------------------++-- |transform program+trProg :: (String -> [String] -> [TypeDecl] -> [FuncDecl] -> [OpDecl] -> a)+          -> Prog -> a+trProg prog (Prog name imps types funcs ops) = prog name imps types funcs ops++-- Selectors++-- |get name from program+progName :: Prog -> String+progName = trProg (\name _ _ _ _ -> name)++-- |get imports from program+progImports :: Prog -> [String]+progImports = trProg (\_ imps _ _ _ -> imps)++-- |get type declarations from program+progTypes :: Prog -> [TypeDecl]+progTypes = trProg (\_ _ types _ _ -> types)++-- |get functions from program+progFuncs :: Prog -> [FuncDecl]+progFuncs = trProg (\_ _ _ funcs _ -> funcs)++-- |get infix operators from program+progOps :: Prog -> [OpDecl]+progOps = trProg (\_ _ _ _ ops -> ops)++-- Update Operations++-- |update program+updProg :: (String -> String)         ->+           ([String] -> [String])     ->+           ([TypeDecl] -> [TypeDecl]) ->+           ([FuncDecl] -> [FuncDecl]) ->+           ([OpDecl] -> [OpDecl])     -> Prog -> Prog+updProg fn fi ft ff fo = trProg prog+ where+  prog name imps types funcs ops+    = Prog (fn name) (fi imps) (ft types) (ff funcs) (fo ops)++-- |update name of program+updProgName :: Update Prog String+updProgName f = updProg f id id id id++-- |update imports of program+updProgImports :: Update Prog [String]+updProgImports f = updProg id f id id id++-- |update type declarations of program+updProgTypes :: Update Prog [TypeDecl]+updProgTypes f = updProg id id f id id++-- |update functions of program+updProgFuncs :: Update Prog [FuncDecl]+updProgFuncs f = updProg id id id f id++-- |update infix operators of program+updProgOps :: Update Prog [OpDecl]+updProgOps = updProg id id id id++-- Auxiliary Functions++-- |get all program variables (also from patterns)+allVarsInProg :: Prog -> [VarIndex]+allVarsInProg = concatMap allVarsInFunc . progFuncs++-- |lift transformation on expressions to program+updProgExps :: Update Prog Expr+updProgExps = updProgFuncs . map . updFuncBody++-- |rename programs variables+rnmAllVarsInProg :: Update Prog VarIndex+rnmAllVarsInProg = updProgFuncs . map . rnmAllVarsInFunc++-- |update all qualified names in program+updQNamesInProg :: Update Prog QName+updQNamesInProg f = updProg id id+  (map (updQNamesInType f)) (map (updQNamesInFunc f)) (map (updOpName f))++-- |rename program (update name of and all qualified names in program)+rnmProg :: String -> Prog -> Prog+rnmProg name p = updProgName (const name) (updQNamesInProg rnm p)+ where+  rnm (m,n) | m==progName p = (name,n)+            | otherwise = (m,n)++-- TypeDecl ------------------------------------------------------------------++-- Selectors++-- |transform type declaration+trType :: (QName -> Visibility -> [TVarWithKind] -> [ConsDecl]  -> a) ->+          (QName -> Visibility -> [TVarWithKind] -> TypeExpr    -> a) ->+          (QName -> Visibility -> [TVarWithKind] -> NewConsDecl -> a) -> TypeDecl -> a+trType typ _ _ (Type name vis params cs) = typ name vis params cs+trType _ typesyn _ (TypeSyn name vis params syn) = typesyn name vis params syn+trType _ _ newtyp (TypeNew name vis params nc) = newtyp name vis params nc++-- |get name of type declaration+typeName :: TypeDecl -> QName+typeName = trType (\name _ _ _ -> name) (\name _ _ _ -> name) (\name _ _ _ -> name)++-- |get visibility of type declaration+typeVisibility :: TypeDecl -> Visibility+typeVisibility = trType (\_ vis _ _ -> vis) (\_ vis _ _ -> vis) (\_ vis _ _ -> vis)++-- |get type parameters of type declaration+typeParams :: TypeDecl -> [TVarWithKind]+typeParams = trType (\_ _ params _ -> params) (\_ _ params _ -> params) (\_ _ params _ -> params)++-- |get constructor declarations from type declaration+typeConsDecls :: TypeDecl -> [ConsDecl]+typeConsDecls = trType (\_ _ _ cs -> cs)+                       (error "Curry.FlatCurry.Goodies: type synonym")+                       (error "Curry.FlatCurry.Goodies: newtype")++-- |get synonym of type declaration+typeSyn :: TypeDecl -> TypeExpr+typeSyn = trType undefined (\_ _ _ syn -> syn) undefined++-- |is type declaration a type synonym?+isTypeSyn :: TypeDecl -> Bool+isTypeSyn = trType (\_ _ _ _ -> False) (\_ _ _ _ -> True) (\_ _ _ _ -> False)++-- | is type declaration declaring a regular type?+isDataTypeDecl :: TypeDecl -> Bool+isDataTypeDecl = trType (\_ _ _ cs -> not (null cs)) (\_ _ _ _ -> False) (\_ _ _ _ -> False)++-- | is type declaration declaring an external type?+isExternalType :: TypeDecl -> Bool+isExternalType = trType (\_ _ _ cs -> null cs) (\_ _ _ _ -> False) (\_ _ _ _ -> False)++-- |is type declaration a newtype?+isNewtype :: TypeDecl -> Bool+isNewtype = trType (\_ _ _ _ -> False) (\_ _ _ _ -> False) (\_ _ _ _ -> False)++-- |Is the 'TypeDecl' public?+isPublicType :: TypeDecl -> Bool+isPublicType = (== Public) . typeVisibility++-- Update Operations++-- |update type declaration+updType :: (QName -> QName) ->+           (Visibility -> Visibility) ->+           ([TVarWithKind] -> [TVarWithKind]) ->+           ([ConsDecl] -> [ConsDecl]) ->+           (NewConsDecl -> NewConsDecl) ->+           (TypeExpr -> TypeExpr)     -> TypeDecl -> TypeDecl+updType fn fv fp fc fnc fs = trType typ typesyn newtyp+ where+  typ name vis params cs = Type (fn name) (fv vis) (fp params) (fc cs)+  newtyp name vis params nc = TypeNew (fn name) (fv vis) (fp params) (fnc nc)+  typesyn name vis params syn = TypeSyn (fn name) (fv vis) (fp params) (fs syn)++-- |update name of type declaration+updTypeName :: Update TypeDecl QName+updTypeName f = updType f id id id id id++-- |update visibility of type declaration+updTypeVisibility :: Update TypeDecl Visibility+updTypeVisibility f = updType id f id id id id++-- |update type parameters of type declaration+updTypeParams :: Update TypeDecl [TVarWithKind]+updTypeParams f = updType id id f id id id++-- |update constructor declarations of type declaration+updTypeConsDecls :: Update TypeDecl [ConsDecl]+updTypeConsDecls f = updType id id id f id id++-- |update constructor declarations of newtype declaration+updTypeNewConsDecls :: Update TypeDecl NewConsDecl+updTypeNewConsDecls f = updType id id id id f id++-- |update synonym of type declaration+updTypeSynonym :: Update TypeDecl TypeExpr+updTypeSynonym = updType id id id id id++-- Auxiliary Functions++-- |update all qualified names in type declaration+updQNamesInType :: Update TypeDecl QName+updQNamesInType f+  = updType f id id (map (updQNamesInConsDecl f)) (updQNamesInNewConsDecl f)+            (updQNamesInTypeExpr f)++-- ConsDecl ------------------------------------------------------------------++-- Selectors++-- |transform constructor declaration+trCons :: (QName -> Int -> Visibility -> [TypeExpr] -> a) -> ConsDecl -> a+trCons cons (Cons name arity vis args) = cons name arity vis args++-- |get name of constructor declaration+consName :: ConsDecl -> QName+consName = trCons (\name _ _ _ -> name)++-- |get arity of constructor declaration+consArity :: ConsDecl -> Int+consArity = trCons (\_ arity _ _ -> arity)++-- |get visibility of constructor declaration+consVisibility :: ConsDecl -> Visibility+consVisibility = trCons (\_ _ vis _ -> vis)++-- |Is the constructor declaration public?+isPublicCons :: ConsDecl -> Bool+isPublicCons = isPublic . consVisibility++-- |get arguments of constructor declaration+consArgs :: ConsDecl -> [TypeExpr]+consArgs = trCons (\_ _ _ args -> args)++-- Update Operations++-- |update constructor declaration+updCons :: (QName -> QName) ->+           (Int -> Int) ->+           (Visibility -> Visibility) ->+           ([TypeExpr] -> [TypeExpr]) -> ConsDecl -> ConsDecl+updCons fn fa fv fas = trCons cons+ where+  cons name arity vis args = Cons (fn name) (fa arity) (fv vis) (fas args)++-- |update name of constructor declaration+updConsName :: Update ConsDecl QName+updConsName f = updCons f id id id++-- |update arity of constructor declaration+updConsArity :: Update ConsDecl Int+updConsArity f = updCons id f id id++-- |update visibility of constructor declaration+updConsVisibility :: Update ConsDecl Visibility+updConsVisibility f = updCons id id f id++-- |update arguments of constructor declaration+updConsArgs :: Update ConsDecl [TypeExpr]+updConsArgs = updCons id id id++-- Auxiliary Functions++-- |update all qualified names in constructor declaration+updQNamesInConsDecl :: Update ConsDecl QName+updQNamesInConsDecl f = updCons f id id (map (updQNamesInTypeExpr f))+++-- NewConsDecl ------------------------------------------------------------------++-- Selectors++-- |transform newtype constructor declaration+trNewCons :: (QName -> Visibility -> TypeExpr -> a) -> NewConsDecl -> a+trNewCons cons (NewCons name vis arg) = cons name vis arg++-- |get name of new constructor declaration+newConsName :: NewConsDecl -> QName+newConsName = trNewCons (\name _ _ -> name)++-- |get visibility of new constructor declaration+newConsVisibility :: NewConsDecl -> Visibility+newConsVisibility = trNewCons (\_ vis _ -> vis)++-- |Is the new constructor declaration public?+isPublicNewCons :: ConsDecl -> Bool+isPublicNewCons = isPublic . consVisibility++-- |get argument of new constructor declaration+newConsArg :: NewConsDecl -> TypeExpr+newConsArg = trNewCons (\_ _ arg -> arg)++-- Update Operations++-- |update new constructor declaration+updNewCons :: (QName -> QName) ->+              (Visibility -> Visibility) ->+              (TypeExpr -> TypeExpr) -> NewConsDecl -> NewConsDecl+updNewCons fn fv fas = trNewCons cons+ where+  cons name vis args = NewCons (fn name) (fv vis) (fas args)++-- |update name of new constructor declaration+updNewConsName :: Update NewConsDecl QName+updNewConsName f = updNewCons f id id++-- |update visibility of new constructor declaration+updNewConsVisibility :: Update NewConsDecl Visibility+updNewConsVisibility f = updNewCons id f id++-- |update argument of new constructor declaration+updNewConsArg :: Update NewConsDecl TypeExpr+updNewConsArg = updNewCons id id++-- Auxiliary Functions++-- |update all qualified names in new constructor declaration+updQNamesInNewConsDecl :: Update NewConsDecl QName+updQNamesInNewConsDecl f = updNewCons f id (updQNamesInTypeExpr f)++-- TypeExpr ------------------------------------------------------------------++-- Selectors++-- |get index from type variable+tVarIndex :: TypeExpr -> TVarIndex+tVarIndex (TVar n) = n+tVarIndex _        = error $ "Curry.FlatCurry.Goodies.tvarIndex: " +++                             "no type variable"++-- |get domain from functional type+domain :: TypeExpr -> TypeExpr+domain (FuncType dom _) = dom+domain _                = error $ "Curry.FlatCurry.Goodies.domain: " +++                                  "no function type"++-- |get range from functional type+range :: TypeExpr -> TypeExpr+range (FuncType _ ran) = ran+range _                = error $ "Curry.FlatCurry.Goodies.range: " +++                                  "no function type"++-- |get name from constructed type+tConsName :: TypeExpr -> QName+tConsName (TCons name _) = name+tConsName _              = error $ "Curry.FlatCurry.Goodies.tConsName: " +++                                   "no constructor type"++-- |get arguments from constructed type+tConsArgs :: TypeExpr -> [TypeExpr]+tConsArgs (TCons _ args) = args+tConsArgs _              = error $ "Curry.FlatCurry.Goodies.tConsArgs: " +++                                   "no constructor type"++-- |transform type expression+trTypeExpr :: (TVarIndex -> a) ->+              (QName -> [a] -> a) ->+              (a -> a -> a) ->+              ([TVarWithKind] -> a -> a) -> TypeExpr -> a+trTypeExpr tvar _ _ _ (TVar t) = tvar t+trTypeExpr tvar tcons functype foralltype (TCons name args)+  = tcons name (map (trTypeExpr tvar tcons functype foralltype) args)+trTypeExpr tvar tcons functype foralltype (FuncType from to)+  = functype (f from) (f to)+ where+  f = trTypeExpr tvar tcons functype foralltype+trTypeExpr tvar tcons functype foralltype (ForallType ns t)+  = foralltype ns (trTypeExpr tvar tcons functype foralltype t)++-- Test Operations++-- |is type expression a type variable?+isTVar :: TypeExpr -> Bool+isTVar = trTypeExpr (\_ -> True) (\_ _ -> False) (\_ _ -> False) (\_ _ -> False)++-- |is type declaration a constructed type?+isTCons :: TypeExpr -> Bool+isTCons+  = trTypeExpr (\_ -> False) (\_ _ -> True) (\_ _ -> False) (\_ _ -> False)++-- |is type declaration a functional type?+isFuncType :: TypeExpr -> Bool+isFuncType+  = trTypeExpr (\_ -> False) (\_ _ -> False) (\_ _ -> True) (\_ _ -> False)++-- |is type declaration a forall type?+isForallType :: TypeExpr -> Bool+isForallType+  = trTypeExpr (\_ -> False) (\_ _ -> False) (\_ _ -> False) (\_ _ -> True)++-- Update Operations++-- |update all type variables+updTVars :: (TVarIndex -> TypeExpr) -> TypeExpr -> TypeExpr+updTVars tvar = trTypeExpr tvar TCons FuncType ForallType++-- |update all type constructors+updTCons :: (QName -> [TypeExpr] -> TypeExpr) -> TypeExpr -> TypeExpr+updTCons tcons = trTypeExpr TVar tcons FuncType ForallType++-- |update all functional types+updFuncTypes :: (TypeExpr -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr+updFuncTypes functype = trTypeExpr TVar TCons functype ForallType++-- |update all forall types+updForallTypes :: ([TVarWithKind] -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr+updForallTypes = trTypeExpr TVar TCons FuncType++-- Auxiliary Functions++-- |get argument types from functional type+argTypes :: TypeExpr -> [TypeExpr]+argTypes (TVar _) = []+argTypes (TCons _ _) = []+argTypes (FuncType dom ran) = dom : argTypes ran+argTypes (ForallType _ _) = []++-- |Compute the arity of a 'TypeExpr'+typeArity :: TypeExpr -> Int+typeArity = length . argTypes++-- |get result type from (nested) functional type+resultType :: TypeExpr -> TypeExpr+resultType (TVar n) = TVar n+resultType (TCons name args) = TCons name args+resultType (FuncType _ ran) = resultType ran+resultType (ForallType ns t) = ForallType ns t++-- |get indexes of all type variables+allVarsInTypeExpr :: TypeExpr -> [TVarIndex]+allVarsInTypeExpr = trTypeExpr pure (const concat) (++) ((++) . map fst)++-- |yield the list of all contained type constructors+allTypeCons :: TypeExpr -> [QName]+allTypeCons (TVar _) = []+allTypeCons (TCons name args) = name : concatMap allTypeCons args+allTypeCons (FuncType t1 t2) = allTypeCons t1 ++ allTypeCons t2+allTypeCons (ForallType _ t) = allTypeCons t++-- |rename variables in type expression+rnmAllVarsInTypeExpr :: (TVarIndex -> TVarIndex) -> TypeExpr -> TypeExpr+rnmAllVarsInTypeExpr f = updTVars (TVar . f)++-- |update all qualified names in type expression+updQNamesInTypeExpr :: (QName -> QName) -> TypeExpr -> TypeExpr+updQNamesInTypeExpr f = updTCons (\name args -> TCons (f name) args)++-- OpDecl --------------------------------------------------------------------++-- |transform operator declaration+trOp :: (QName -> Fixity -> Integer -> a) -> OpDecl -> a+trOp op (Op name fix prec) = op name fix prec++-- Selectors++-- |get name from operator declaration+opName :: OpDecl -> QName+opName = trOp (\name _ _ -> name)++-- |get fixity of operator declaration+opFixity :: OpDecl -> Fixity+opFixity = trOp (\_ fix _ -> fix)++-- |get precedence of operator declaration+opPrecedence :: OpDecl -> Integer+opPrecedence = trOp (\_ _ prec -> prec)++-- Update Operations++-- |update operator declaration+updOp :: (QName -> QName) ->+         (Fixity -> Fixity) ->+         (Integer -> Integer) -> OpDecl -> OpDecl+updOp fn ff fp = trOp op+ where op name fix prec = Op (fn name) (ff fix) (fp prec)++-- |update name of operator declaration+updOpName :: Update OpDecl QName+updOpName f = updOp f id id++-- |update fixity of operator declaration+updOpFixity :: Update OpDecl Fixity+updOpFixity f = updOp id f id++-- |update precedence of operator declaration+updOpPrecedence :: Update OpDecl Integer+updOpPrecedence = updOp id id++-- FuncDecl ------------------------------------------------------------------++-- |transform function+trFunc :: (QName -> Int -> Visibility -> TypeExpr -> Rule -> a) -> FuncDecl -> a+trFunc func (Func name arity vis t rule) = func name arity vis t rule++-- Selectors++-- |get name of function+funcName :: FuncDecl -> QName+funcName = trFunc (\name _ _ _ _ -> name)++-- |get arity of function+funcArity :: FuncDecl -> Int+funcArity = trFunc (\_ arity _ _ _ -> arity)++-- |get visibility of function+funcVisibility :: FuncDecl -> Visibility+funcVisibility = trFunc (\_ _ vis _ _ -> vis)++-- |get type of function+funcType :: FuncDecl -> TypeExpr+funcType = trFunc (\_ _ _ t _ -> t)++-- |get rule of function+funcRule :: FuncDecl -> Rule+funcRule = trFunc (\_ _ _ _ rule -> rule)++-- Update Operations++-- |update function+updFunc :: (QName -> QName) ->+           (Int -> Int) ->+           (Visibility -> Visibility) ->+           (TypeExpr -> TypeExpr) ->+           (Rule -> Rule)             -> FuncDecl -> FuncDecl+updFunc fn fa fv ft fr = trFunc func+ where+  func name arity vis t rule+    = Func (fn name) (fa arity) (fv vis) (ft t) (fr rule)++-- |update name of function+updFuncName :: Update FuncDecl QName+updFuncName f = updFunc f id id id id++-- |update arity of function+updFuncArity :: Update FuncDecl Int+updFuncArity f = updFunc id f id id id++-- |update visibility of function+updFuncVisibility :: Update FuncDecl Visibility+updFuncVisibility f = updFunc id id f id id++-- |update type of function+updFuncType :: Update FuncDecl TypeExpr+updFuncType f = updFunc id id id f id++-- |update rule of function+updFuncRule :: Update FuncDecl Rule+updFuncRule = updFunc id id id id++-- Auxiliary Functions++-- |is function public?+isPublicFunc :: FuncDecl -> Bool+isPublicFunc = isPublic . funcVisibility++-- |is function externally defined?+isExternal :: FuncDecl -> Bool+isExternal = isRuleExternal . funcRule++-- |get variable names in a function declaration+allVarsInFunc :: FuncDecl -> [VarIndex]+allVarsInFunc = allVarsInRule . funcRule++-- |get arguments of function, if not externally defined+funcArgs :: FuncDecl -> [VarIndex]+funcArgs = ruleArgs . funcRule++-- |get body of function, if not externally defined+funcBody :: FuncDecl -> Expr+funcBody = ruleBody . funcRule++-- |get the right-hand-sides of a 'FuncDecl'+funcRHS :: FuncDecl -> [Expr]+funcRHS f | not (isExternal f) = orCase (funcBody f)+          | otherwise = []+ where+  orCase e+    | isOr e = concatMap orCase (orExps e)+    | isCase e = concatMap orCase (map branchExpr (caseBranches e))+    | otherwise = [e]++-- |rename all variables in function+rnmAllVarsInFunc :: Update FuncDecl VarIndex+rnmAllVarsInFunc = updFunc id id id id . rnmAllVarsInRule++-- |update all qualified names in function+updQNamesInFunc :: Update FuncDecl QName+updQNamesInFunc f = updFunc f id id (updQNamesInTypeExpr f) (updQNamesInRule f)++-- |update arguments of function, if not externally defined+updFuncArgs :: Update FuncDecl [VarIndex]+updFuncArgs = updFuncRule . updRuleArgs++-- |update body of function, if not externally defined+updFuncBody :: Update FuncDecl Expr+updFuncBody = updFuncRule . updRuleBody++-- Rule ----------------------------------------------------------------------++-- |transform rule+trRule :: ([VarIndex] -> Expr -> a) -> (String -> a) -> Rule -> a+trRule rule _ (Rule args e) = rule args e+trRule _ ext (External s) = ext s++-- Selectors++-- |get rules arguments if it's not external+ruleArgs :: Rule -> [VarIndex]+ruleArgs = trRule (\args _ -> args) undefined++-- |get rules body if it's not external+ruleBody :: Rule -> Expr+ruleBody = trRule (\_ e -> e) undefined++-- |get rules external declaration+ruleExtDecl :: Rule -> String+ruleExtDecl = trRule undefined id++-- Test Operations++-- |is rule external?+isRuleExternal :: Rule -> Bool+isRuleExternal = trRule (\_ _ -> False) (\_ -> True)++-- Update Operations++-- |update rule+updRule :: ([VarIndex] -> [VarIndex]) ->+           (Expr -> Expr) ->+           (String -> String) -> Rule -> Rule+updRule fa fe fs = trRule rule ext+ where+  rule args e = Rule (fa args) (fe e)+  ext s = External (fs s)++-- |update rules arguments+updRuleArgs :: Update Rule [VarIndex]+updRuleArgs f = updRule f id id++-- |update rules body+updRuleBody :: Update Rule Expr+updRuleBody f = updRule id f id++-- |update rules external declaration+updRuleExtDecl :: Update Rule String+updRuleExtDecl f = updRule id id f++-- Auxiliary Functions++-- |get variable names in a functions rule+allVarsInRule :: Rule -> [VarIndex]+allVarsInRule = trRule (\args body -> args ++ allVars body) (\_ -> [])++-- |rename all variables in rule+rnmAllVarsInRule :: Update Rule VarIndex+rnmAllVarsInRule f = updRule (map f) (rnmAllVars f) id++-- |update all qualified names in rule+updQNamesInRule :: Update Rule QName+updQNamesInRule = updRuleBody . updQNames++-- CombType ------------------------------------------------------------------++-- |transform combination type+trCombType :: a -> (Int -> a) -> a -> (Int -> a) -> CombType -> a+trCombType fc _ _ _ FuncCall = fc+trCombType _ fpc _ _ (FuncPartCall n) = fpc n+trCombType _ _ cc _ ConsCall = cc+trCombType _ _ _ cpc (ConsPartCall n) = cpc n++-- Test Operations++-- |is type of combination FuncCall?+isCombTypeFuncCall :: CombType -> Bool+isCombTypeFuncCall = trCombType True (\_ -> False) False (\_ -> False)++-- |is type of combination FuncPartCall?+isCombTypeFuncPartCall :: CombType -> Bool+isCombTypeFuncPartCall = trCombType False (\_ -> True) False (\_ -> False)++-- |is type of combination ConsCall?+isCombTypeConsCall :: CombType -> Bool+isCombTypeConsCall = trCombType False (\_ -> False) True (\_ -> False)++-- |is type of combination ConsPartCall?+isCombTypeConsPartCall :: CombType -> Bool+isCombTypeConsPartCall = trCombType False (\_ -> False) False (\_ -> True)++-- Expr ----------------------------------------------------------------------++-- Selectors++-- |get internal number of variable+varNr :: Expr -> VarIndex+varNr (Var n) = n+varNr _       = error "Curry.FlatCurry.Goodies.varNr: no variable"++-- |get literal if expression is literal expression+literal :: Expr -> Literal+literal (Lit l) = l+literal _       = error "Curry.FlatCurry.Goodies.literal: no literal"++-- |get combination type of a combined expression+combType :: Expr -> CombType+combType (Comb ct _ _) = ct+combType _             = error $ "Curry.FlatCurry.Goodies.combType: " +++                                 "no combined expression"++-- |get name of a combined expression+combName :: Expr -> QName+combName (Comb _ name _) = name+combName _               = error $ "Curry.FlatCurry.Goodies.combName: " +++                                 "no combined expression"++-- |get arguments of a combined expression+combArgs :: Expr -> [Expr]+combArgs (Comb _ _ args) = args+combArgs _               = error $ "Curry.FlatCurry.Goodies.combArgs: " +++                                 "no combined expression"++-- |get number of missing arguments if expression is combined+missingCombArgs :: Expr -> Int+missingCombArgs = missingArgs . combType+  where+  missingArgs :: CombType -> Int+  missingArgs = trCombType 0 id 0 id++-- |get indices of varoables in let declaration+letBinds :: Expr -> [(VarIndex,Expr)]+letBinds (Let vs _) = vs+letBinds _          = error $ "Curry.FlatCurry.Goodies.letBinds: " +++                              "no let expression"++-- |get body of let declaration+letBody :: Expr -> Expr+letBody (Let _ e) = e+letBody _         = error $ "Curry.FlatCurry.Goodies.letBody: " +++                              "no let expression"++-- |get variable indices from declaration of free variables+freeVars :: Expr -> [VarIndex]+freeVars (Free vs _) = vs+freeVars _           = error $ "Curry.FlatCurry.Goodies.freeVars: " +++                               "no declaration of free variables"++-- |get expression from declaration of free variables+freeExpr :: Expr -> Expr+freeExpr (Free _ e) = e+freeExpr _           = error $ "Curry.FlatCurry.Goodies.freeExpr: " +++                               "no declaration of free variables"++-- |get expressions from or-expression+orExps :: Expr -> [Expr]+orExps (Or e1 e2) = [e1,e2]+orExps _          = error $ "Curry.FlatCurry.Goodies.orExps: " +++                            "no or expression"++-- |get case-type of case expression+caseType :: Expr -> CaseType+caseType (Case ct _ _) = ct+caseType _               = error $ "Curry.FlatCurry.Goodies.caseType: " +++                                   "no case expression"++-- |get scrutinee of case expression+caseExpr :: Expr -> Expr+caseExpr (Case _ e _) = e+caseExpr _              = error $ "Curry.FlatCurry.Goodies.caseExpr: " +++                                  "no case expression"+++-- |get branch expressions from case expression+caseBranches :: Expr -> [BranchExpr]+caseBranches (Case _ _ bs) = bs+caseBranches _             = error+  "Curry.FlatCurry.Goodies.caseBranches: no case expression"++-- Test Operations++-- |is expression a variable?+isVar :: Expr -> Bool+isVar e = case e of+  Var _ -> True+  _ -> False++-- |is expression a literal expression?+isLit :: Expr -> Bool+isLit e = case e of+  Lit _ -> True+  _ -> False++-- |is expression combined?+isComb :: Expr -> Bool+isComb e = case e of+  Comb _ _ _ -> True+  _ -> False++-- |is expression a let expression?+isLet :: Expr -> Bool+isLet e = case e of+  Let _ _ -> True+  _ -> False++-- |is expression a declaration of free variables?+isFree :: Expr -> Bool+isFree e = case e of+  Free _ _ -> True+  _ -> False++-- |is expression an or-expression?+isOr :: Expr -> Bool+isOr e = case e of+  Or _ _ -> True+  _ -> False++-- |is expression a case expression?+isCase :: Expr -> Bool+isCase e = case e of+  Case _ _ _ -> True+  _ -> False++-- |transform expression+trExpr  :: (VarIndex -> a)+        -> (Literal -> a)+        -> (CombType -> QName -> [a] -> a)+        -> ([(VarIndex, a)] -> a -> a)+        -> ([VarIndex] -> a -> a)+        -> (a -> a -> a)+        -> (CaseType -> a -> [b] -> a)+        -> (Pattern -> a -> b)+        -> (a -> TypeExpr -> a)+        -> Expr+        -> a+trExpr var lit comb lt fr oR cas branch typed expr = case expr of+  Var n             -> var n+  Lit l             -> lit l+  Comb ct name args -> comb ct name (map f args)+  Let bs e          -> lt (map (\(v, x) -> (v, f x)) bs) (f e)+  Free vs e         -> fr vs (f e)+  Or e1 e2          -> oR (f e1) (f e2)+  Case ct e bs      -> cas ct (f e) (map (\ (Branch p e') -> branch p (f e')) bs)+  Typed e ty        -> typed (f e) ty+  where+  f = trExpr var lit comb lt fr oR cas branch typed++-- Update Operations++-- |update all variables in given expression+updVars :: (VarIndex -> Expr) -> Expr -> Expr+updVars var = trExpr var Lit Comb Let Free Or Case Branch Typed++-- |update all literals in given expression+updLiterals :: (Literal -> Expr) -> Expr -> Expr+updLiterals lit = trExpr Var lit Comb Let Free Or Case Branch Typed++-- |update all combined expressions in given expression+updCombs :: (CombType -> QName -> [Expr] -> Expr) -> Expr -> Expr+updCombs comb = trExpr Var Lit comb Let Free Or Case Branch Typed++-- |update all let expressions in given expression+updLets :: ([(VarIndex,Expr)] -> Expr -> Expr) -> Expr -> Expr+updLets lt = trExpr Var Lit Comb lt Free Or Case Branch Typed++-- |update all free declarations in given expression+updFrees :: ([VarIndex] -> Expr -> Expr) -> Expr -> Expr+updFrees fr = trExpr Var Lit Comb Let fr Or Case Branch Typed++-- |update all or expressions in given expression+updOrs :: (Expr -> Expr -> Expr) -> Expr -> Expr+updOrs oR = trExpr Var Lit Comb Let Free oR Case Branch Typed++-- |update all case expressions in given expression+updCases :: (CaseType -> Expr -> [BranchExpr] -> Expr) -> Expr -> Expr+updCases cas = trExpr Var Lit Comb Let Free Or cas Branch Typed++-- |update all case branches in given expression+updBranches :: (Pattern -> Expr -> BranchExpr) -> Expr -> Expr+updBranches branch = trExpr Var Lit Comb Let Free Or Case branch Typed++-- |update all typed expressions in given expression+updTypeds :: (Expr -> TypeExpr -> Expr) -> Expr -> Expr+updTypeds = trExpr Var Lit Comb Let Free Or Case Branch++-- Auxiliary Functions++-- |is expression a call of a function where all arguments are provided?+isFuncCall :: Expr -> Bool+isFuncCall e = isComb e && isCombTypeFuncCall (combType e)++-- |is expression a partial function call?+isFuncPartCall :: Expr -> Bool+isFuncPartCall e = isComb e && isCombTypeFuncPartCall (combType e)++-- |is expression a call of a constructor?+isConsCall :: Expr -> Bool+isConsCall e = isComb e && isCombTypeConsCall (combType e)++-- |is expression a partial constructor call?+isConsPartCall :: Expr -> Bool+isConsPartCall e = isComb e && isCombTypeConsPartCall (combType e)++-- |is expression fully evaluated?+isGround :: Expr -> Bool+isGround e+  = case e of+      Comb ConsCall _ args -> all isGround args+      _ -> isLit e++-- |get all variables (also pattern variables) in expression+allVars :: Expr -> [VarIndex]+allVars e = trExpr (:) (const id) comb lt fr (.) cas branch const e []+ where+  comb _ _ = foldr (.) id+  lt bs e' = e' . foldr (.) id (map (\ (n,ns) -> (n:) . ns) bs)+  fr vs e' = (vs++) . e'+  cas _ e' bs = e' . foldr (.) id bs+  branch pat e' = ((args pat)++) . e'+  args pat | isConsPattern pat = patArgs pat+           | otherwise = []++-- |rename all variables (also in patterns) in expression+rnmAllVars :: Update Expr VarIndex+rnmAllVars f = trExpr (Var . f) Lit Comb lt (Free . map f) Or Case branch Typed+ where+   lt = Let . map (\ (n,e) -> (f n,e))+   branch = Branch . updPatArgs (map f)++-- |update all qualified names in expression+updQNames :: Update Expr QName+updQNames f = trExpr Var Lit comb Let Free Or Case (Branch . updPatCons f) Typed+ where+  comb ct name args = Comb ct (f name) args++-- BranchExpr ----------------------------------------------------------------++-- |transform branch expression+trBranch :: (Pattern -> Expr -> a) -> BranchExpr -> a+trBranch branch (Branch pat e) = branch pat e++-- Selectors++-- |get pattern from branch expression+branchPattern :: BranchExpr -> Pattern+branchPattern = trBranch (\pat _ -> pat)++-- |get expression from branch expression+branchExpr :: BranchExpr -> Expr+branchExpr = trBranch (\_ e -> e)++-- Update Operations++-- |update branch expression+updBranch :: (Pattern -> Pattern) -> (Expr -> Expr) -> BranchExpr -> BranchExpr+updBranch fp fe = trBranch branch+ where+  branch pat e = Branch (fp pat) (fe e)++-- |update pattern of branch expression+updBranchPattern :: Update BranchExpr Pattern+updBranchPattern f = updBranch f id++-- |update expression of branch expression+updBranchExpr :: Update BranchExpr Expr+updBranchExpr = updBranch id++-- Pattern -------------------------------------------------------------------++-- |transform pattern+trPattern :: (QName -> [VarIndex] -> a) -> (Literal -> a) -> Pattern -> a+trPattern pattern _ (Pattern name args) = pattern name args+trPattern _ lpattern (LPattern l) = lpattern l++-- Selectors++-- |get name from constructor pattern+patCons :: Pattern -> QName+patCons = trPattern (\name _ -> name) undefined++-- |get arguments from constructor pattern+patArgs :: Pattern -> [VarIndex]+patArgs = trPattern (\_ args -> args) undefined++-- |get literal from literal pattern+patLiteral :: Pattern -> Literal+patLiteral = trPattern undefined id++-- Test Operations++-- |is pattern a constructor pattern?+isConsPattern :: Pattern -> Bool+isConsPattern = trPattern (\_ _ -> True) (\_ -> False)++-- Update Operations++-- |update pattern+updPattern :: (QName -> QName) ->+              ([VarIndex] -> [VarIndex]) ->+              (Literal -> Literal) -> Pattern -> Pattern+updPattern fn fa fl = trPattern pattern lpattern+ where+  pattern name args = Pattern (fn name) (fa args)+  lpattern l = LPattern (fl l)++-- |update constructors name of pattern+updPatCons :: (QName -> QName) -> Pattern -> Pattern+updPatCons f = updPattern f id id++-- |update arguments of constructor pattern+updPatArgs :: ([VarIndex] -> [VarIndex]) -> Pattern -> Pattern+updPatArgs f = updPattern id f id++-- |update literal of pattern+updPatLiteral :: (Literal -> Literal) -> Pattern -> Pattern+updPatLiteral f = updPattern id id f++-- Auxiliary Functions++-- |build expression from pattern+patExpr :: Pattern -> Expr+patExpr = trPattern (\ name -> Comb ConsCall name . map Var) Lit++-- |Is this a public 'Visibility'?+isPublic :: Visibility -> Bool+isPublic = (== Public)
+ src/Curry/FlatCurry/InterfaceEquivalence.hs view
@@ -0,0 +1,58 @@+{- |+    Module      :  $Header$+    Description :  Check the equality of two FlatCurry interfaces+    Copyright   :  (c) 2006       , Martin Engelke+                       2011 - 2014, Björn Peemöller+                       2014       , Jan Tikovsky+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable+-}++module Curry.FlatCurry.InterfaceEquivalence (eqInterface) where++import Data.List (deleteFirstsBy)++import Curry.FlatCurry.Type++infix 4 =~=, `eqvSet`++-- |Check whether the interfaces of two FlatCurry programs are equivalent.+eqInterface :: Prog -> Prog -> Bool+eqInterface = (=~=)++-- |Type class to express the equivalence of two values+class Equiv a where+  (=~=) :: a -> a -> Bool++instance Equiv a => Equiv [a] where+  []     =~= []     = True+  (x:xs) =~= (y:ys) = x =~= y && xs =~= ys+  _      =~= _      = False++instance Equiv Char where (=~=) = (==)++-- |Equivalence of lists independent of the order.+eqvSet :: Equiv a => [a] -> [a] -> Bool+xs `eqvSet` ys = null (deleteFirstsBy (=~=) xs ys ++ deleteFirstsBy (=~=) ys xs)++instance Equiv Prog where+  Prog m1 is1 ts1 fs1 os1 =~= Prog m2 is2 ts2 fs2 os2+    = m1 == m2 && is1 `eqvSet` is2 && ts1 `eqvSet` ts2+               && fs1 `eqvSet` fs2 && os1 `eqvSet` os2++instance Equiv TypeDecl where (=~=) = (==)++instance Equiv FuncDecl where+  Func qn1 ar1 vis1 ty1 r1 =~= Func qn2 ar2 vis2 ty2 r2+    = qn1 == qn2 && ar1 == ar2 && vis1 == vis2 && ty1 == ty2 && r1 =~= r2++-- TODO: Check why arguments of rules are not checked for equivalence+instance Equiv Rule where+  Rule _ _   =~= Rule _ _   = True+  External _ =~= External _ = True+  _          =~= _          = False++instance Equiv OpDecl where (=~=) = (==)
+ src/Curry/FlatCurry/Pretty.hs view
@@ -0,0 +1,217 @@+{- |+    Module      :  $Header$+    Description :  A pretty printer for FlatCurry+    Copyright   :  (c) 2015 Björn Peemöller+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module implements a pretty printer for FlatCurry modules.+-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Curry.FlatCurry.Pretty (pPrint, pPrintPrec) where++import Prelude hiding ((<>))+import Data.Char      (ord)++import Curry.Base.Pretty+import Curry.FlatCurry.Type++instance Pretty Prog where+  pPrint (Prog m is ts fs os) = sepByBlankLine+    [ ppHeader m ts fs+    , vcat           (map ppImport is)+    , vcat           (map pPrint   os)+    , sepByBlankLine (map pPrint   ts)+    , sepByBlankLine (map pPrint   fs)+    ]++ppHeader :: String -> [TypeDecl] -> [FuncDecl] -> Doc+ppHeader m ts fs = sep+  [text "module" <+> text m, ppExports ts fs, text "where"]++-- |pretty-print the export list+ppExports :: [TypeDecl] -> [FuncDecl] -> Doc+ppExports ts fs = parens $ list (map ppTypeExport ts ++ ppFuncExports fs)++ppTypeExport :: TypeDecl -> Doc+ppTypeExport (Type    qn vis _ cs)+  | vis == Private      = empty+  | all isPublicCons cs = ppPrefixOp qn <+> text "(..)"+  | otherwise           = ppPrefixOp qn <+> parens (list (ppConsExports cs))+    where isPublicCons (Cons _ _ v _) = v == Public+ppTypeExport (TypeNew qn vis _ nc)+  | vis == Private  = empty+  | isPublicCons nc = ppPrefixOp qn <+> text "(..)"+  | otherwise       = ppPrefixOp qn <+> parens empty+    where isPublicCons (NewCons _ v _) = v == Public+ppTypeExport (TypeSyn qn vis _ _ )+  | vis == Private = empty+  | otherwise      = ppPrefixOp qn++-- |pretty-print the export list of constructors+ppConsExports :: [ConsDecl] -> [Doc]+ppConsExports cs = [ ppPrefixOp qn | Cons qn _ Public _ <- cs]++-- |pretty-print the export list of functions+ppFuncExports :: [FuncDecl] -> [Doc]+ppFuncExports fs = [ ppPrefixOp qn | Func qn _ Public _ _ <- fs]++-- |pretty-print an import statement+ppImport :: String -> Doc+ppImport m = text "import" <+> text m++instance Pretty OpDecl where+  pPrint(Op qn fix n) = pPrint fix <+> integer n <+> ppInfixOp qn++instance Pretty Fixity where+  pPrint InfixOp  = text "infix"+  pPrint InfixlOp = text "infixl"+  pPrint InfixrOp = text "infixr"++instance Pretty TypeDecl where+  pPrint (Type    qn _ vs cs) = text "data" <+> ppQName qn+    <+> hsep (ppTVarIndex <$> fst <$> vs) $+$ ppConsDecls cs+  pPrint (TypeSyn qn _ vs ty) = text "type" <+> ppQName qn+    <+> hsep (ppTVarIndex <$> fst <$> vs) <+> equals <+> pPrintPrec 0 ty+  pPrint (TypeNew qn _ vs nc) = text "newtype" <+> ppQName qn+    <+> hsep (ppTVarIndex <$> fst <$> vs) <+> equals <+> pPrint nc++-- |pretty-print the constructor declarations+ppConsDecls :: [ConsDecl] -> Doc+ppConsDecls cs = indent $ vcat $+  zipWith (<+>) (equals : repeat (char '|')) (map pPrint cs)++instance Pretty ConsDecl where+  pPrint (Cons qn _ _ tys) = fsep $ ppPrefixOp qn : map (pPrintPrec 2) tys++instance Pretty NewConsDecl where+  pPrint (NewCons qn _ ty) = fsep [pPrint qn, pPrintPrec 2 ty]++instance Pretty TypeExpr where+  pPrintPrec _ (TVar           i) = ppTVarIndex i+  pPrintPrec p (FuncType ty1 ty2) = parenIf (p > 0) $ fsep+    [pPrintPrec 1 ty1, rarrow, pPrintPrec 0 ty2]+  pPrintPrec p (TCons     qn tys) = parenIf (p > 1 && not (null tys)) $ fsep+    (ppPrefixOp qn : map (pPrintPrec 2) tys)+  pPrintPrec p (ForallType vs ty)+    | null vs   = pPrintPrec p ty+    | otherwise = parenIf (p > 0) $ ppQuantifiedVars vs <+> pPrintPrec 0 ty++-- |pretty-print explicitly quantified type variables (without kinds)+ppQuantifiedVars :: [(TVarIndex, Kind)] -> Doc+ppQuantifiedVars vs+  | null vs = empty+  | otherwise = text "forall" <+> hsep (map ppTVar vs) <> char '.'++ppTVar :: (TVarIndex, Kind) -> Doc+ppTVar (i, _) = ppTVarIndex i++-- |pretty-print a type variable+ppTVarIndex :: TVarIndex -> Doc+ppTVarIndex i = text $ vars !! i+  where vars = [ if n == 0 then [c] else c : show n+               | n <- [0 :: Int ..], c <- ['a' .. 'z']+               ]++instance Pretty FuncDecl where+  pPrint (Func qn _ _ ty r)+    = hsep [ppPrefixOp qn, text "::", pPrintPrec 0 ty]+      $+$ ppPrefixOp qn <+> pPrint r++instance Pretty Rule where+  pPrint (Rule  vs e) =+    fsep (map ppVarIndex vs) <+> equals <+> indent (pPrintPrec 0 e)+  pPrint (External _) = text "external"++instance Pretty Expr where+  pPrintPrec _ (Var        v) = ppVarIndex v+  pPrintPrec _ (Lit        l) = pPrint l+  pPrintPrec p (Comb _ qn es) = ppComb p qn es+  pPrintPrec p (Free    vs e)+    | null vs             = pPrintPrec p e+    | otherwise           = parenIf (p > 0) $ sep+                            [ text "let" <+> list (map ppVarIndex vs)+                                         <+> text "free"+                            , text "in"  <+> pPrintPrec 0 e+                            ]+  pPrintPrec p (Let     ds e) = parenIf (p > 0) $+    sep [text "let" <+> ppDecls ds, text "in" <+> pPrintPrec 0 e]+  pPrintPrec p (Or     e1 e2) = parenIf (p > 0) $+    pPrintPrec 1 e1 <+> text "?" <+> pPrintPrec 1 e2+  pPrintPrec p (Case ct e bs) = parenIf (p > 0) $+    pPrint ct <+> pPrintPrec 0 e <+> text "of" $$ indent (vcat (map pPrint bs))+  pPrintPrec p (Typed   e ty) = parenIf (p > 0) $+    pPrintPrec 0 e <+> text "::" <+> pPrintPrec 0 ty++-- |pretty-print a variable+ppVarIndex :: VarIndex -> Doc+ppVarIndex i = text $ 'v' : show i++instance Pretty Literal where+  pPrint (Intc   i) = integer i+  pPrint (Floatc f) = double  f+  pPrint (Charc  c) = text (showEscape c)++-- |Escape character literal+showEscape :: Char -> String+showEscape c+  | o <   10  = "'\\00" ++ show o ++ "'"+  | o <   32  = "'\\0"  ++ show o ++ "'"+  | o == 127  = "'\\127'"+  | otherwise = show c+  where o = ord c++-- |Pretty print a constructor or function call+ppComb :: Int -> QName -> [Expr] -> Doc+ppComb _ qn []      = ppPrefixOp qn+ppComb p qn [e1,e2]+  | isInfixOp qn    = parenIf (p > 0)+                    $ hsep [pPrintPrec 1 e1, pPrint qn, pPrintPrec 1 e2]+ppComb p qn es      = parenIf (p > 0)+                    $ hsep (ppPrefixOp qn : map (pPrintPrec 1) es)++-- |pretty-print a list of declarations+ppDecls :: [(VarIndex, Expr)] -> Doc+ppDecls = vcat . map ppDecl++-- |pretty-print a single declaration+ppDecl :: (VarIndex, Expr) -> Doc+ppDecl (v, e) = ppVarIndex v <+> equals <+> pPrintPrec 0 e++instance Pretty CaseType where+  pPrint Rigid = text "case"+  pPrint Flex  = text "fcase"++instance Pretty BranchExpr where+  pPrint (Branch p e) = pPrint p <+> rarrow <+> pPrintPrec 0 e++instance Pretty Pattern where+  pPrint (Pattern c [v1,v2])+    | isInfixOp c            = ppVarIndex v1 <+> ppInfixOp c <+> ppVarIndex v2+  pPrint (Pattern  c     vs) = fsep (ppPrefixOp c : map ppVarIndex vs)+  pPrint (LPattern        l) = pPrint l++-- Names++-- |pretty-print a prefix operator+ppPrefixOp :: QName -> Doc+ppPrefixOp qn = parenIf (isInfixOp qn) (ppQName qn)++-- |pretty-print a name in infix manner+ppInfixOp :: QName -> Doc+ppInfixOp qn = if isInfixOp qn then ppQName qn else bquotes (ppQName qn)++-- |pretty-print a qualified name+ppQName :: QName -> Doc+ppQName (m, i) = text $ m ++ '.' : i++-- |Check whether an operator is an infix operator+isInfixOp :: QName -> Bool+isInfixOp = all (`elem` "~!@#$%^&*+-=<>:?./|\\") . snd++-- Indentation+indent :: Doc -> Doc+indent = nest 2
+ src/Curry/FlatCurry/Type.hs view
@@ -0,0 +1,521 @@+{- |+    Module      : $Header$+    Description : Representation of FlatCurry.+    Copyright   : (c) Michael Hanus  2003+                      Martin Engelke 2004+                      Bernd Brassel  2005+    License     : BSD-3-clause++    Maintainer  : bjp@informatik.uni-kiel.de+    Stability   : experimental+    Portability : portable++    This module contains a definition for representing FlatCurry programs+    in Haskell in type 'Prog'.+-}++module Curry.FlatCurry.Type+  ( -- * Representation of qualified names and (type) variables+    QName, VarIndex, TVarIndex, TVarWithKind+    -- * Data types for FlatCurry+  , Visibility (..), Prog (..), TypeDecl (..), TypeExpr (..), Kind (..)+  , ConsDecl (..), NewConsDecl(..), OpDecl (..), Fixity (..)+  , FuncDecl (..), Rule (..), Expr (..), Literal (..)+  , CombType (..), CaseType (..), BranchExpr (..), Pattern (..)+  ) where++import Data.Binary+import Control.Monad++-- ---------------------------------------------------------------------------+-- Qualified names+-- ---------------------------------------------------------------------------++-- |Qualified names.+--+-- In FlatCurry all names are qualified to avoid name clashes.+-- The first component is the module name and the second component the+-- unqualified name as it occurs in the source program.+type QName = (String, String)++-- ---------------------------------------------------------------------------+-- Variable representation+-- ---------------------------------------------------------------------------++-- |Representation of variables.+type VarIndex = Int++-- ---------------------------------------------------------------------------+-- FlatCurry representation+-- ---------------------------------------------------------------------------++-- |Visibility of various entities.+data Visibility+  = Public    -- ^ public (exported) entity+  | Private   -- ^ private entity+    deriving (Eq, Read, Show)++-- |A FlatCurry module.+--+-- A value of this data type has the form+--+-- @Prog modname imports typedecls functions opdecls@+--+-- where+--+-- [@modname@]   Name of this module+-- [@imports@]   List of modules names that are imported+-- [@typedecls@] Type declarations+-- [@funcdecls@] Function declarations+-- [@ opdecls@]  Operator declarations+data Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl]+    deriving (Eq, Read, Show)++-- |Declaration of algebraic data type or type synonym.+--+-- A data type declaration of the form+--+-- @data t x1...xn = ...| c t1....tkc |...@+--+-- is represented by the FlatCurry term+--+-- @Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...]@+--+-- where each @ij@ is the index of the type variable @xj@+--+-- /Note:/ The type variable indices are unique inside each type declaration+--         and are usually numbered from 0.+--+-- Thus, a data type declaration consists of the name of the data type,+-- a list of type parameters and a list of constructor declarations.+data TypeDecl+  = Type    QName Visibility [TVarWithKind] [ConsDecl]+  | TypeSyn QName Visibility [TVarWithKind] TypeExpr+  | TypeNew QName Visibility [TVarWithKind] NewConsDecl+    deriving (Eq, Read, Show)++-- |Type variables are represented by @(TVar i)@ where @i@ is a+-- type variable index.+type TVarIndex = Int++-- |Kinded type variables are represented by a tuple of type variable+-- index and kind.+type TVarWithKind = (TVarIndex, Kind)++-- |A constructor declaration consists of the name and arity of the+-- constructor and a list of the argument types of the constructor.+data ConsDecl = Cons QName Int Visibility [TypeExpr]+    deriving (Eq, Read, Show)++-- |A constructor declaration for a newtype consists+-- of the name of the constructor+-- and the argument type of the constructor.+data NewConsDecl = NewCons QName Visibility TypeExpr+    deriving (Eq, Read, Show)++-- |Type expressions.+--+-- A type expression is either a type variable, a function type,+-- or a type constructor application.+--+-- /Note:/ the names of the predefined type constructors are+-- @Int@, @Float@, @Bool@, @Char@, @IO@, @Success@,+-- @()@ (unit type), @(,...,)@ (tuple types), @[]@ (list type)+data TypeExpr+  = TVar        TVarIndex               -- ^ type variable+  | FuncType    TypeExpr TypeExpr       -- ^ function type @t1 -> t2@+  | TCons QName [TypeExpr]              -- ^ type constructor application+  | ForallType  [TVarWithKind] TypeExpr -- ^ forall type+    deriving (Eq, Read, Show)++-- |Kinds.+--+-- A kind is either * or k_1 -> k_2 where k_1 and k_2 are kinds.+data Kind+  = KStar            -- ^ star kind+  | KArrow Kind Kind -- ^ arrow kind+ deriving (Eq, Ord, Read, Show)+    +-- |Operator declarations.+--+-- An operator declaration @fix p n@ in Curry corresponds to the+-- FlatCurry term @(Op n fix p)@.+--+-- /Note:/ the constructor definition of 'Op' differs from the original+-- PAKCS definition using Haskell type 'Integer' instead of 'Int'+-- for representing the precedence.+data OpDecl = Op QName Fixity Integer+    deriving (Eq, Read, Show)++-- |Fixity of an operator.+data Fixity+  = InfixOp  -- ^ non-associative infix operator+  | InfixlOp -- ^ left-associative infix operator+  | InfixrOp -- ^ right-associative infix operator+    deriving (Eq, Read, Show)++-- |Data type for representing function declarations.+--+-- A function declaration in FlatCurry is a term of the form+--+-- @(Func name arity type (Rule [i_1,...,i_arity] e))@+--+-- and represents the function "name" with definition+--+-- @+-- name :: type+-- name x_1...x_arity = e+-- @+--+-- where each @i_j@ is the index of the variable @x_j@+--+-- /Note:/ The variable indices are unique inside each function declaration+--         and are usually numbered from 0.+--+-- External functions are represented as+--+-- @Func name arity type (External s)@+--+-- where s is the external name associated to this function.+--+-- Thus, a function declaration consists of the name, arity, type, and rule.+data FuncDecl = Func QName Int Visibility TypeExpr Rule+    deriving (Eq, Read, Show)++-- |A rule is either a list of formal parameters together with an expression+-- or an 'External' tag.+data Rule+  = Rule [VarIndex] Expr+  | External String+    deriving (Eq, Read, Show)++-- |Data type for representing expressions.+--+-- Remarks:+--+-- 1.if-then-else expressions are represented as function calls:+--+--   @(if e1 then e2 else e3)@+--+--   is represented as+--+--   @(Comb FuncCall ("Prelude","ifThenElse") [e1,e2,e3])@+--+-- 2.Higher order applications are represented as calls to the (external)+--   function @apply@. For instance, the rule+--+--   @app f x = f x@+--+--   is represented as+--+--   @(Rule  [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1]))@+--+-- 3.A conditional rule is represented as a call to an external function+--   @cond@ where the first argument is the condition (a constraint).+--+--   For instance, the rule+--+--   @equal2 x | x=:=2 = success@+--+--   is represented as+--+--   @+--   (Rule [0]+--       (Comb FuncCall ("Prelude","cond")+--             [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)],+--             Comb FuncCall ("Prelude","success") []]))+--   @+--+-- 4.Functions with evaluation annotation @choice@ are represented+--   by a rule whose right-hand side is enclosed in a call to the+--   external function @Prelude.commit@.+--   Furthermore, all rules of the original definition must be+--   represented by conditional expressions (i.e., (cond [c,e]))+--   after pattern matching.+--+--   Example:+--+--   @+--   m eval choice+--   m [] y = y+--   m x [] = x+--   @+--+--   is translated into (note that the conditional branches can be also+--   wrapped with Free declarations in general):+--+--   @+--   Rule [0,1]+--     (Comb FuncCall ("Prelude","commit")+--       [Or (Case Rigid (Var 0)+--             [(Pattern ("Prelude","[]") []+--                 (Comb FuncCall ("Prelude","cond")+--                       [Comb FuncCall ("Prelude","success") [],+--                         Var 1]))] )+--           (Case Rigid (Var 1)+--             [(Pattern ("Prelude","[]") []+--                 (Comb FuncCall ("Prelude","cond")+--                       [Comb FuncCall ("Prelude","success") [],+--                         Var 0]))] )])+--   @+--+--   Operational meaning of @(Prelude.commit e)@:+--   evaluate @e@ with local search spaces and commit to the first+--   @(Comb FuncCall ("Prelude","cond") [c,ge])@ in @e@ whose constraint @c@+--   is satisfied+data Expr+  -- |Variable, represented by unique index+  = Var VarIndex+  -- |Literal (Integer/Float/Char constant)+  | Lit Literal+  -- |Application @(f e1 ... en)@ of function/constructor @f@+  --  with @n <= arity f@+  | Comb CombType QName [Expr]+  -- |Introduction of free local variables for an expression+  | Free [VarIndex] Expr+  -- |Local let-declarations+  | Let [(VarIndex, Expr)] Expr+  -- |Disjunction of two expressions+  -- (resulting from overlapping left-hand sides)+  | Or Expr Expr+  -- |case expression+  | Case CaseType Expr [BranchExpr]+  -- |typed expression+  | Typed Expr TypeExpr+    deriving (Eq, Read, Show)++-- |Data type for representing literals.+--+-- A literal  is either an integer, a float, or a character constant.+--+-- /Note:/ The constructor definition of 'Intc' differs from the original+-- PAKCS definition. It uses Haskell type 'Integer' instead of 'Int'+-- to provide an unlimited range of integer numbers. Furthermore,+-- float values are represented with Haskell type 'Double' instead of+-- 'Float'.+data Literal+  = Intc   Integer+  | Floatc Double+  | Charc  Char+    deriving (Eq, Read, Show)++-- |Data type for classifying combinations+-- (i.e., a function/constructor applied to some arguments).+data CombType+  -- |a call to a function where all arguments are provided+  = FuncCall+  -- |a call with a constructor at the top, all arguments are provided+  | ConsCall+  -- |a partial call to a function (i.e., not all arguments are provided)+  --  where the parameter is the number of missing arguments+  | FuncPartCall Int+  -- |a partial call to a constructor along with number of missing arguments+  | ConsPartCall Int+    deriving (Eq, Read, Show)++-- |Classification of case expressions, either flexible or rigid.+data CaseType+  = Rigid+  | Flex+    deriving (Eq, Read, Show)++-- |Branches in a case expression.+--+-- Branches @(m.c x1...xn) -> e@ in case expressions are represented as+--+-- @(Branch (Pattern (m,c) [i1,...,in]) e)@+--+-- where each @ij@ is the index of the pattern variable @xj@, or as+--+-- @(Branch (LPattern (Intc i)) e)@+--+-- for integers as branch patterns (similarly for other literals+-- like float or character constants).+data BranchExpr = Branch Pattern Expr+    deriving (Eq, Read, Show)++-- |Patterns in case expressions.+data Pattern+  = Pattern QName [VarIndex]+  | LPattern Literal+    deriving (Eq, Read, Show)++instance Binary Visibility where+  put Public  = putWord8 0+  put Private = putWord8 1++  get = do+    x <- getWord8+    case x of+      0 -> return Public+      1 -> return Private+      _ -> fail "Invalid encoding for Visibility"++instance Binary Prog where+  put (Prog mid im tys fus ops) =+    put mid >> put im >> put tys >> put fus >> put ops+  get = Prog <$> get <*> get <*> get <*> get <*> get++instance Binary TypeDecl where+  put (Type    qid vis vs cs) =+    putWord8 0 >> put qid >> put vis >> put vs >> put cs+  put (TypeSyn qid vis vs ty) =+    putWord8 1 >> put qid >> put vis >> put vs >> put ty+  put (TypeNew qid vis vs c ) =+    putWord8 2 >> put qid >> put vis >> put vs >> put c++  get = do+    x <- getWord8+    case x of+      0 -> liftM4 Type get get get get+      1 -> liftM4 TypeSyn get get get get+      2 -> liftM4 TypeNew get get get get+      _ -> fail "Invalid encoding for TypeDecl"++instance Binary ConsDecl where+  put (Cons qid arity vis tys) = put qid >> put arity >> put vis >> put tys+  get = Cons <$> get <*> get <*> get <*> get++instance Binary NewConsDecl where+  put (NewCons qid vis ty) = put qid >> put vis >> put ty+  get = NewCons <$> get <*> get <*> get++instance Binary TypeExpr where+  put (TVar tv) =+    putWord8 0 >> put tv+  put (FuncType ty1 ty2) =+    putWord8 1 >> put ty1 >> put ty2+  put (TCons qid tys) =+    putWord8 2 >> put qid >> put tys+  put (ForallType vs ty) =+    putWord8 3 >> put vs >> put ty++  get = do+    x <- getWord8+    case x of+      0 -> fmap TVar get+      1 -> liftM2 FuncType get get+      2 -> liftM2 TCons get get+      3 -> liftM2 ForallType get get+      _ -> fail "Invalid encoding for TypeExpr"++instance Binary Kind where+  put KStar          = putWord8 0+  put (KArrow k1 k2) = putWord8 1 >> put k1 >> put k2+  get = do+    x <- getWord8+    case x of+      0 -> return KStar+      1 -> liftM2 KArrow get get+      _ -> fail "Invalid encoding for Kind"++instance Binary OpDecl where+  put (Op qid fix pr) = put qid >> put fix >> put pr+  get = liftM3 Op get get get++instance Binary Fixity where+  put InfixOp  = putWord8 0+  put InfixlOp = putWord8 1+  put InfixrOp = putWord8 2++  get = do+    x <- getWord8+    case x of+      0 -> return InfixOp+      1 -> return InfixlOp+      2 -> return InfixrOp+      _ -> fail "Invalid encoding for Fixity"++instance Binary FuncDecl where+  put (Func qid arity vis ty r) =+    put qid >> put arity >> put vis >> put ty >> put r+  get = Func <$> get <*> get <*> get <*> get <*> get++instance Binary Rule where+  put (Rule     alts e) = putWord8 0 >> put alts >> put e+  put (External n     ) = putWord8 1 >> put n++  get = do+    x <- getWord8+    case x of+      0 -> liftM2 Rule get get+      1 -> fmap External get+      _ -> fail "Invalid encoding for TRule"++instance Binary Expr where+  put (Var v) = putWord8 0 >> put v+  put (Lit l) = putWord8 1 >> put l+  put (Comb cty qid es) =+    putWord8 2 >> put cty >> put qid >> put es+  put (Let  bs e) = putWord8 3 >> put bs >> put e+  put (Free vs e) = putWord8 4 >> put vs >> put e+  put (Or  e1 e2) = putWord8 5 >> put e1 >> put e2+  put (Case cty ty as) = putWord8 6 >> put cty >> put ty >> put as+  put (Typed e ty) = putWord8 7 >> put e >> put ty++  get = do+    x <- getWord8+    case x of+      0 -> fmap Var get+      1 -> fmap Lit get+      2 -> liftM3 Comb get get get+      3 -> liftM2 Let get get+      4 -> liftM2 Free get get+      5 -> liftM2 Or get get+      6 -> liftM3 Case get get get+      7 -> liftM2 Typed get get+      _ -> fail "Invalid encoding for TExpr"++instance Binary BranchExpr where+  put (Branch p e) = put p >> put e+  get = liftM2 Branch get get++instance Binary Pattern where+  put (Pattern  qid vs) = putWord8 0 >> put qid >> put vs+  put (LPattern l     ) = putWord8 1 >> put l++  get = do+    x <- getWord8+    case x of+      0 -> liftM2 Pattern get get+      1 -> fmap LPattern get+      _ -> fail "Invalid encoding for TPattern"++instance Binary Literal where+  put (Intc   i) = putWord8 0 >> put i+  put (Floatc f) = putWord8 1 >> put f+  put (Charc  c) = putWord8 2 >> put c++  get = do+    x <- getWord8+    case x of+      0 -> fmap Intc get+      1 -> fmap Floatc get+      2 -> fmap Charc get+      _ -> fail "Invalid encoding for Literal"++instance Binary CombType where+  put FuncCall = putWord8 0+  put ConsCall = putWord8 1+  put (FuncPartCall i) = putWord8 2 >> put i+  put (ConsPartCall i) = putWord8 3 >> put i++  get = do+    x <- getWord8+    case x of+      0 -> return FuncCall+      1 -> return ConsCall+      2 -> fmap FuncPartCall get+      3 -> fmap ConsPartCall get+      _ -> fail "Invalid encoding for CombType"++instance Binary CaseType where+  put Rigid = putWord8 0+  put Flex  = putWord8 1++  get = do+    x <- getWord8+    case x of+      0 -> return Rigid+      1 -> return Flex+      _ -> fail "Invalid encoding for CaseType"
+ src/Curry/FlatCurry/Typeable.hs view
@@ -0,0 +1,22 @@+{- |+    Module      : $Header$+    Description : Typeclass of Typeable entities+    Copyright   : (c) 2018        Kai-Oliver Prott+    License     : BSD-3-clause++    Maintainer  : fte@informatik.uni-kiel.de+    Stability   : experimental+    Portability : portable++    This module defines a Typeclass for easy access to the type of entites+-}++module Curry.FlatCurry.Typeable (Typeable(..)) where++import Curry.FlatCurry.Type (TypeExpr)++class Typeable a where+  typeOf :: a -> TypeExpr++instance Typeable TypeExpr where+  typeOf = id
+ src/Curry/FlatCurry/Typed/Goodies.hs view
@@ -0,0 +1,666 @@+{- |+    Module      : $Header$+    Description : Utility functions for working with TypedFlatCurry.+    Copyright   : (c) 2016 - 2017 Finn Teegen+                      2018        Kai-Oliver Prott+    License     : BSD-3-clause++    Maintainer  : fte@informatik.uni-kiel.de+    Stability   : experimental+    Portability : portable++    This library provides selector functions, test and update operations+    as well as some useful auxiliary functions for TypedFlatCurry data terms.+    Most of the provided functions are based on general transformation+    functions that replace constructors with user-defined+    functions. For recursive datatypes the transformations are defined+    inductively over the term structure. This is quite usual for+    transformations on TypedFlatCurry terms,+    so the provided functions can be used to implement specific transformations+    without having to explicitly state the recursion. Essentially, the tedious+    part of such transformations - descend in fairly complex term structures -+    is abstracted away, which hopefully makes the code more clear and brief.+-}++module Curry.FlatCurry.Typed.Goodies+  ( module Curry.FlatCurry.Typed.Goodies+  , module Curry.FlatCurry.Goodies+  ) where++import Curry.FlatCurry.Goodies ( Update+                               , trType, typeName, typeVisibility, typeParams+                               , typeConsDecls, typeSyn, isTypeSyn+                               , isDataTypeDecl, isExternalType, isPublicType+                               , updType, updTypeName, updTypeVisibility+                               , updTypeParams, updTypeConsDecls, updTypeSynonym+                               , updQNamesInType+                               , trCons, consName, consArity, consVisibility+                               , isPublicCons, consArgs, updCons, updConsName+                               , updConsArity, updConsVisibility, updConsArgs+                               , updQNamesInConsDecl+                               , trNewCons, newConsName, newConsVisibility+                               , isPublicNewCons, newConsArg+                               , updNewCons, updNewConsName+                               , updNewConsVisibility, updNewConsArg+                               , updQNamesInNewConsDecl+                               , tVarIndex, domain, range, tConsName, tConsArgs+                               , trTypeExpr, isTVar, isTCons, isFuncType+                               , updTVars, updTCons, updFuncTypes, argTypes+                               , typeArity, resultType, allVarsInTypeExpr+                               , allTypeCons, rnmAllVarsInTypeExpr+                               , updQNamesInTypeExpr+                               , trOp, opName, opFixity, opPrecedence, updOp+                               , updOpName, updOpFixity, updOpPrecedence+                               , trCombType, isCombTypeFuncCall+                               , isCombTypeFuncPartCall, isCombTypeConsCall+                               , isCombTypeConsPartCall+                               , isPublic+                               )++import Curry.FlatCurry.Typed.Type++-- TProg ----------------------------------------------------------------------++-- |transform program+trTProg :: (String -> [String] -> [TypeDecl] -> [TFuncDecl] -> [OpDecl] -> b)+        -> TProg -> b+trTProg prog (TProg name imps types funcs ops) = prog name imps types funcs ops++-- Selectors++-- |get name from program+tProgName :: TProg -> String+tProgName = trTProg (\name _ _ _ _ -> name)++-- |get imports from program+tProgImports :: TProg -> [String]+tProgImports = trTProg (\_ imps _ _ _ -> imps)++-- |get type declarations from program+tProgTypes :: TProg -> [TypeDecl]+tProgTypes = trTProg (\_ _ types _ _ -> types)++-- |get functions from program+tProgTFuncs :: TProg -> [TFuncDecl]+tProgTFuncs = trTProg (\_ _ _ funcs _ -> funcs)++-- |get infix operators from program+tProgOps :: TProg -> [OpDecl]+tProgOps = trTProg (\_ _ _ _ ops -> ops)++-- Update Operations++-- |update program+updTProg :: (String -> String) ->+            ([String] -> [String]) ->+            ([TypeDecl] -> [TypeDecl]) ->+            ([TFuncDecl] -> [TFuncDecl]) ->+            ([OpDecl] -> [OpDecl]) -> TProg -> TProg+updTProg fn fi ft ff fo = trTProg prog+ where+  prog name imps types funcs ops+    = TProg (fn name) (fi imps) (ft types) (ff funcs) (fo ops)++-- |update name of program+updTProgName :: Update TProg String+updTProgName f = updTProg f id id id id++-- |update imports of program+updTProgImports :: Update TProg [String]+updTProgImports f = updTProg id f id id id++-- |update type declarations of program+updTProgTypes :: Update TProg [TypeDecl]+updTProgTypes f = updTProg id id f id id++-- |update functions of program+updTProgTFuncs :: Update TProg [TFuncDecl]+updTProgTFuncs f = updTProg id id id f id++-- |update infix operators of program+updTProgOps :: Update TProg [OpDecl]+updTProgOps = updTProg id id id id++-- Auxiliary Functions++-- |get all program variables (also from patterns)+allVarsInTProg :: TProg -> [(VarIndex, TypeExpr)]+allVarsInTProg = concatMap allVarsInTFunc . tProgTFuncs++-- |lift transformation on expressions to program+updTProgTExps :: Update TProg TExpr+updTProgTExps = updTProgTFuncs . map . updTFuncBody++-- |rename programs variables+rnmAllVarsInTProg :: Update TProg VarIndex+rnmAllVarsInTProg = updTProgTFuncs . map . rnmAllVarsInTFunc++-- |update all qualified names in program+updQNamesInTProg :: Update TProg QName+updQNamesInTProg f = updTProg id id+  (map (updQNamesInType f)) (map (updQNamesInTFunc f)) (map (updOpName f))++-- |rename program (update name of and all qualified names in program)+rnmTProg :: String -> TProg -> TProg+rnmTProg name p = updTProgName (const name) (updQNamesInTProg rnm p)+ where+  rnm (m, n) | m == tProgName p = (name, n)+             | otherwise = (m, n)++-- TFuncDecl ------------------------------------------------------------------++-- |transform function+trTFunc :: (QName -> Int -> Visibility -> TypeExpr -> TRule -> b) -> TFuncDecl -> b+trTFunc func (TFunc name arity vis t rule) = func name arity vis t rule++-- Selectors++-- |get name of function+tFuncName :: TFuncDecl -> QName+tFuncName = trTFunc (\name _ _ _ _ -> name)++-- |get arity of function+tFuncArity :: TFuncDecl -> Int+tFuncArity = trTFunc (\_ arity _ _ _ -> arity)++-- |get visibility of function+tFuncVisibility :: TFuncDecl -> Visibility+tFuncVisibility = trTFunc (\_ _ vis _ _ -> vis)++-- |get type of function+tFuncType :: TFuncDecl -> TypeExpr+tFuncType = trTFunc (\_ _ _ t _ -> t)++-- |get rule of function+tFuncTRule :: TFuncDecl -> TRule+tFuncTRule = trTFunc (\_ _ _ _ rule -> rule)++-- Update Operations++-- |update function+updTFunc :: (QName -> QName) ->+            (Int -> Int) ->+            (Visibility -> Visibility) ->+            (TypeExpr -> TypeExpr) ->+            (TRule -> TRule) -> TFuncDecl -> TFuncDecl+updTFunc fn fa fv ft fr = trTFunc func+ where+  func name arity vis t rule+    = TFunc (fn name) (fa arity) (fv vis) (ft t) (fr rule)++-- |update name of function+updTFuncName :: Update TFuncDecl QName+updTFuncName f = updTFunc f id id id id++-- |update arity of function+updTFuncArity :: Update TFuncDecl Int+updTFuncArity f = updTFunc id f id id id++-- |update visibility of function+updTFuncVisibility :: Update TFuncDecl Visibility+updTFuncVisibility f = updTFunc id id f id id++-- |update type of function+updFuncType :: Update TFuncDecl TypeExpr+updFuncType f = updTFunc id id id f id++-- |update rule of function+updTFuncTRule :: Update TFuncDecl TRule+updTFuncTRule = updTFunc id id id id++-- Auxiliary Functions++-- |is function public?+isPublicTFunc :: TFuncDecl -> Bool+isPublicTFunc = isPublic . tFuncVisibility++-- |is function externally defined?+isExternal :: TFuncDecl -> Bool+isExternal = isTRuleExternal . tFuncTRule++-- |get variable names in a function declaration+allVarsInTFunc :: TFuncDecl -> [(VarIndex, TypeExpr)]+allVarsInTFunc = allVarsInTRule . tFuncTRule++-- |get arguments of function, if not externally defined+tFuncArgs :: TFuncDecl -> [(VarIndex, TypeExpr)]+tFuncArgs = tRuleArgs . tFuncTRule++-- |get body of function, if not externally defined+tFuncBody :: TFuncDecl -> TExpr+tFuncBody = tRuleBody . tFuncTRule++-- |get the right-hand-sides of a 'FuncDecl'+tFuncRHS :: TFuncDecl -> [TExpr]+tFuncRHS f | not (isExternal f) = orCase (tFuncBody f)+           | otherwise = []+ where+  orCase e+    | isTOr e = concatMap orCase (orExps e)+    | isTCase e = concatMap (orCase . tBranchTExpr) (caseBranches e)+    | otherwise = [e]++-- |rename all variables in function+rnmAllVarsInTFunc :: Update TFuncDecl VarIndex+rnmAllVarsInTFunc = updTFunc id id id id . rnmAllVarsInTRule++-- |update all qualified names in function+updQNamesInTFunc :: Update TFuncDecl QName+updQNamesInTFunc f = updTFunc f id id (updQNamesInTypeExpr f) (updQNamesInTRule f)++-- |update arguments of function, if not externally defined+updTFuncArgs :: Update TFuncDecl [(VarIndex, TypeExpr)]+updTFuncArgs = updTFuncTRule . updTRuleArgs++-- |update body of function, if not externally defined+updTFuncBody :: Update TFuncDecl TExpr+updTFuncBody = updTFuncTRule . updTRuleBody++-- TRule ----------------------------------------------------------------------++-- |transform rule+trTRule :: ([(VarIndex, TypeExpr)] -> TExpr -> b) -> (TypeExpr -> String -> b) -> TRule -> b+trTRule rule _ (TRule args e) = rule args e+trTRule _ ext (TExternal ty s) = ext ty s++-- Selectors++-- |get rules arguments if it's not external+tRuleArgs :: TRule -> [(VarIndex, TypeExpr)]+tRuleArgs = trTRule const undefined++-- |get rules body if it's not external+tRuleBody :: TRule -> TExpr+tRuleBody = trTRule (\_ e -> e) undefined++-- |get rules external declaration+tRuleExtDecl :: TRule -> String+tRuleExtDecl = trTRule undefined (\_ s -> s)++-- Test Operations++-- |is rule external?+isTRuleExternal :: TRule -> Bool+isTRuleExternal = trTRule (\_ _ -> False) (\_ _ -> True)++-- Update Operations++-- |update rule+updTRule :: (TypeExpr -> TypeExpr) ->+            ([(VarIndex, TypeExpr)] -> [(VarIndex, TypeExpr)]) ->+            (TExpr -> TExpr) ->+            (String -> String) -> TRule -> TRule+updTRule fannot fa fe fs = trTRule rule ext+ where+  rule args e = TRule (fa args) (fe e)+  ext ty s = TExternal (fannot ty) (fs s)++-- |update rules TypeExpr+updTRuleType :: Update TRule TypeExpr+updTRuleType f = updTRule f id id id++-- |update rules arguments+updTRuleArgs :: Update TRule [(VarIndex, TypeExpr)]+updTRuleArgs f = updTRule id f id id++-- |update rules body+updTRuleBody :: Update TRule TExpr+updTRuleBody f = updTRule id id f id++-- |update rules external declaration+updTRuleExtDecl :: Update TRule String+updTRuleExtDecl = updTRule id id id++-- Auxiliary Functions++-- |get variable names in a functions rule+allVarsInTRule :: TRule -> [(VarIndex, TypeExpr)]+allVarsInTRule = trTRule (\args body -> args ++ allVars body) (\_ _ -> [])++-- |rename all variables in rule+rnmAllVarsInTRule :: Update TRule VarIndex+rnmAllVarsInTRule f = updTRule id (map (\(a, b) -> (f a, b))) (rnmAllVars f) id++-- |update all qualified names in rule+updQNamesInTRule :: Update TRule QName+updQNamesInTRule = updTRuleBody . updQNames++-- TExpr ----------------------------------------------------------------------++-- Selectors++-- |get internal number of variable+varNr :: TExpr -> VarIndex+varNr (TVarE _ n) = n+varNr _           = error "Curry.FlatCurry.Typed.Goodies.varNr: no variable"++-- |get literal if expression is literal expression+literal :: TExpr -> Literal+literal (TLit _ l) = l+literal _          = error "Curry.FlatCurry.Typed.Goodies.literal: no literal"++-- |get combination type of a combined expression+combType :: TExpr -> CombType+combType (TComb _ ct _ _) = ct+combType _                = error $ "Curry.FlatCurry.Typed.Goodies.combType: " +++                                    "no combined expression"++-- |get name of a combined expression+combName :: TExpr -> QName+combName (TComb _ _ name _) = name+combName _                  = error $ "Curry.FlatCurry.Typed.Goodies.combName: " +++                                      "no combined expression"++-- |get arguments of a combined expression+combArgs :: TExpr -> [TExpr]+combArgs (TComb _ _ _ args) = args+combArgs _                  = error $ "Curry.FlatCurry.Typed.Goodies.combArgs: " +++                                      "no combined expression"++-- |get number of missing arguments if expression is combined+missingCombArgs :: TExpr -> Int+missingCombArgs = missingArgs . combType+  where+  missingArgs :: CombType -> Int+  missingArgs = trCombType 0 id 0 id++-- |get indices of variables in let declaration+letBinds :: TExpr -> [((VarIndex, TypeExpr), TExpr)]+letBinds (TLet vs _) = vs+letBinds _           = error $ "Curry.FlatCurry.Typed.Goodies.letBinds: " +++                               "no let expression"++-- |get body of let declaration+letBody :: TExpr -> TExpr+letBody (TLet _ e) = e+letBody _          = error $ "Curry.FlatCurry.Typed.Goodies.letBody: " +++                             "no let expression"++-- |get variable indices from declaration of free variables+freeVars :: TExpr -> [(VarIndex, TypeExpr)]+freeVars (TFree vs _) = vs+freeVars _            = error $ "Curry.FlatCurry.Typed.Goodies.freeVars: " +++                                "no declaration of free variables"++-- |get expression from declaration of free variables+freeExpr :: TExpr -> TExpr+freeExpr (TFree _ e) = e+freeExpr _           = error $ "Curry.FlatCurry.Typed.Goodies.freeExpr: " +++                               "no declaration of free variables"++-- |get expressions from or-expression+orExps :: TExpr -> [TExpr]+orExps (TOr e1 e2) = [e1, e2]+orExps _           = error $ "Curry.FlatCurry.Typed.Goodies.orExps: " +++                             "no or expression"++-- |get case-type of case expression+caseType :: TExpr -> CaseType+caseType (TCase ct _ _) = ct+caseType _              = error $ "Curry.FlatCurry.Typed.Goodies.caseType: " +++                                  "no case expression"++-- |get scrutinee of case expression+caseExpr :: TExpr -> TExpr+caseExpr (TCase _ e _) = e+caseExpr _             = error $ "Curry.FlatCurry.Typed.Goodies.caseExpr: " +++                                   "no case expression"+++-- |get branch expressions from case expression+caseBranches :: TExpr -> [TBranchExpr]+caseBranches (TCase _ _ bs) = bs+caseBranches _              = error "Curry.FlatCurry.Typed.Goodies.caseBranches: no case expression"++-- Test Operations++-- |is expression a variable?+isTVarE :: TExpr -> Bool+isTVarE e = case e of+  TVarE _ _ -> True+  _ -> False++-- |is expression a literal expression?+isTLit :: TExpr -> Bool+isTLit e = case e of+  TLit _ _ -> True+  _ -> False++-- |is expression combined?+isTComb :: TExpr -> Bool+isTComb e = case e of+  TComb _ _ _ _ -> True+  _ -> False++-- |is expression a let expression?+isTLet :: TExpr -> Bool+isTLet e = case e of+  TLet _ _ -> True+  _ -> False++-- |is expression a declaration of free variables?+isTFree :: TExpr -> Bool+isTFree e = case e of+  TFree _ _ -> True+  _ -> False++-- |is expression an or-expression?+isTOr :: TExpr -> Bool+isTOr e = case e of+  TOr _ _ -> True+  _ -> False++-- |is expression a case expression?+isTCase :: TExpr -> Bool+isTCase e = case e of+  TCase _ _ _ -> True+  _ -> False++-- |transform expression+trTExpr  :: (TypeExpr -> VarIndex -> b)+         -> (TypeExpr -> Literal -> b)+         -> (TypeExpr -> CombType -> QName -> [b] -> b)+         -> ([((VarIndex, TypeExpr), b)] -> b -> b)+         -> ([(VarIndex, TypeExpr)] -> b -> b)+         -> (b -> b -> b)+         -> (CaseType -> b -> [c] -> b)+         -> (TPattern -> b -> c)+         -> (b -> TypeExpr -> b)+         -> TExpr+         -> b+trTExpr var lit comb lt fr oR cas branch typed expr = case expr of+  TVarE ty n            -> var ty n+  TLit ty l             -> lit ty l+  TComb ty ct name args -> comb ty ct name (map f args)+  TLet bs e             -> lt (map (\(v, x) -> (v, f x)) bs) (f e)+  TFree vs e            -> fr vs (f e)+  TOr e1 e2             -> oR (f e1) (f e2)+  TCase ct e bs         -> cas ct (f e) (map (\ (TBranch p e') -> branch p (f e')) bs)+  TTyped e ty           -> typed (f e) ty+  where+  f = trTExpr var lit comb lt fr oR cas branch typed++-- |update all variables in given expression+updVars :: (TypeExpr -> VarIndex -> TExpr) -> TExpr -> TExpr+updVars var = trTExpr var TLit TComb TLet TFree TOr TCase TBranch TTyped++-- |update all literals in given expression+updLiterals :: (TypeExpr -> Literal -> TExpr) -> TExpr -> TExpr+updLiterals lit = trTExpr TVarE lit TComb TLet TFree TOr TCase TBranch TTyped++-- |update all combined expressions in given expression+updCombs :: (TypeExpr -> CombType -> QName -> [TExpr] -> TExpr) -> TExpr -> TExpr+updCombs comb = trTExpr TVarE TLit comb TLet TFree TOr TCase TBranch TTyped++-- |update all let expressions in given expression+updLets :: ([((VarIndex, TypeExpr), TExpr)] -> TExpr -> TExpr) -> TExpr -> TExpr+updLets lt = trTExpr TVarE TLit TComb lt TFree TOr TCase TBranch TTyped++-- |update all free declarations in given expression+updFrees :: ([(VarIndex, TypeExpr)] -> TExpr -> TExpr) -> TExpr -> TExpr+updFrees fr = trTExpr TVarE TLit TComb TLet fr TOr TCase TBranch TTyped++-- |update all or expressions in given expression+updOrs :: (TExpr -> TExpr -> TExpr) -> TExpr -> TExpr+updOrs oR = trTExpr TVarE TLit TComb TLet TFree oR TCase TBranch TTyped++-- |update all case expressions in given expression+updCases :: (CaseType -> TExpr -> [TBranchExpr] -> TExpr) -> TExpr -> TExpr+updCases cas = trTExpr TVarE TLit TComb TLet TFree TOr cas TBranch TTyped++-- |update all case branches in given expression+updBranches :: (TPattern -> TExpr -> TBranchExpr) -> TExpr -> TExpr+updBranches branch = trTExpr TVarE TLit TComb TLet TFree TOr TCase branch TTyped++-- |update all typed expressions in given expression+updTypeds :: (TExpr -> TypeExpr -> TExpr) -> TExpr -> TExpr+updTypeds = trTExpr TVarE TLit TComb TLet TFree TOr TCase TBranch++-- Auxiliary Functions++-- |is expression a call of a function where all arguments are provided?+isFuncCall :: TExpr -> Bool+isFuncCall e = isTComb e && isCombTypeFuncCall (combType e)++-- |is expression a partial function call?+isFuncPartCall :: TExpr -> Bool+isFuncPartCall e = isTComb e && isCombTypeFuncPartCall (combType e)++-- |is expression a call of a constructor?+isConsCall :: TExpr -> Bool+isConsCall e = isTComb e && isCombTypeConsCall (combType e)++-- |is expression a partial constructor call?+isConsPartCall :: TExpr -> Bool+isConsPartCall e = isTComb e && isCombTypeConsPartCall (combType e)++-- |is expression fully evaluated?+isGround :: TExpr -> Bool+isGround e+  = case e of+      TComb _ ConsCall _ args -> all isGround args+      _ -> isTLit e++-- |get all variables (also pattern variables) in expression+allVars :: TExpr -> [(VarIndex, TypeExpr)]+allVars e = trTExpr var lit comb lt fr (.) cas branch typ e []+ where+  var a v = (:) (v, a)+  lit = const (const id)+  comb _ _ _ = foldr (.) id+  lt bs e' = e' . foldr (.) id (map (\(n,ns) -> (n:) . ns) bs)+  fr vs e' = (vs++) . e'+  cas _ e' bs = e' . foldr (.) id bs+  branch pat e' = (args pat ++) . e'+  typ = const+  args pat | isConsPattern pat = tPatArgs pat+           | otherwise = []++-- |rename all variables (also in patterns) in expression+rnmAllVars :: Update TExpr VarIndex+rnmAllVars f = trTExpr var TLit TComb lt fr TOr TCase branch TTyped+ where+   var a = TVarE a . f+   lt = TLet . map (\((n, b), e) -> ((f n, b), e))+   fr = TFree . map (\(b, c) -> (f b, c))+   branch = TBranch . updTPatArgs (map (\(a, b) -> (f a, b)))++-- |update all qualified names in expression+updQNames :: Update TExpr QName+updQNames f = trTExpr TVarE TLit comb TLet TFree TOr TCase branch TTyped+ where+  comb ty ct name args = TComb ty ct (f name) args+  branch = TBranch . updTPatCons f++-- TBranchExpr ----------------------------------------------------------------++-- |transform branch expression+trTBranch :: (TPattern -> TExpr -> b) -> TBranchExpr -> b+trTBranch branch (TBranch pat e) = branch pat e++-- Selectors++-- |get pattern from branch expression+tBranchTPattern :: TBranchExpr -> TPattern+tBranchTPattern = trTBranch const++-- |get expression from branch expression+tBranchTExpr :: TBranchExpr -> TExpr+tBranchTExpr = trTBranch (\_ e -> e)++-- Update Operations++-- |update branch expression+updTBranch :: (TPattern -> TPattern) -> (TExpr -> TExpr) -> TBranchExpr -> TBranchExpr+updTBranch fp fe = trTBranch branch+ where+  branch pat e = TBranch (fp pat) (fe e)++-- |update pattern of branch expression+updTBranchTPattern :: Update TBranchExpr TPattern+updTBranchTPattern f = updTBranch f id++-- |update expression of branch expression+updTBranchTExpr :: Update TBranchExpr TExpr+updTBranchTExpr = updTBranch id++-- TPattern -------------------------------------------------------------------++-- |transform pattern+trTPattern :: (TypeExpr -> QName -> [(VarIndex, TypeExpr)] -> b) -> (TypeExpr -> Literal -> b) -> TPattern -> b+trTPattern pat _ (TPattern ty name args) = pat ty name args+trTPattern _ lpat (TLPattern a l) = lpat a l++-- Selectors++-- |get name from constructor pattern+tPatCons :: TPattern -> QName+tPatCons = trTPattern (\_ name _ -> name) undefined++-- |get arguments from constructor pattern+tPatArgs :: TPattern -> [(VarIndex, TypeExpr)]+tPatArgs = trTPattern (\_ _ args -> args) undefined++-- |get literal from literal pattern+tPatLiteral :: TPattern -> Literal+tPatLiteral = trTPattern undefined (const id)++-- Test Operations++-- |is pattern a constructor pattern?+isConsPattern :: TPattern -> Bool+isConsPattern = trTPattern (\_ _ _ -> True) (\_ _ -> False)++-- Update Operations++-- |update pattern+updTPattern :: (TypeExpr -> TypeExpr) ->+               (QName -> QName) ->+               ([(VarIndex, TypeExpr)] -> [(VarIndex, TypeExpr)]) ->+               (Literal -> Literal) -> TPattern -> TPattern+updTPattern fannot fn fa fl = trTPattern pattern lpattern+ where+  pattern ty name args = TPattern (fannot ty) (fn name) (fa args)+  lpattern ty l = TLPattern (fannot ty) (fl l)++-- |update TypeExpr of pattern+updTPatType :: (TypeExpr -> TypeExpr) -> TPattern -> TPattern+updTPatType f = updTPattern f id id id++-- |update constructors name of pattern+updTPatCons :: (QName -> QName) -> TPattern -> TPattern+updTPatCons f = updTPattern id f id id++-- |update arguments of constructor pattern+updTPatArgs :: ([(VarIndex, TypeExpr)] -> [(VarIndex, TypeExpr)]) -> TPattern -> TPattern+updTPatArgs f = updTPattern id id f id++-- |update literal of pattern+updTPatLiteral :: (Literal -> Literal) -> TPattern -> TPattern+updTPatLiteral = updTPattern id id id++-- Auxiliary Functions++-- |build expression from pattern+tPatExpr :: TPattern -> TExpr+tPatExpr = trTPattern (\ty name -> TComb ty ConsCall name . map (uncurry (flip TVarE))) TLit
+ src/Curry/FlatCurry/Typed/Type.hs view
@@ -0,0 +1,146 @@+{- |+    Module      : $Header$+    Description : Representation of annotated FlatCurry.+    Copyright   : (c) 2016 - 2017 Finn Teegen+                      2018        Kai-Oliver Prott+    License     : BSD-3-clause++    Maintainer  : fte@informatik.uni-kiel.de+    Stability   : experimental+    Portability : portable++    This library contains a version of FlatCurry's abstract syntax tree+    modified with type information++    For more information about the abstract syntax tree of `FlatCurry`,+    see the documentation of the respective module.+-}++module Curry.FlatCurry.Typed.Type+  ( module Curry.FlatCurry.Typed.Type+  , module Curry.FlatCurry.Typeable+  , module Curry.FlatCurry.Type+  ) where++import Data.Binary+import Control.Monad++import Curry.FlatCurry.Typeable+import Curry.FlatCurry.Type ( QName, VarIndex, Visibility (..), TVarIndex+                            , TypeDecl (..), Kind (..), OpDecl (..), Fixity (..)+                            , TypeExpr (..), ConsDecl (..), NewConsDecl (..)+                            , Literal (..), CombType (..), CaseType (..)+                            )++data TProg = TProg String [String] [TypeDecl] [TFuncDecl] [OpDecl]+  deriving (Eq, Read, Show)++data TFuncDecl = TFunc QName Int Visibility TypeExpr TRule+  deriving (Eq, Read, Show)++data TRule+  = TRule     [(VarIndex, TypeExpr)] TExpr+  | TExternal TypeExpr String+  deriving (Eq, Read, Show)++data TExpr+  = TVarE  TypeExpr VarIndex -- otherwise name clash with TypeExpr's TVar+  | TLit   TypeExpr Literal+  | TComb  TypeExpr CombType QName [TExpr]+  | TLet   [((VarIndex, TypeExpr), TExpr)] TExpr+  | TFree  [(VarIndex, TypeExpr)] TExpr+  | TOr    TExpr TExpr+  | TCase  CaseType TExpr [TBranchExpr]+  | TTyped TExpr TypeExpr+  deriving (Eq, Read, Show)++data TBranchExpr = TBranch TPattern TExpr+  deriving (Eq, Read, Show)++data TPattern+  = TPattern  TypeExpr QName [(VarIndex, TypeExpr)]+  | TLPattern TypeExpr Literal+  deriving (Eq, Read, Show)++instance Typeable TRule where+  typeOf (TRule args e) = foldr (FuncType . snd) (typeOf e) args+  typeOf (TExternal ty _) = ty++instance Typeable TExpr where+  typeOf (TVarE ty _) = ty+  typeOf (TLit ty _) = ty+  typeOf (TComb  ty _ _ _) = ty+  typeOf (TLet _ e) = typeOf e+  typeOf (TFree _ e) = typeOf e+  typeOf (TOr e _) = typeOf e+  typeOf (TCase _ _ (e:_)) = typeOf e+  typeOf (TTyped _ ty) = ty+  typeOf (TCase _ _ []) = error $ "Curry.FlatCurry.Typed.Type.typeOf: " +++                                  "empty list in case expression"++instance Typeable TPattern where+  typeOf (TPattern ty _ _) = ty+  typeOf (TLPattern ty _) = ty++instance Typeable TBranchExpr where+  typeOf (TBranch _ e) = typeOf e++instance Binary TProg where+  put (TProg mid im tys fus ops) =+    put mid >> put im >> put tys >> put fus >> put ops+  get = TProg <$> get <*> get <*> get <*> get <*> get++instance Binary TFuncDecl where+  put (TFunc qid arity vis ty r) =+    put qid >> put arity >> put vis >> put ty >> put r+  get = TFunc <$> get <*> get <*> get <*> get <*> get++instance Binary TRule where+  put (TRule     alts e) = putWord8 0 >> put alts >> put e+  put (TExternal ty n  ) = putWord8 1 >> put ty   >> put n++  get = do+    x <- getWord8+    case x of+      0 -> liftM2 TRule get get+      1 -> liftM2 TExternal get get+      _ -> fail "Invalid encoding for TRule"++instance Binary TExpr where+  put (TVarE ty v) = putWord8 0 >> put ty >> put v+  put (TLit  ty l) = putWord8 1 >> put ty >> put l+  put (TComb ty cty qid es) =+    putWord8 2 >> put ty >> put cty >> put qid >> put es+  put (TLet  bs e) = putWord8 3 >> put bs >> put e+  put (TFree vs e) = putWord8 4 >> put vs >> put e+  put (TOr  e1 e2) = putWord8 5 >> put e1 >> put e2+  put (TCase cty ty as) = putWord8 6 >> put cty >> put ty >> put as+  put (TTyped e ty) = putWord8 7 >> put e >> put ty++  get = do+    x <- getWord8+    case x of+      0 -> liftM2 TVarE get get+      1 -> liftM2 TLit get get+      2 -> liftM4 TComb get get get get+      3 -> liftM2 TLet get get+      4 -> liftM2 TFree get get+      5 -> liftM2 TOr get get+      6 -> liftM3 TCase get get get+      7 -> liftM2 TTyped get get+      _ -> fail "Invalid encoding for TExpr"++instance Binary TBranchExpr where+  put (TBranch p e) = put p >> put e+  get = liftM2 TBranch get get++instance Binary TPattern where+  put (TPattern  ty qid vs) = putWord8 0 >> put ty >> put qid >> put vs+  put (TLPattern ty l     ) = putWord8 1 >> put ty >> put l++  get = do+    x <- getWord8+    case x of+      0 -> liftM3 TPattern get get get+      1 -> liftM2 TLPattern get get+      _ -> fail "Invalid encoding for TPattern"
src/Curry/Syntax.hs view
@@ -1,43 +1,81 @@-{--  A simple interface for reading and manipulating Curry-  source code.+{- |+    Module      :  $Header$+    Description :  Interface for reading and manipulating Curry source code+    Copyright   :  (c) 2009        Holger Siegel+                       2011 - 2013 Björn Peemöller+                       2016        Finn Teegen+                       2016        Jan Tikovsky+    License     :  BSD-3-clause -  (c) 2009, Holger Siegel.+    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable -}- module Curry.Syntax   ( module Curry.Syntax.Type-  , parseModule-  , parseHeader+  , module Curry.Syntax.Utils+  , L.Token (..), L.Category (..), L.Attributes (..)+  , unlit, unlitLexSource, unlitParseHeader, unlitParsePragmas, unlitParseModule+  , lexSource, parseInterface, parseHeader, parsePragmas, parseModule, parseGoal+  , pPrint, pPrintPrec+  , showModule   ) where -import Control.Monad-import Data.List+import           Curry.Base.Monad             (CYM)+import           Curry.Base.Span              (Span)+import           Curry.Base.Pretty            (pPrint, pPrintPrec)+import qualified Curry.Files.Unlit       as U (unlit) -import Curry.Base.MessageMonad-import Curry.Syntax.Type-import qualified Curry.Syntax.Parser as CSP-import Curry.Syntax.Unlit+import qualified Curry.Syntax.Lexer      as L+import qualified Curry.Syntax.Parser     as P+import           Curry.Syntax.Pretty          ()+import           Curry.Syntax.ShowModule      (showModule)+import           Curry.Syntax.Type+import           Curry.Syntax.Utils --- | Parses a curry module.-parseModule :: Bool -> FilePath -> String -> MsgMonad Module-parseModule likeFlat fn =-  unlitLiterate fn >=> CSP.parseSource likeFlat fn+-- |Unliterate a LiterateCurry file, identity on normal Curry file.+unlit :: FilePath -> String -> CYM String+unlit = U.unlit --- | Pares a curry header-parseHeader :: FilePath -> String -> MsgMonad Module-parseHeader fn =-  unlitLiterate fn >=> CSP.parseHeader fn+-- |Unliterate and return the result of a lexical analysis of the source+-- program @src@.+-- The result is a list of tuples consisting of a 'Span' and a 'Token'.+unlitLexSource :: FilePath -> String -> CYM [(Span, L.Token)]+unlitLexSource fn src = U.unlit fn src >>= L.lexSource fn --- Literate source files use the extension ".lcurry"-unlitLiterate :: FilePath -> String -> MsgMonad String-unlitLiterate fn s-  | isLiterateSource fn = unlit fn s-  | otherwise = return s+-- |Unliterate and parse only pragmas of a Curry 'Module'+unlitParsePragmas :: FilePath -> String -> CYM (Module ())+unlitParsePragmas fn src = U.unlit fn src >>= P.parsePragmas fn --- | Compute if a file contains literate curry by its extension-isLiterateSource :: FilePath -> Bool-isLiterateSource fn = litExt `isSuffixOf` fn+-- |Unliterate and parse a Curry 'Module' header+unlitParseHeader :: FilePath -> String -> CYM (Module ())+unlitParseHeader fn src = U.unlit fn src >>= P.parseHeader fn -litExt = ".lcurry"+-- |Unliterate and parse a Curry 'Module'+unlitParseModule :: FilePath -> String -> CYM (Module ())+unlitParseModule fn src = U.unlit fn src >>= P.parseSource fn +-- |Return the result of a lexical analysis of the source program @src@.+-- The result is a list of tuples consisting of a 'Span' and a 'Token'.+lexSource :: FilePath -> String -> CYM [(Span, L.Token)]+lexSource = L.lexSource++-- |Parse a Curry 'Interface'+parseInterface :: FilePath -> String -> CYM Interface+parseInterface = P.parseInterface++-- |Parse only pragmas of a Curry 'Module'+parsePragmas :: FilePath -> String -> CYM (Module ())+parsePragmas = P.parsePragmas++-- |Parse a Curry 'Module' header+parseHeader :: FilePath -> String -> CYM (Module ())+parseHeader = P.parseHeader++-- |Parse a Curry 'Module'+parseModule :: FilePath -> String -> CYM (Module ())+parseModule = P.parseSource++-- |Parse a 'Goal', i.e. an expression with (optional) local declarations+parseGoal :: String -> CYM (Goal ())+parseGoal = P.parseGoal
+ src/Curry/Syntax/Extension.hs view
@@ -0,0 +1,120 @@+{- |+    Module      :  $Header$+    Description :  Curry language extensions+    Copyright   :  (c) 2013 - 2014 Björn Peemöller+                       2016        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module provides the data structures for Curry language extensions.+-}++module Curry.Syntax.Extension+  ( -- * Extensions+    Extension (..), KnownExtension (..), classifyExtension, kielExtensions+    -- * Tools+  , Tool (..), classifyTool+  ) where++import Data.Binary+import Data.Char           (toUpper)+import Control.Monad++import Curry.Base.Ident    (Ident (..))+import Curry.Base.Position+import Curry.Base.SpanInfo++-- |Specified language extensions, either known or unknown.+data Extension+  = KnownExtension   SpanInfo KnownExtension -- ^ a known extension+  | UnknownExtension SpanInfo String         -- ^ an unknown extension+    deriving (Eq, Read, Show)++instance HasSpanInfo Extension where+  getSpanInfo (KnownExtension   spi _) = spi+  getSpanInfo (UnknownExtension spi _) = spi+  +  setSpanInfo spi (KnownExtension   _ ke) = KnownExtension spi ke+  setSpanInfo spi (UnknownExtension _ s)  = UnknownExtension spi s++instance HasPosition Extension where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance Binary Extension where+  put (KnownExtension   p e) = putWord8 0 >> put p >> put e+  put (UnknownExtension p e) = putWord8 1 >> put p >> put e++  get = do+    x <- getWord8+    case x of+      0 -> liftM2 KnownExtension get get+      1 -> liftM2 UnknownExtension get get+      _ -> fail "Invalid encoding for Extension"++instance Binary KnownExtension where+  put AnonFreeVars       = putWord8 0+  put CPP                = putWord8 1+  put FunctionalPatterns = putWord8 2+  put NegativeLiterals   = putWord8 3+  put NoImplicitPrelude  = putWord8 4++  get = do+    x <- getWord8+    case x of+      0 -> return AnonFreeVars+      1 -> return CPP+      2 -> return FunctionalPatterns+      3 -> return NegativeLiterals+      4 -> return NoImplicitPrelude+      _ -> fail "Invalid encoding for KnownExtension"++-- |Known language extensions of Curry.+data KnownExtension+  = AnonFreeVars              -- ^ anonymous free variables+  | CPP                       -- ^ C preprocessor+  | FunctionalPatterns        -- ^ functional patterns+  | NegativeLiterals          -- ^ negative literals+  | NoImplicitPrelude         -- ^ no implicit import of the prelude+    deriving (Eq, Read, Show, Enum, Bounded)++-- |Classifies a 'String' as an 'Extension'+classifyExtension :: Ident -> Extension+classifyExtension i = case reads extName of+  [(e, "")] -> KnownExtension   (getSpanInfo i) e+  _         -> UnknownExtension (getSpanInfo i) extName+  where extName = idName i++-- |'Extension's available by Kiel's Curry compilers.+kielExtensions :: [KnownExtension]+kielExtensions = [AnonFreeVars, FunctionalPatterns]++-- |Different Curry tools which may accept compiler options.+data Tool = KICS2 | PAKCS | CYMAKE | FRONTEND | UnknownTool String+    deriving (Eq, Read, Show)++instance Binary Tool where+  put KICS2           = putWord8 0+  put PAKCS           = putWord8 1+  put CYMAKE          = putWord8 2+  put FRONTEND        = putWord8 3+  put (UnknownTool s) = putWord8 4 >> put s++  get = do+    x <- getWord8+    case x of+      0 -> return KICS2+      1 -> return PAKCS+      2 -> return CYMAKE+      3 -> return FRONTEND+      4 -> fmap UnknownTool get+      _ -> fail "Invalid encoding for Tool"++-- |Classifies a 'String' as a 'Tool'+classifyTool :: String -> Tool+classifyTool str = case reads (map toUpper str) of+  [(t, "")] -> t+  _         -> UnknownTool str
− src/Curry/Syntax/Frontend.hs 
@@ -1,202 +0,0 @@---------------------------------------------------------------------------------------------------------------------------------------------------------------------- Frontend - Provides an API for dealing with several kinds of Curry---            program representations------ December 2005,--- Martin Engelke (men@informatik.uni-kiel.de)----module Curry.Syntax.Frontend (lex, parse, fullParse, typingParse)where--import Data.Maybe-import qualified Data.Map as Map-import Control.Monad.Writer-import Control.Monad.Error-import Prelude hiding (lex)---import Curry.Base.MessageMonad-import Curry.Base.Ident-import Curry.Base.Position--import Curry.Files.Filenames-import Curry.Files.PathUtils--import qualified Curry.Syntax as CS-import Curry.Syntax.Lexer--import Modules-import CurryBuilder-import CurryCompilerOpts--import CurryDeps--import Base(ModuleEnv)--------------------------------------------------------------------------------------------------------------------------------------------------------------------- Returns the result of a lexical analysis of the source program 'src'.--- The result is a list of tuples consisting of a position and a token--- (see Modules "Position" and "CurryLexer")-lex :: FilePath -> String -> MsgMonad [(Position,Token)]-lex fn src = lexFile (first fn) src False []----- Returns the result of a syntactical analysis of the source program 'src'.--- The result is the syntax tree of the program (type 'Module'; see Module--- "CurrySyntax").-parse :: FilePath -> String -> MsgMonad CS.Module-parse fn src = CS.parseModule True fn src >>= genCurrySyntax fn----- Returns the syntax tree of the source program 'src' (type 'Module'; see--- Module "CurrySyntax") after resolving the category (i.e. function,--- constructor or variable) of an identifier. 'fullParse' always--- searches for standard Curry libraries in the path defined in the--- environment variable "PAKCSLIBPATH". Additional search paths can--- be defined using the argument 'paths'.-fullParse :: [FilePath] -> FilePath -> String -> IO (MsgMonad CS.Module)-fullParse paths fn src = -- liftM msgmonad2result $-                         genFullCurrySyntax simpleCheckModule paths fn (parse fn src)---- Behaves like 'fullParse', but Returns the syntax tree of the source --- program 'src' (type 'Module'; see Module "CurrySyntax") after inferring --- the types of identifiers.-typingParse :: [FilePath] -> FilePath -> String -> IO (MsgMonad CS.Module)-typingParse paths fn src = genFullCurrySyntax checkModule paths fn (parse fn src)--{---- Compiles the source programm 'src' to an AbstractCurry program.--- 'fullParse' always searches for standard Curry libraries in the path --- defined in the environment variable "PAKCSLIBPATH". Additional search --- paths can be defined using the argument 'paths'.--- Notes: Due to the lack of error handling in the current version of the--- front end, this function may fail when an error occurs-abstractIO :: [FilePath] -> FilePath -> String -> IO (MsgMonad ACY.CurryProg)-abstractIO paths fn src = genAbstractIO paths fn (parse fn src)---- Compiles the source program 'src' to a FlatCurry program.--- 'fullParse' always searches for standard Curry libraries in the path --- defined in the environment variable "PAKCSLIBPATH". Additional search --- paths can be defined using the argument 'paths'.--- Note: Due to the lack of error handling in the current version of the--- front end, this function may fail when an error occurs-flatIO :: [FilePath] -> FilePath -> String -> IO (MsgMonad FCY.Prog)-flatIO paths fn src = genFlatIO paths fn (parse fn src)--}-------------------------------------------------------------------------------------------------------------------------------------------------------------------- Privates...---opts paths = defaultOpts{ -                     importPaths = paths,-		     noVerb      = True,-		     noWarn      = True,-		     abstract    = True-		   }------genCurrySyntax :: FilePath -> CS.Module -> MsgMonad (CS.Module)-genCurrySyntax fn mod-    = let mod'@(CS.Module mid _ _) = patchModuleId fn (importPrelude fn mod)-      in if isValidModuleId fn mid-	 then return mod'-	 else failWith $ err_invalidModuleName mid------genFullCurrySyntax :: (Options -> Base.ModuleEnv -> CS.Module -> IO (t1, t2, t3, CS.Module, t4, [WarnMsg]))-                   -> [FilePath] -> t -> MsgMonad CS.Module -> IO (MsgMonad CS.Module)-genFullCurrySyntax check paths fn m-   = runMsgIO m $ \mod -> do errs <- makeInterfaces paths mod-	                     if null errs-	                       then do mEnv <- loadInterfaces paths mod-		                       (_, _, _, mod', _, msgs') <- check (opts paths) mEnv mod-		                       return (tell msgs' >> return  mod')-	                       else return (failWith (head errs))---{--genAbstractIO :: [FilePath] -> FilePath -> MsgMonad CS.Module-	      -> IO (MsgMonad ACY.CurryProg)-genAbstractIO paths fn m-   = runMsgIO m $ \mod ->-     do errs <- makeInterfaces paths mod-	if null errs-	   then do mEnv <- loadInterfaces paths mod-		   (tyEnv, tcEnv, _, mod', _, msgs')-		       <- simpleCheckModule (opts paths) mEnv mod-		   return (tell msgs' >> return (genTypedAbstract tyEnv tcEnv mod'))-	   else return (failWith $ head errs)------genFlatIO :: [FilePath] -> FilePath -> MsgMonad CS.Module -> IO (MsgMonad FCY.Prog)-genFlatIO paths fn m-   = runMsgIO m $ \ mod -> -     do errs <- makeInterfaces paths mod-	if null errs then-	   (do mEnv <- loadInterfaces paths mod-	       (tyEnv, tcEnv, aEnv, mod', intf, msgs') <- -	           checkModule (opts paths) mEnv mod-	       let (il, aEnv', _) -	              = transModule True True False mEnv tyEnv tcEnv aEnv mod'-	           il' = completeCase mEnv il-	           cEnv = curryEnv mEnv tcEnv intf mod'-	           (prog,msgs'') = genFlatCurry (opts paths) cEnv mEnv -	                                        tyEnv tcEnv aEnv' il'-               return (tell msgs'' >> tell msgs' >> return prog)-	   )-	   else return (failWith $ head errs)--}-------------------------------------------------------------------------------------- Generates interface files for importes modules, if they don't exist or--- if they are not up-to-date.-makeInterfaces ::  [FilePath] -> CS.Module -> IO [String]-makeInterfaces paths (CS.Module mid _ decls)-  = do let imports = [preludeMIdent | mid /= preludeMIdent] -		      ++ [imp | CS.ImportDecl _ imp _ _ _ <- decls]-       (deps, errs) <- fmap flattenDeps (foldM (moduleDeps paths []) Map.empty imports)-       when (null errs) (mapM_ (compile deps . snd) deps)-       return errs- where- compile deps (Source file' mods)-    = do smake [flatName file', flatIntName file']-	       (file':mapMaybe (flatInterface deps) mods)-	       (compileModule (opts paths) file')-	       (return Nothing)-	 return ()- compile _ _ = return ()-- flatInterface deps mod -    = case (lookup mod deps) of-        Just (Source file _)  -> Just (flatIntName (dropExtension file))-	Just (Interface file) -> Just (flatIntName (dropExtension file))-	_                     -> Nothing----- Returns 'True', if file name and module name are equal.-isValidModuleId :: FilePath -> ModuleIdent -> Bool-isValidModuleId fn mid-   = last (moduleQualifiers mid) == takeBaseName fn------------------------------------------------------------------------------------- Messages--err_invalidModuleName :: ModuleIdent -> String-err_invalidModuleName mid -   = "module \"" ++ moduleName mid -     ++ "\" must be in a file \"" ++ moduleName mid ++ ".curry\""------------------------------------------------------------------------------------------------------------------------------------------------------------------
+ src/Curry/Syntax/InterfaceEquivalence.hs view
@@ -0,0 +1,209 @@+{- |+    Module      :  $Header$+    Description :  Comparison of Curry Interfaces+    Copyright   :  (c) 2000 - 2007 Wolfgang Lux+                       2014 - 2015 Björn Peemöller+                       2014        Jan Tikovsky+                       2016        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    If a module is recompiled, the compiler has to check whether the+    interface file must be updated. This must be done if any exported+    entity has been changed, or an export was removed or added. The+    function 'intfEquiv' checks whether two interfaces are+    equivalent, i.e., whether they define the same entities.+-}+module Curry.Syntax.InterfaceEquivalence (fixInterface, intfEquiv) where++import Data.List (deleteFirstsBy, sort)+import qualified Data.Set as Set++import Curry.Base.Ident+import Curry.Syntax++infix 4 =~=, `eqvSet`++-- |Are two given interfaces equivalent?+intfEquiv :: Interface -> Interface -> Bool+intfEquiv = (=~=)++-- |Type class to express the equivalence of two values+class Equiv a where+  (=~=) :: a -> a -> Bool++instance Equiv a => Equiv (Maybe a) where+  Nothing =~= Nothing = True+  Nothing =~= Just _  = False+  Just _  =~= Nothing = False+  Just x  =~= Just y  = x =~= y++instance Equiv a => Equiv [a] where+  []     =~= []     = True+  (x:xs) =~= (y:ys) = x =~= y && xs =~= ys+  _      =~= _      = False++eqvList, eqvSet :: Equiv a => [a] -> [a] -> Bool+xs `eqvList` ys = length xs == length ys && and (zipWith (=~=) xs ys)+xs `eqvSet` ys = null (deleteFirstsBy (=~=) xs ys ++ deleteFirstsBy (=~=) ys xs)++instance Equiv Interface where+  Interface m1 is1 ds1 =~= Interface m2 is2 ds2+    = m1 == m2 && is1 `eqvSet` is2 && ds1 `eqvSet` ds2++instance Equiv IImportDecl where+  IImportDecl _ m1 =~= IImportDecl _ m2 = m1 == m2++-- Since the kind of type constructors or type classes can be omitted+-- in the interface when the kind is simple, i.e., it is either * or of+-- the form * -> ... -> *, a non given kind has to be considered equivalent+-- to a given one if the latter is simple.++eqvKindExpr :: Maybe KindExpr -> Maybe KindExpr -> Bool+Nothing  `eqvKindExpr` (Just k) = isSimpleKindExpr k+(Just k) `eqvKindExpr` Nothing  = isSimpleKindExpr k+k1       `eqvKindExpr` k2       = k1 == k2++isSimpleKindExpr :: KindExpr -> Bool+isSimpleKindExpr Star               = True+isSimpleKindExpr (ArrowKind Star k) = isSimpleKindExpr k+isSimpleKindExpr _                  = False+++instance Equiv IDecl where+  IInfixDecl _ fix1 p1 op1 =~= IInfixDecl _ fix2 p2 op2+    = fix1 == fix2 && p1 == p2 && op1 == op2+  HidingDataDecl _ tc1 k1 tvs1 =~= HidingDataDecl _ tc2 k2 tvs2+    = tc1 == tc2 && k1 `eqvKindExpr` k2 && tvs1 == tvs2+  IDataDecl _ tc1 k1 tvs1 cs1 hs1 =~= IDataDecl _ tc2 k2 tvs2 cs2 hs2+    = tc1 == tc2 && k1 `eqvKindExpr` k2 && tvs1 == tvs2 && cs1 =~= cs2 &&+      hs1 `eqvSet` hs2+  INewtypeDecl _ tc1 k1 tvs1 nc1 hs1 =~= INewtypeDecl _ tc2 k2 tvs2 nc2 hs2+    = tc1 == tc2 && k1 `eqvKindExpr` k2 && tvs1 == tvs2 && nc1 =~= nc2 &&+      hs1 `eqvSet` hs2+  ITypeDecl _ tc1 k1 tvs1 ty1 =~= ITypeDecl _ tc2 k2 tvs2 ty2+    = tc1 == tc2 && k1 `eqvKindExpr` k2 && tvs1 == tvs2 && ty1 == ty2+  IFunctionDecl _ f1 cm1 n1 qty1 =~= IFunctionDecl _ f2 cm2 n2 qty2+    = f1 == f2 && cm1 == cm2 && n1 == n2 && qty1 == qty2+  HidingClassDecl _ cx1 cls1 k1 _ =~= HidingClassDecl _ cx2 cls2 k2 _+    = cx1 == cx2 && cls1 == cls2 && k1 `eqvKindExpr` k2+  IClassDecl _ cx1 cls1 k1 _ ms1 hs1 =~= IClassDecl _ cx2 cls2 k2 _ ms2 hs2+    = cx1 == cx2 && cls1 == cls2 && k1 `eqvKindExpr` k2 &&+      ms1 `eqvList` ms2 && hs1 `eqvSet` hs2+  IInstanceDecl _ cx1 cls1 ty1 is1 m1 =~= IInstanceDecl _ cx2 cls2 ty2 is2 m2+    = cx1 == cx2 && cls1 == cls2 && ty1 == ty2 && sort is1 == sort is2 &&+      m1 == m2+  _ =~= _ = False++instance Equiv ConstrDecl where+  ConstrDecl _ c1 tys1 =~= ConstrDecl _ c2 tys2+    = c1 == c2 && tys1 == tys2+  ConOpDecl _ ty11 op1 ty12 =~= ConOpDecl _ ty21 op2 ty22+    = op1 == op2 && ty11 == ty21 && ty12 == ty22+  RecordDecl _ c1 fs1 =~= RecordDecl _ c2 fs2+    = c1 == c2 && fs1 `eqvList` fs2+  _ =~= _ = False++instance Equiv FieldDecl where+  FieldDecl _ ls1 ty1 =~= FieldDecl _ ls2 ty2 = ls1 == ls2 && ty1 == ty2++instance Equiv NewConstrDecl where+  NewConstrDecl _ c1 ty1 =~= NewConstrDecl _ c2 ty2 = c1 == c2 && ty1 == ty2+  NewRecordDecl _ c1 fld1 =~= NewRecordDecl _ c2 fld2 = c1 == c2 && fld1 == fld2+  _ =~= _ = False++instance Equiv IMethodDecl where+  IMethodDecl _ f1 a1 qty1 =~= IMethodDecl _ f2 a2 qty2+    = f1 == f2 && a1 == a2 && qty1 == qty2++instance Equiv Ident where+  (=~=) = (==)++-- If we check for a change in the interface, we do not need to check the+-- interface declarations, but still must disambiguate (nullary) type+-- constructors and type variables in type expressions. This is handled+-- by function 'fixInterface' and the associated type class 'FixInterface'.++-- |Disambiguate nullary type constructors and type variables.+fixInterface :: Interface -> Interface+fixInterface (Interface m is ds) = Interface m is $+  fix (Set.fromList (typeConstructors ds)) ds++class FixInterface a where+  fix :: Set.Set Ident -> a -> a++instance FixInterface a => FixInterface (Maybe a) where+  fix tcs = fmap (fix tcs)++instance FixInterface a => FixInterface [a] where+  fix tcs = map (fix tcs)++instance FixInterface IDecl where+  fix tcs (IDataDecl p tc k vs cs hs) =+    IDataDecl p tc k vs (fix tcs cs) hs+  fix tcs (INewtypeDecl p tc k vs nc hs) =+    INewtypeDecl p tc k vs (fix tcs nc) hs+  fix tcs (ITypeDecl p tc k vs ty) =+    ITypeDecl p tc k vs (fix tcs ty)+  fix tcs (IFunctionDecl p f cm n qty) =+    IFunctionDecl p f cm n (fix tcs qty)+  fix tcs (HidingClassDecl p cx cls k tv) =+    HidingClassDecl p (fix tcs cx) cls k tv+  fix tcs (IClassDecl p cx cls k tv ms hs) =+    IClassDecl p (fix tcs cx) cls k tv (fix tcs ms) hs+  fix tcs (IInstanceDecl p cx cls inst is m) =+    IInstanceDecl p (fix tcs cx) cls (fix tcs inst) is m+  fix _ d = d++instance FixInterface ConstrDecl where+  fix tcs (ConstrDecl p      c tys) = ConstrDecl p c (fix tcs tys)+  fix tcs (ConOpDecl  p ty1 op ty2) = ConOpDecl  p   (fix tcs ty1)+                                                op   (fix tcs ty2)+  fix tcs (RecordDecl p c fs)       = RecordDecl p c (fix tcs fs)++instance FixInterface FieldDecl where+  fix tcs (FieldDecl p ls ty) = FieldDecl p ls (fix tcs ty)++instance FixInterface NewConstrDecl where+  fix tcs (NewConstrDecl p c ty    ) = NewConstrDecl p c (fix tcs ty)+  fix tcs (NewRecordDecl p c (i,ty)) = NewRecordDecl p c (i, fix tcs ty)++instance FixInterface IMethodDecl where+  fix tcs (IMethodDecl p f a qty) = IMethodDecl p f a (fix tcs qty)++instance FixInterface QualTypeExpr where+  fix tcs (QualTypeExpr spi cx ty) = QualTypeExpr spi (fix tcs cx) (fix tcs ty)++instance FixInterface Constraint where+  fix tcs (Constraint spi qcls ty) = Constraint spi qcls (fix tcs ty)++instance FixInterface TypeExpr where+  fix tcs (ConstructorType spi tc)+    | not (isQualified tc) && not (isPrimTypeId tc) && tc' `Set.notMember` tcs+    = VariableType spi tc'+    | otherwise = ConstructorType spi tc+    where tc' = unqualify tc+  fix tcs (ApplyType  spi ty1 ty2) = ApplyType spi (fix tcs ty1) (fix tcs ty2)+  fix tcs (VariableType    spi tv)+    | tv `Set.member` tcs = ConstructorType spi (qualify tv)+    | otherwise           = VariableType spi tv+  fix tcs (TupleType      spi tys) = TupleType spi (fix tcs tys)+  fix tcs (ListType        spi ty) = ListType  spi (fix tcs ty)+  fix tcs (ArrowType  spi ty1 ty2) = ArrowType spi (fix tcs ty1) (fix tcs ty2)+  fix tcs (ParenType       spi ty) = ParenType spi (fix tcs ty)+  fix tcs (ForallType   spi vs ty) = ForallType spi vs (fix tcs ty)++typeConstructors :: [IDecl] -> [Ident]+typeConstructors ds = [tc | (QualIdent _ Nothing tc) <- foldr tyCons [] ds]+  where tyCons (IInfixDecl          _ _ _ _) tcs = tcs+        tyCons (HidingDataDecl     _ tc _ _) tcs = tc : tcs+        tyCons (IDataDecl      _ tc _ _ _ _) tcs = tc : tcs+        tyCons (INewtypeDecl   _ tc _ _ _ _) tcs = tc : tcs+        tyCons (ITypeDecl        _ tc _ _ _) tcs = tc : tcs+        tyCons (IFunctionDecl     _ _ _ _ _) tcs = tcs+        tyCons (HidingClassDecl   _ _ _ _ _) tcs = tcs+        tyCons (IClassDecl    _ _ _ _ _ _ _) tcs = tcs+        tyCons (IInstanceDecl   _ _ _ _ _ _) tcs = tcs
− src/Curry/Syntax/LLParseComb.lhs 
@@ -1,288 +0,0 @@-% $Id: LLParseComb.lhs,v 1.26 2004/02/15 23:11:30 wlux Exp $-%-% Copyright (c) 1999-2004, Wolfgang Lux-% See LICENSE for the full license.-%-\nwfilename{LLParseComb.lhs}-\section{Parsing Combinators}\label{sec:ll-parsecomb}-The parsing combinators implemented in the module \texttt{LLParseComb}-are based on the LL(1) parsing combinators developed by Swierstra and-Duponcheel~\cite{SwierstraDuponcheel96:Parsers}. They have been-adapted to using continuation passing style in order to work with the-lexing combinators described in the previous section. In addition, the-facilities for error correction are omitted in this implementation.--The two functions \texttt{applyParser} and \texttt{prefixParser} use-the specified parser for parsing a string. When \texttt{applyParser}-is used, an error is reported if the parser does not consume the whole-string, whereas \texttt{prefixParser} discards the rest of the input-string in this case.-\begin{verbatim}--> module Curry.Syntax.LLParseComb(Symbol(..),Parser,->                    applyParser,prefixParser, position,succeed,symbol,->                    (<?>),(<|>),(<|?>),(<*>),(<\>),(<\\>),->                    opt,(<$>),(<$->),(<*->),(<-*>),(<**>),(<??>),(<.>),->                    many,many1, sepBy,sepBy1, chainr,chainr1,chainl,chainl1,->                    bracket,ops, layoutOn,layoutOff,layoutEnd) where--> import Control.Monad-> import Data.Maybe-> import qualified Data.Set as Set-> import qualified Data.Map as Map--> import Curry.Syntax.LexComb-> import Curry.Base.MessageMonad-> import Curry.Base.Position---> infixl 5 <\>, <\\>-> infixl 4 <*>, <$>, <$->, <*->, <-*>, <**>, <??>, <.>-> infixl 3 <|>, <|?>-> infixl 2 <?>, `opt`--\end{verbatim}-\paragraph{Parser types}-\begin{verbatim}--> class (Ord s,Show s) => Symbol s where->   isEOF :: s -> Bool--> type SuccessCont s a = Position -> s -> P a-> type FailureCont a = Position -> String -> P a-> type Lexer s a = SuccessCont s a -> FailureCont a -> P a-> type ParseFun s a b = (a -> SuccessCont s b) -> FailureCont b->                     -> SuccessCont s b--> data Parser s a b = Parser (Maybe (ParseFun s a b))->                            (Map.Map s (Lexer s b -> ParseFun s a b))--> instance Symbol s => Show (Parser s a b) where->   showsPrec p (Parser e ps) = showParen (p >= 10) $->     showString "Parser " . shows (isJust e) .->     showChar ' ' . shows (Map.keysSet ps)--> applyParser :: Symbol s => Parser s a a -> Lexer s a -> FilePath -> String->             -> MsgMonad a-> applyParser p lexer = parse (lexer (choose p lexer done failP) failP)->   where done x pos s->           | isEOF s = returnP x->           | otherwise = failP pos (unexpected s)--> prefixParser :: Symbol s => Parser s a a -> Lexer s a -> FilePath -> String->              -> MsgMonad a-> prefixParser p lexer = parse (lexer (choose p lexer discard failP) failP)->   where discard x _ _ = returnP x--> choose :: Symbol s => Parser s a b -> Lexer s b -> ParseFun s a b-> choose (Parser e ps) lexer success fail pos s =->   case Map.lookup s ps of->     Just p -> p lexer success fail pos s->     Nothing ->->       case e of->         Just p -> p success fail pos s->         Nothing -> fail pos (unexpected s)--> unexpected :: Symbol s => s -> String-> unexpected s->   | isEOF s = "Unexpected end-of-file"->   | otherwise = "Unexpected token " ++ show s--\end{verbatim}-\paragraph{Basic combinators}-\begin{verbatim}--> position :: Symbol s => Parser s Position b-> position = Parser (Just p) Map.empty->   where p success _ pos = success pos pos--> succeed :: Symbol s => a -> Parser s a b-> succeed x = Parser (Just p) Map.empty->   where p success _ = success x--> symbol :: Symbol s => s -> Parser s s a-> symbol s = Parser Nothing (Map.singleton s p)->   where p lexer success fail pos s = lexer (success s) fail--> (<?>) :: Symbol s => Parser s a b -> String -> Parser s a b-> p <?> msg = p <|> Parser (Just pfail) Map.empty->   where pfail _ fail pos _ = fail pos msg--> (<|>) :: Symbol s => Parser s a b -> Parser s a b -> Parser s a b-> Parser e1 ps1 <|> Parser e2 ps2->   | isJust e1 && isJust e2 = error "Ambiguous parser for empty word"->   | not (Set.null common) = error ("Ambiguous parser for " ++ show common)->   | otherwise = Parser (e1 `mplus` e2) (Map.union ps1 ps2)->   where common = Map.keysSet ps1 `Set.intersection` Map.keysSet ps2--\end{verbatim}-The parsing combinators presented so far require that the grammar-being parsed is LL(1). In some cases it may be difficult or even-impossible to transform a grammar into LL(1) form. As a remedy, we-include a non-deterministic version of the choice combinator in-addition to the deterministic combinator adapted from the paper. For-every symbol from the intersection of the parser's first sets, the-combinator \texttt{(<|?>)} applies both parsing functions to the input-stream and uses that one which processes the longer prefix of the-input stream irrespective of whether it succeeds or fails. If both-functions recognize the same prefix, we choose the one that succeeds-and report an ambiguous parse error if both succeed.-\begin{verbatim}--> (<|?>) :: Symbol s => Parser s a b -> Parser s a b -> Parser s a b-> Parser e1 ps1 <|?> Parser e2 ps2->   | isJust e1 && isJust e2 = error "Ambiguous parser for empty word"->   | otherwise = Parser (e1 `mplus` e2) (Map.union ps1' ps2)->   where ps1' = Map.fromList [(s,maybe p (try p) (Map.lookup s ps2))->                           | (s,p) <- Map.toList ps1]->         try p1 p2 lexer success fail pos s =->           closeP1 p2s `thenP` \p2s' ->->           closeP1 p2f `thenP` \p2f' ->->           parse p1 (retry p2s') (retry p2f')->           where p2s r1 = parse p2 (select True r1) (select False r1)->                 p2f r1 = parse p2 (flip (select False) r1) (select False r1)->                 parse p psucc pfail =->                   p lexer (successK psucc) (failK pfail) pos s->                 successK k x pos s = k (pos,success x pos s)->                 failK k pos msg = k (pos,fail pos msg)->                 retry k (pos,p) = closeP0 p `thenP` curry k pos->         select suc (pos1,p1) (pos2,p2) =->           case pos1 `compare` pos2 of->             GT -> p1->             EQ->               | suc -> error ("Ambiguous parse before " ++ show pos1)->               | otherwise -> p1->             LT -> p2--> (<*>) :: Symbol s => Parser s (a -> b) c -> Parser s a c -> Parser s b c-> Parser (Just p1) ps1 <*> ~p2@(Parser e2 ps2) =->   Parser (fmap (seqEE p1) e2)->          (Map.union (fmap (flip seqPP p2) ps1) (fmap (seqEP p1) ps2))-> Parser Nothing ps1 <*> p2 = Parser Nothing (fmap (flip seqPP p2) ps1)--> seqEE :: Symbol s => ParseFun s (a -> b) c -> ParseFun s a c->       -> ParseFun s b c-> seqEE p1 p2 success fail = p1 (\f -> p2 (success . f) fail) fail--> seqEP :: Symbol s => ParseFun s (a -> b) c -> (Lexer s c -> ParseFun s a c)->       -> Lexer s c -> ParseFun s b c-> seqEP p1 p2 lexer success fail = p1 (\f -> p2 lexer (success . f) fail) fail--> seqPP :: Symbol s => (Lexer s c -> ParseFun s (a -> b) c) -> Parser s a c->       -> Lexer s c -> ParseFun s b c-> seqPP p1 p2 lexer success fail =->   p1 lexer (\f -> choose p2 lexer (success . f) fail) fail--\end{verbatim}-The combinators \verb|<\\>| and \verb|<\>| can be used to restrict-the first set of a parser. This is useful for combining two parsers-with an overlapping first set with the deterministic combinator <|>.-\begin{verbatim}--> (<\>) :: Symbol s => Parser s a c -> Parser s b c -> Parser s a c-> p <\> Parser _ ps = p <\\> Map.keys ps--> (<\\>) :: Symbol s => Parser s a b -> [s] -> Parser s a b-> Parser e ps <\\> xs = Parser e (foldr Map.delete ps xs)--\end{verbatim}-\paragraph{Other combinators.}-Note that some of these combinators have not been published in the-paper, but were taken from the implementation found on the web.-\begin{verbatim}--> opt :: Symbol s => Parser s a b -> a -> Parser s a b-> p `opt` x = p <|> succeed x--> (<$>) :: Symbol s => (a -> b) -> Parser s a c -> Parser s b c-> f <$> p = succeed f <*> p--> (<$->) :: Symbol s => a -> Parser s b c -> Parser s a c-> f <$-> p = const f <$> p--> (<*->) :: Symbol s => Parser s a c -> Parser s b c -> Parser s a c-> p <*-> q = const <$> p <*> q--> (<-*>) :: Symbol s => Parser s a c -> Parser s b c -> Parser s b c-> p <-*> q = const id <$> p <*> q--> (<**>) :: Symbol s => Parser s a c -> Parser s (a -> b) c -> Parser s b c-> p <**> q = flip ($) <$> p <*> q--> (<??>) :: Symbol s => Parser s a b -> Parser s (a -> a) b -> Parser s a b-> p <??> q = p <**> (q `opt` id)--> (<.>) :: Symbol s => Parser s (a -> b) d -> Parser s (b -> c) d->       -> Parser s (a -> c) d-> p1 <.> p2 = p1 <**> ((.) <$> p2)--> many :: Symbol s => Parser s a b -> Parser s [a] b-> many p = many1 p `opt` []--> many1 :: Symbol s => Parser s a b -> Parser s [a] b-> -- many1 p = (:) <$> p <*> many p-> many1 p = (:) <$> p <*> (many1 p `opt` [])--\end{verbatim}-The first definition of \texttt{many1} is commented out because it-does not compile under nhc. This is due to a -- known -- bug in the-type checker of nhc which expects a default declaration when compiling-mutually recursive functions with class constraints. However, no such-default can be given in the above case because neither of the types-involved is a numeric type.-\begin{verbatim}--> sepBy :: Symbol s => Parser s a c -> Parser s b c -> Parser s [a] c-> p `sepBy` q = p `sepBy1` q `opt` []--> sepBy1 :: Symbol s => Parser s a c -> Parser s b c -> Parser s [a] c-> p `sepBy1` q = (:) <$> p <*> many (q <-*> p)--> chainr :: Symbol s => Parser s a b -> Parser s (a -> a -> a) b -> a->        -> Parser s a b-> chainr p op x = chainr1 p op `opt` x--> chainr1 :: Symbol s => Parser s a b -> Parser s (a -> a -> a) b->         -> Parser s a b-> chainr1 p op = r->   where r = p <**> (flip <$> op <*> r `opt` id)--> chainl :: Symbol s => Parser s a b -> Parser s (a -> a -> a) b -> a->        -> Parser s a b-> chainl p op x = chainl1 p op `opt` x--> chainl1 :: Symbol s => Parser s a b -> Parser s (a -> a -> a) b->         -> Parser s a b-> chainl1 p op = foldF <$> p <*> many (flip <$> op <*> p)->   where foldF x [] = x->         foldF x (f:fs) = foldF (f x) fs--> bracket :: Symbol s => Parser s a c -> Parser s b c -> Parser s a c->         -> Parser s b c-> bracket open p close = open <-*> p <*-> close--> ops :: Symbol s => [(s,a)] -> Parser s a b-> ops [] = error "internal error: ops"-> ops [(s,x)] = x <$-> symbol s-> ops ((s,x):rest) = x <$-> symbol s <|> ops rest--\end{verbatim}-\paragraph{Layout combinators}-Note that the layout functions grab the next token (and its position).-After modifying the layout context, the continuation is called with-the same token and an undefined result.-\begin{verbatim}--> layoutOn :: Symbol s => Parser s a b-> layoutOn = Parser (Just on) Map.empty->   where on success _ pos = pushContext (column pos) . success undefined pos--> layoutOff :: Symbol s => Parser s a b-> layoutOff = Parser (Just off) Map.empty->   where off success _ pos = pushContext (-1) . success undefined pos--> layoutEnd :: Symbol s => Parser s a b-> layoutEnd = Parser (Just end) Map.empty->   where end success _ pos = popContext . success undefined pos--\end{verbatim}
− src/Curry/Syntax/LexComb.lhs 
@@ -1,104 +0,0 @@-% -*- LaTeX -*--% $Id: LexComb.lhs,v 1.16 2004/01/20 16:44:14 wlux Exp $-%-% Copyright (c) 1999-2004, Wolfgang Lux-% See LICENSE for the full license.-%-\nwfilename{LexComb.lhs}-\section{Lexing combinators}-The module \texttt{LexComb} provides the basic types and combinators-to implement the lexers. The combinators use continuation passing code-in a monadic style. The first argument of the continuation function is-the current position, and the second is the string to be parsed. The third-argument is a flag which signals the lexer that it is lexing the-beginning of a line and therefore has to check for layout tokens. The-fourth argument is a stack of indentations that is used to handle-nested layout groups.-\begin{verbatim}--> module Curry.Syntax.LexComb where--> import Data.Char--> import Curry.Base.MessageMonad-> import Curry.Base.Position--> infixl 1 `thenP`, `thenP_`--> type Indent = Int-> type Context = [Indent]-> type P a = Position -> String -> Bool -> Context -> MsgMonad a--> parse :: P a -> FilePath -> String -> MsgMonad a-> parse p fn s = p (first fn) s False []--\end{verbatim}-Monad functions for the lexer.-\begin{verbatim}--> returnP :: a -> P a-> returnP x _ _ _ _ = return x--> thenP :: P a -> (a -> P b) -> P b-> thenP lex k pos s bol ctxt = lex pos s bol ctxt >>= \x -> k x pos s bol ctxt--> thenP_ :: P a -> P b -> P b-> p1 `thenP_` p2 = p1 `thenP` \_ -> p2--> failP :: Position -> String -> P a-> failP pos msg _ _ _ _ = failWith (parseError pos msg)--> closeP0 :: P a -> P (P a)-> closeP0 lex pos s bol ctxt = return (\_ _ _ _ -> lex pos s bol ctxt)--> closeP1 :: (a -> P b) -> P (a -> P b)-> closeP1 f pos s bol ctxt = return (\x _ _ _ _ -> f x pos s bol ctxt)--> parseError :: Position -> String -> String-> parseError p what = "\n" ++ show p ++ ": " ++ what--\end{verbatim}-Combinators that handle layout.-\begin{verbatim}--> pushContext :: Int -> P a -> P a-> pushContext col cont pos s bol ctxt = cont pos s bol (col:ctxt)--> popContext :: P a -> P a-> popContext cont pos s bol (_:ctxt) = cont pos s bol ctxt-> popContext cont pos s bol [] =->    error "parse error: popping layout from empty context stack. \->          \Perhaps you have inserted too many '}'?"--\end{verbatim}-Conversions from strings into numbers.-\begin{verbatim}--> convertSignedIntegral :: Num a => a -> String -> a-> convertSignedIntegral b ('+':s) = convertIntegral b s-> convertSignedIntegral b ('-':s) = - convertIntegral b s-> convertSignedIntegral b s = convertIntegral b s--> convertIntegral :: Num a => a -> String -> a-> convertIntegral b = foldl op 0->   where m `op` n | isDigit n = b * m + fromIntegral (ord n - ord0)->                  | isUpper n = b * m + fromIntegral (ord n - ordA)->                  | otherwise = b * m + fromIntegral (ord n - orda)->         ord0 = ord '0'->         ordA = ord 'A' - 10->         orda = ord 'a' - 10--> convertSignedFloating :: Fractional a => String -> String -> Int -> a-> convertSignedFloating ('+':m) f e = convertFloating m f e-> convertSignedFloating ('-':m) f e = - convertFloating m f e-> convertSignedFloating m f e = convertFloating m f e--> convertFloating :: Fractional a => String -> String -> Int -> a-> convertFloating m f e->   | e' == 0 = m'->   | e' > 0  = m' * 10^e'->   | otherwise = m' / 10^(-e')->   where m' = convertIntegral 10 (m ++ f)->         e' = e - length f--\end{verbatim}
+ src/Curry/Syntax/Lexer.hs view
@@ -0,0 +1,889 @@+{- |+    Module      :  $Header$+    Description :  A lexer for Curry+    Copyright   :  (c) 1999 - 2004 Wolfgang Lux+                       2005        Martin Engelke+                       2011 - 2013 Björn Peemöller+                       2016        Finn Teegen+                       2016        Jan Tikovsky+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable+-}+module Curry.Syntax.Lexer+  ( -- * Data types for tokens+    Token (..), Category (..), Attributes (..)++    -- * lexing functions+  , lexSource, lexer, fullLexer+  ) where++import Prelude hiding (fail)+import Data.Char+  ( chr, ord, isAlpha, isAlphaNum, isDigit, isHexDigit, isOctDigit+  , isSpace, isUpper, toLower+  )+import Data.List (intercalate)+import qualified Data.Map as Map+  (Map, union, lookup, findWithDefault, fromList)++import Curry.Base.LexComb+import Curry.Base.Position+import Curry.Base.Span++-- ---------------------------------------------------------------------------+-- Tokens. Note that the equality and ordering instances of Token disregard+-- the attributes, as so that the parser decides about accepting a token+-- just by its category.+-- ---------------------------------------------------------------------------++-- |Data type for curry lexer tokens+data Token = Token Category Attributes++instance Eq Token where+  Token c1 _ == Token c2 _ = c1 == c2++instance Ord Token where+  Token c1 _ `compare` Token c2 _ = c1 `compare` c2++instance Symbol Token where+  isEOF (Token c _) = c == EOF++  dist _ (Token VSemicolon         _) = (0,  0)+  dist _ (Token VRightBrace        _) = (0,  0)+  dist _ (Token EOF                _) = (0,  0)+  dist _ (Token DotDot             _) = (0,  1)+  dist _ (Token DoubleColon        _) = (0,  1)+  dist _ (Token LeftArrow          _) = (0,  1)+  dist _ (Token RightArrow         _) = (0,  1)+  dist _ (Token DoubleArrow        _) = (0,  1)+  dist _ (Token KW_do              _) = (0,  1)+  dist _ (Token KW_if              _) = (0,  1)+  dist _ (Token KW_in              _) = (0,  1)+  dist _ (Token KW_of              _) = (0,  1)+  dist _ (Token Id_as              _) = (0,  1)+  dist _ (Token KW_let             _) = (0,  2)+  dist _ (Token PragmaEnd          _) = (0,  2)+  dist _ (Token KW_case            _) = (0,  3)+  dist _ (Token KW_class           _) = (0,  4)+  dist _ (Token KW_data            _) = (0,  3)+  dist _ (Token KW_default         _) = (0,  6)+  dist _ (Token KW_deriving        _) = (0,  7)+  dist _ (Token KW_else            _) = (0,  3)+  dist _ (Token KW_free            _) = (0,  3)+  dist _ (Token KW_then            _) = (0,  3)+  dist _ (Token KW_type            _) = (0,  3)+  dist _ (Token KW_fcase           _) = (0,  4)+  dist _ (Token KW_infix           _) = (0,  4)+  dist _ (Token KW_instance        _) = (0,  7)+  dist _ (Token KW_where           _) = (0,  4)+  dist _ (Token Id_ccall           _) = (0,  4)+  dist _ (Token KW_import          _) = (0,  5)+  dist _ (Token KW_infixl          _) = (0,  5)+  dist _ (Token KW_infixr          _) = (0,  5)+  dist _ (Token KW_module          _) = (0,  5)+  dist _ (Token Id_forall          _) = (0,  5)+  dist _ (Token Id_hiding          _) = (0,  5)+  dist _ (Token KW_newtype         _) = (0,  6)+  dist _ (Token KW_external        _) = (0,  7)+  dist _ (Token Id_interface       _) = (0,  8)+  dist _ (Token Id_primitive       _) = (0,  8)+  dist _ (Token Id_qualified       _) = (0,  8)+  dist _ (Token PragmaHiding       _) = (0,  9)+  dist _ (Token PragmaLanguage     _) = (0, 11)+  dist _ (Token Id                 a) = distAttr False a+  dist _ (Token QId                a) = distAttr False a+  dist _ (Token Sym                a) = distAttr False a+  dist _ (Token QSym               a) = distAttr False a+  dist _ (Token IntTok             a) = distAttr False a+  dist _ (Token FloatTok           a) = distAttr False a+  dist _ (Token CharTok            a) = distAttr False a+  dist c (Token StringTok          a) = updColDist c (distAttr False a)+  dist _ (Token LineComment        a) = distAttr True  a+  dist c (Token NestedComment      a) = updColDist c (distAttr True  a)+  dist _ (Token PragmaOptions      a) = let (ld, cd) = distAttr False a+                                        in  (ld, cd + 11)+  dist _ _                            = (0, 0)++-- TODO: Comment+updColDist :: Int -> Distance -> Distance+updColDist c (ld, cd) = (ld, if ld == 0 then cd else cd - c + 1)++distAttr :: Bool -> Attributes -> Distance+distAttr isComment attr = case attr of+  NoAttributes              -> (0, 0)+  CharAttributes     _ orig -> (0, length orig + 1)+  IntAttributes      _ orig -> (0, length orig - 1)+  FloatAttributes    _ orig -> (0, length orig - 1)+  StringAttributes   _ orig+      -- comment without surrounding quotes+    | isComment             -> (ld, cd)+      -- string with one ending double quote or two surrounding double quotes+      -- (column distance + 1 / + 2)+    | '\n' `elem` orig      -> (ld, cd + 1)+    | otherwise             -> (ld, cd + 2)+    where ld = length (filter    (== '\n') orig)+          cd = length (takeWhile (/= '\n') (reverse orig)) - 1+  IdentAttributes    mid i  -> (0, length (intercalate "." (mid ++ [i])) - 1)+  OptionsAttributes mt args -> case mt of+                                 Nothing -> (0, distArgs + 1)+                                 Just t  -> (0, length t + distArgs + 2)+    where distArgs = length args++-- |Category of curry tokens+data Category+  -- literals+  = CharTok+  | IntTok+  | FloatTok+  | StringTok++  -- identifiers+  | Id   -- identifier+  | QId  -- qualified identifier+  | Sym  -- symbol+  | QSym -- qualified symbol++  -- punctuation symbols+  | LeftParen     -- (+  | RightParen    -- )+  | Semicolon     -- ;+  | LeftBrace     -- {+  | RightBrace    -- }+  | LeftBracket   -- [+  | RightBracket  -- ]+  | Comma         -- ,+  | Underscore    -- _+  | Backquote     -- `++  -- layout+  | VSemicolon         -- virtual ;+  | VRightBrace        -- virtual }++  -- reserved keywords+  | KW_case+  | KW_class+  | KW_data+  | KW_default+  | KW_deriving+  | KW_do+  | KW_else+  | KW_external+  | KW_fcase+  | KW_free+  | KW_if+  | KW_import+  | KW_in+  | KW_infix+  | KW_infixl+  | KW_infixr+  | KW_instance+  | KW_let+  | KW_module+  | KW_newtype+  | KW_of+  | KW_then+  | KW_type+  | KW_where++  -- reserved operators+  | At           -- @+  | Colon        -- :+  | DotDot       -- ..+  | DoubleColon  -- ::+  | Equals       -- =+  | Backslash    -- \+  | Bar          -- |+  | LeftArrow    -- <-+  | RightArrow   -- ->+  | Tilde        -- ~+  | DoubleArrow  -- =>++  -- special identifiers+  | Id_as+  | Id_ccall+  | Id_forall+  | Id_hiding+  | Id_interface+  | Id_primitive+  | Id_qualified++  -- special operators+  | SymDot      -- .+  | SymMinus    -- -++  -- special symbols+  | SymStar -- kind star (*)++  -- pragmas+  | PragmaLanguage -- {-# LANGUAGE+  | PragmaOptions  -- {-# OPTIONS+  | PragmaHiding   -- {-# HIDING+  | PragmaMethod   -- {-# METHOD+  | PragmaModule   -- {-# MODULE+  | PragmaEnd      -- #-}+++  -- comments (only for full lexer) inserted by men & bbr+  | LineComment+  | NestedComment++  -- end-of-file token+  | EOF+    deriving (Eq, Ord)++-- There are different kinds of attributes associated with the tokens.+-- Most attributes simply save the string corresponding to the token.+-- However, for qualified identifiers, we also record the list of module+-- qualifiers. The values corresponding to a literal token are properly+-- converted already. To simplify the creation and extraction of+-- attribute values, we make use of records.++-- |Attributes associated to a token+data Attributes+  = NoAttributes+  | CharAttributes    { cval     :: Char        , original :: String }+  | IntAttributes     { ival     :: Integer     , original :: String }+  | FloatAttributes   { fval     :: Double      , original :: String }+  | StringAttributes  { sval     :: String      , original :: String }+  | IdentAttributes   { modulVal :: [String]    , sval     :: String }+  | OptionsAttributes { toolVal  :: Maybe String, toolArgs :: String }++instance Show Attributes where+  showsPrec _ NoAttributes             = showChar '_'+  showsPrec _ (CharAttributes    cv _) = shows cv+  showsPrec _ (IntAttributes     iv _) = shows iv+  showsPrec _ (FloatAttributes   fv _) = shows fv+  showsPrec _ (StringAttributes  sv _) = shows sv+  showsPrec _ (IdentAttributes  mid i) = showsEscaped+                                       $ intercalate "." $ mid ++ [i]+  showsPrec _ (OptionsAttributes mt s) = showsTool mt+                                       . showChar ' ' . showString s+    where showsTool = maybe id (\t -> showChar '_' . showString t)+++-- ---------------------------------------------------------------------------+-- The 'Show' instance of 'Token' is designed to display all tokens in their+-- source representation.+-- ---------------------------------------------------------------------------++showsEscaped :: String -> ShowS+showsEscaped s = showChar '`' . showString s . showChar '\''++showsIdent :: Attributes -> ShowS+showsIdent a = showString "identifier " . shows a++showsSpecialIdent :: String -> ShowS+showsSpecialIdent s = showString "identifier " . showsEscaped s++showsOperator :: Attributes -> ShowS+showsOperator a = showString "operator " . shows a++showsSpecialOperator :: String -> ShowS+showsSpecialOperator s = showString "operator " . showsEscaped s++instance Show Token where+  showsPrec _ (Token Id                 a) = showsIdent a+  showsPrec _ (Token QId                a) = showString "qualified "+                                           . showsIdent a+  showsPrec _ (Token Sym                a) = showsOperator a+  showsPrec _ (Token QSym               a) = showString "qualified "+                                           . showsOperator a+  showsPrec _ (Token IntTok             a) = showString "integer "   . shows a+  showsPrec _ (Token FloatTok           a) = showString "float "     . shows a+  showsPrec _ (Token CharTok            a) = showString "character " . shows a+  showsPrec _ (Token StringTok          a) = showString "string "    . shows a+  showsPrec _ (Token LeftParen          _) = showsEscaped "("+  showsPrec _ (Token RightParen         _) = showsEscaped ")"+  showsPrec _ (Token Semicolon          _) = showsEscaped ";"+  showsPrec _ (Token LeftBrace          _) = showsEscaped "{"+  showsPrec _ (Token RightBrace         _) = showsEscaped "}"+  showsPrec _ (Token LeftBracket        _) = showsEscaped "["+  showsPrec _ (Token RightBracket       _) = showsEscaped "]"+  showsPrec _ (Token Comma              _) = showsEscaped ","+  showsPrec _ (Token Underscore         _) = showsEscaped "_"+  showsPrec _ (Token Backquote          _) = showsEscaped "`"+  showsPrec _ (Token VSemicolon         _)+    = showsEscaped ";" . showString " (inserted due to layout)"+  showsPrec _ (Token VRightBrace        _)+    = showsEscaped "}" . showString " (inserted due to layout)"+  showsPrec _ (Token At                 _) = showsEscaped "@"+  showsPrec _ (Token Colon              _) = showsEscaped ":"+  showsPrec _ (Token DotDot             _) = showsEscaped ".."+  showsPrec _ (Token DoubleArrow        _) = showsEscaped "=>"+  showsPrec _ (Token DoubleColon        _) = showsEscaped "::"+  showsPrec _ (Token Equals             _) = showsEscaped "="+  showsPrec _ (Token Backslash          _) = showsEscaped "\\"+  showsPrec _ (Token Bar                _) = showsEscaped "|"+  showsPrec _ (Token LeftArrow          _) = showsEscaped "<-"+  showsPrec _ (Token RightArrow         _) = showsEscaped "->"+  showsPrec _ (Token Tilde              _) = showsEscaped "~"+  showsPrec _ (Token SymDot             _) = showsSpecialOperator "."+  showsPrec _ (Token SymMinus           _) = showsSpecialOperator "-"+  showsPrec _ (Token SymStar            _) = showsEscaped "*"+  showsPrec _ (Token KW_case            _) = showsEscaped "case"+  showsPrec _ (Token KW_class           _) = showsEscaped "class"+  showsPrec _ (Token KW_data            _) = showsEscaped "data"+  showsPrec _ (Token KW_default         _) = showsEscaped "default"+  showsPrec _ (Token KW_deriving        _) = showsEscaped "deriving"+  showsPrec _ (Token KW_do              _) = showsEscaped "do"+  showsPrec _ (Token KW_else            _) = showsEscaped "else"+  showsPrec _ (Token KW_external        _) = showsEscaped "external"+  showsPrec _ (Token KW_fcase           _) = showsEscaped "fcase"+  showsPrec _ (Token KW_free            _) = showsEscaped "free"+  showsPrec _ (Token KW_if              _) = showsEscaped "if"+  showsPrec _ (Token KW_import          _) = showsEscaped "import"+  showsPrec _ (Token KW_in              _) = showsEscaped "in"+  showsPrec _ (Token KW_infix           _) = showsEscaped "infix"+  showsPrec _ (Token KW_infixl          _) = showsEscaped "infixl"+  showsPrec _ (Token KW_infixr          _) = showsEscaped "infixr"+  showsPrec _ (Token KW_instance        _) = showsEscaped "instance"+  showsPrec _ (Token KW_let             _) = showsEscaped "let"+  showsPrec _ (Token KW_module          _) = showsEscaped "module"+  showsPrec _ (Token KW_newtype         _) = showsEscaped "newtype"+  showsPrec _ (Token KW_of              _) = showsEscaped "of"+  showsPrec _ (Token KW_then            _) = showsEscaped "then"+  showsPrec _ (Token KW_type            _) = showsEscaped "type"+  showsPrec _ (Token KW_where           _) = showsEscaped "where"+  showsPrec _ (Token Id_as              _) = showsSpecialIdent "as"+  showsPrec _ (Token Id_ccall           _) = showsSpecialIdent "ccall"+  showsPrec _ (Token Id_forall          _) = showsSpecialIdent "forall"+  showsPrec _ (Token Id_hiding          _) = showsSpecialIdent "hiding"+  showsPrec _ (Token Id_interface       _) = showsSpecialIdent "interface"+  showsPrec _ (Token Id_primitive       _) = showsSpecialIdent "primitive"+  showsPrec _ (Token Id_qualified       _) = showsSpecialIdent "qualified"+  showsPrec _ (Token PragmaLanguage     _) = showString "{-# LANGUAGE"+  showsPrec _ (Token PragmaOptions      a) = showString "{-# OPTIONS"+                                           . shows a+  showsPrec _ (Token PragmaHiding       _) = showString "{-# HIDING"+  showsPrec _ (Token PragmaMethod       _) = showString "{-# METHOD"+  showsPrec _ (Token PragmaModule       _) = showString "{-# MODULE"+  showsPrec _ (Token PragmaEnd          _) = showString "#-}"+  showsPrec _ (Token LineComment        a) = shows a+  showsPrec _ (Token NestedComment      a) = shows a+  showsPrec _ (Token EOF                _) = showString "<end-of-file>"++-- ---------------------------------------------------------------------------+-- The following functions can be used to construct tokens with+-- specific attributes.+-- ---------------------------------------------------------------------------++-- |Construct a simple 'Token' without 'Attributes'+tok :: Category -> Token+tok t = Token t NoAttributes++-- |Construct a 'Token' for a single 'Char'+charTok :: Char -> String -> Token+charTok c o = Token CharTok CharAttributes { cval = c, original = o }++-- |Construct a 'Token' for an int value+intTok :: Integer -> String -> Token+intTok base digits = Token IntTok IntAttributes+  { ival = convertIntegral base digits, original = digits }++-- |Construct a 'Token' for a float value+floatTok :: String -> String -> Int -> String -> Token+floatTok mant frac expo rest = Token FloatTok FloatAttributes+  { fval     = convertFloating mant frac expo+  , original = mant ++ "." ++ frac ++ rest }++-- |Construct a 'Token' for a string value+stringTok :: String -> String -> Token+stringTok cs s = Token StringTok StringAttributes { sval = cs, original = s }++-- |Construct a 'Token' for identifiers+idTok :: Category -> [String] -> String -> Token+idTok t mIdent ident = Token t+  IdentAttributes { modulVal = mIdent, sval = ident }++-- TODO+pragmaOptionsTok :: Maybe String -> String -> Token+pragmaOptionsTok mbTool s = Token PragmaOptions+  OptionsAttributes { toolVal = mbTool, toolArgs = s }++-- |Construct a 'Token' for a line comment+lineCommentTok :: String -> Token+lineCommentTok s = Token LineComment+  StringAttributes { sval = s, original = s }++-- |Construct a 'Token' for a nested comment+nestedCommentTok :: String -> Token+nestedCommentTok s = Token NestedComment+  StringAttributes { sval = s, original = s }++-- ---------------------------------------------------------------------------+-- Tables for reserved operators and identifiers+-- ---------------------------------------------------------------------------++-- |Map of reserved operators+reservedOps:: Map.Map String Category+reservedOps = Map.fromList+  [ ("@" , At         )+  , (":" , Colon      )+  , ("=>", DoubleArrow)+  , ("::", DoubleColon)+  , ("..", DotDot     )+  , ("=" , Equals     )+  , ("\\", Backslash  )+  , ("|" , Bar        )+  , ("<-", LeftArrow  )+  , ("->", RightArrow )+  , ("~" , Tilde      )+  ]++-- |Map of reserved and special operators+reservedSpecialOps :: Map.Map String Category+reservedSpecialOps = Map.union reservedOps $ Map.fromList+  [ ("." , SymDot     )+  , ("-" , SymMinus   )+  , ("*" , SymStar    )+  ]++-- |Map of keywords+keywords :: Map.Map String Category+keywords = Map.fromList+  [ ("case"    , KW_case    )+  , ("class"   , KW_class   )+  , ("data"    , KW_data    )+  , ("default" , KW_default )+  , ("deriving", KW_deriving)+  , ("do"      , KW_do      )+  , ("else"    , KW_else    )+  , ("external", KW_external)+  , ("fcase"   , KW_fcase   )+  , ("free"    , KW_free    )+  , ("if"      , KW_if      )+  , ("import"  , KW_import  )+  , ("in"      , KW_in      )+  , ("infix"   , KW_infix   )+  , ("infixl"  , KW_infixl  )+  , ("infixr"  , KW_infixr  )+  , ("instance", KW_instance)+  , ("let"     , KW_let     )+  , ("module"  , KW_module  )+  , ("newtype" , KW_newtype )+  , ("of"      , KW_of      )+  , ("then"    , KW_then    )+  , ("type"    , KW_type    )+  , ("where"   , KW_where   )+  ]++-- |Map of keywords and special identifiers+keywordsSpecialIds :: Map.Map String Category+keywordsSpecialIds = Map.union keywords $ Map.fromList+  [ ("as"       , Id_as       )+  , ("ccall"    , Id_ccall    )+  , ("forall"   , Id_forall   )+  , ("hiding"   , Id_hiding   )+  , ("interface", Id_interface)+  , ("primitive", Id_primitive)+  , ("qualified", Id_qualified)+  ]++pragmas :: Map.Map String Category+pragmas = Map.fromList+  [ ("language", PragmaLanguage)+  , ("options" , PragmaOptions )+  , ("hiding"  , PragmaHiding  )+  , ("method"  , PragmaMethod  )+  , ("module"  , PragmaModule  )+  ]+++-- ---------------------------------------------------------------------------+-- Character classes+-- ---------------------------------------------------------------------------++-- |Check whether a 'Char' is allowed for identifiers+isIdentChar :: Char -> Bool+isIdentChar c = isAlphaNum c || c `elem` "'_"++-- |Check whether a 'Char' is allowed for symbols+isSymbolChar :: Char -> Bool+isSymbolChar c = c `elem` "~!@#$%^&*+-=<>:?./|\\"++-- ---------------------------------------------------------------------------+-- Lexing functions+-- ---------------------------------------------------------------------------++-- |Lex source code+lexSource :: FilePath -> String -> CYM [(Span, Token)]+lexSource = parse (applyLexer fullLexer)++-- |CPS-Lexer for Curry+lexer :: Lexer Token a+lexer = skipWhiteSpace True -- skip comments++-- |CPS-Lexer for Curry which also lexes comments.+-- This lexer is useful for documentation tools.+fullLexer :: Lexer Token a+fullLexer = skipWhiteSpace False -- lex comments++-- |Lex the source code and skip whitespaces+skipWhiteSpace :: Bool -> Lexer Token a+skipWhiteSpace skipComments suc fail = skip+  where+  skip sp   []              bol = suc sp (tok EOF)                   sp            [] bol+  skip sp c@('-':'-':_)     _   = lexLineComment     sucComment fail sp            c  True+  skip sp c@('{':'-':'#':_) bol = lexPragma noPragma suc        fail sp            c  bol+  skip sp c@('{':'-':_)     bol = lexNestedComment   sucComment fail sp            c  bol+  skip sp cs@(c:s)          bol+    | c == '\t'                = warnP sp "Tab character" skip       (tabSpan  sp) s  bol+    | c == '\n'                = skip                                (nlSpan   sp) s  True+    | isSpace c                = skip                                (nextSpan sp) s  bol+    | bol                      = lexBOL             suc        fail  sp            cs bol+    | otherwise                = lexToken           suc        fail  sp            cs bol+  sucComment = if skipComments then (\ _suc _fail -> skip) else suc+  noPragma   = lexNestedComment sucComment fail++-- Lex a line comment+lexLineComment :: Lexer Token a+lexLineComment suc _ sp str = case break (== '\n') str of+  (c, s ) -> suc sp (lineCommentTok c) (incrSpan sp $ length c) s++lexPragma :: P a -> Lexer Token a+lexPragma noPragma suc fail sp0 str = pragma (incrSpan sp0 3) (drop 3 str)+  where+  skip = noPragma sp0 str+  pragma sp []         = fail sp0 "Unterminated pragma" sp []+  pragma sp cs@(c : s)+    | c == '\t' = pragma (tabSpan  sp) s+    | c == '\n' = pragma (nlSpan   sp) s+    | isSpace c = pragma (nextSpan sp) s+    | isAlpha c = case Map.lookup (map toLower prag) pragmas of+        Nothing            -> skip+        Just PragmaOptions -> lexOptionsPragma sp0 suc fail sp1 rest+        Just t             -> suc sp0 (tok t)               sp1 rest+    | otherwise = skip+    where+    (prag, rest) = span isAlphaNum cs+    sp1          = incrSpan sp (length prag)++lexOptionsPragma :: Span -> Lexer Token a+lexOptionsPragma sp0 _   fail sp [] = fail sp0 "Unterminated Options pragma" sp []+lexOptionsPragma sp0 suc fail sp (c : s)+  | c == '\t' = lexArgs Nothing (tabSpan  sp) s+  | c == '\n' = lexArgs Nothing (nlSpan   sp) s+  | isSpace c = lexArgs Nothing (nextSpan sp) s+  | c == '_'  = let (tool, s1) = span isIdentChar s+                in  lexArgs (Just tool) (incrSpan sp (length tool + 1)) s1+  | otherwise = fail sp0 "Malformed Options pragma" sp s+  where+  lexArgs mbTool = lexRaw ""+    where+    lexRaw s0 sp1 r = case hash of+      []            -> fail sp0 "End-of-file inside pragma" (incrSpan sp1 len) []+      '#':'-':'}':_ -> token  (trim $ s0 ++ opts) (incrSpan sp1 len)       hash+      _             -> lexRaw (s0 ++ opts ++ "#") (incrSpan sp1 (len + 1)) (drop 1 hash)+      where+      (opts, hash) = span (/= '#') r+      len = length opts+      token = suc sp0 . pragmaOptionsTok mbTool+      trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace++-- Lex a nested comment+lexNestedComment :: Lexer Token a+lexNestedComment suc fail sp0 = lnc (0 :: Integer) id sp0+  where+  -- d   : nesting depth+  -- comm: comment already lexed as functional list+  lnc d comm sp str = case (d, str) of+    (_,        []) -> fail sp0    "Unterminated nested comment"  sp          []+    (1, '-':'}':s) -> suc  sp0    (nestedCommentTok (comm "-}")) (incrSpan sp 2) s+    (_, '{':'-':s) -> cont (d+1) ("{-" ++)                       (incrSpan sp 2) s+    (_, '-':'}':s) -> cont (d-1) ("-}" ++)                       (incrSpan sp 2) s+    (_, c@'\t' :s) -> cont d     (c:)                            (tabSpan    sp) s+    (_, c@'\n' :s) -> cont d     (c:)                            (nlSpan     sp) s+    (_, c      :s) -> cont d     (c:)                            (nextSpan   sp) s+    where cont d' comm' = lnc d' (comm . comm')++-- Lex tokens at the beginning of a line, managing layout.+lexBOL :: Lexer Token a+lexBOL suc fail sp s _ []            = lexToken suc fail sp s False []+lexBOL suc fail sp s _ ctxt@(n:rest)+  | col <  n  = suc sp (tok VRightBrace) sp s True  rest+  | col == n  = lexSemiOrWhere suc fail  sp s False ctxt+  | otherwise = lexToken       suc fail  sp s False ctxt+  where col = column (span2Pos sp)++lexSemiOrWhere :: Lexer Token a+lexSemiOrWhere suc _ sp ('w':'h':'e':'r':'e':s@(c:_))+  | not (isIdentChar c)   = suc sp (tok KW_where)   sp s+lexSemiOrWhere suc _ sp s = suc sp (tok VSemicolon) sp s++-- Lex a single 'Token'+lexToken :: Lexer Token a+lexToken suc _    sp []       = suc sp (tok EOF) sp []+lexToken suc fail sp cs@(c:s)+  | take 3 cs == "#-}" = suc sp (tok PragmaEnd) (incrSpan sp 3) (drop 3 cs)+  | c == '('           = token LeftParen+  | c == ')'           = token RightParen+  | c == ','           = token Comma+  | c == ';'           = token Semicolon+  | c == '['           = token LeftBracket+  | c == ']'           = token RightBracket+  | c == '_'           = token Underscore+  | c == '`'           = token Backquote+  | c == '{'           = token LeftBrace+  | c == '}'           = lexRightBrace (suc sp) (nextSpan sp) s+  | c == '\''          = lexChar   sp suc fail  (nextSpan sp) s+  | c == '\"'          = lexString sp suc fail  (nextSpan sp) s+  | isAlpha      c     = lexIdent      (suc sp) sp            cs+  | isSymbolChar c     = lexSymbol     (suc sp) sp            cs+  | isDigit      c     = lexNumber     (suc sp) sp            cs+  | otherwise          = fail sp ("Illegal character " ++ show c) sp s+  where token t = suc sp (tok t) (nextSpan sp) s++-- Lex a right brace and pop from the context stack+lexRightBrace :: (Token -> P a) -> P a+lexRightBrace cont sp s bol ctxt = cont (tok RightBrace) sp s bol (drop 1 ctxt)++-- Lex an identifier+lexIdent :: (Token -> P a) -> P a+lexIdent cont sp s = maybe (lexOptQual cont (token Id) [ident]) (cont . token)+                          (Map.lookup ident keywordsSpecialIds)+                          (incrSpan sp $ length ident) rest+  where (ident, rest) = span isIdentChar s+        token t       = idTok t [] ident++-- Lex a symbol+lexSymbol :: (Token -> P a) -> P a+lexSymbol cont sp s = cont+  (idTok (Map.findWithDefault Sym sym reservedSpecialOps) [] sym)+  (incrSpan sp $ length sym) rest+  where (sym, rest) = span isSymbolChar s++-- Lex an optionally qualified entity (identifier or symbol).+lexOptQual :: (Token -> P a) -> Token -> [String] -> P a+lexOptQual cont token mIdent sp cs@('.':c:s)+  | isAlpha  c                 = lexQualIdent cont identCont mIdent+                                   (nextSpan sp) (c:s)+  | isSymbolChar c && c /= '.' = lexQualSymbol cont identCont mIdent+                                   (nextSpan sp) (c:s)+--   | c `elem` ":[("   = lexQualPrimitive cont token     mIdent (nextSpan sp) (c:s)+  where identCont _ _ = cont token sp cs+lexOptQual cont token mIdent sp cs@('.':'.':c:s)+  |       isSymbolChar c =       lexQualSymbol cont identCont mIdent+                                   (nextSpan sp) ('.':c:s)+  | not $ isIdentChar  c =       lexQualSymbol cont identCont mIdent+                                   (nextSpan sp) ('.':c:s)+  where identCont _ _ = cont token sp cs+lexOptQual cont token _      sp cs = cont token sp cs++-- Lex a qualified identifier.+lexQualIdent :: (Token -> P a) -> P a -> [String] -> P a+lexQualIdent cont identCont mIdent sp s =+  maybe (lexOptQual cont (idTok QId mIdent ident) (mIdent ++ [ident]))+        (const identCont)+        (Map.lookup ident keywords)+        (incrSpan sp (length ident)) rest+  where (ident, rest) = span isIdentChar s++-- Lex a qualified symbol.+lexQualSymbol :: (Token -> P a) -> P a -> [String] -> P a+lexQualSymbol cont identCont mIdent sp s =+  maybe (cont (idTok QSym mIdent sym)) (const identCont)+        (Map.lookup sym reservedOps)+        (incrSpan sp (length sym)) rest+  where (sym, rest) = span isSymbolChar s++-- ---------------------------------------------------------------------------+-- /Note:/ since Curry allows an unlimited range of integer numbers,+-- read numbers must be converted to Haskell type 'Integer'.+-- ---------------------------------------------------------------------------++-- Lex a numeric literal.+lexNumber :: (Token -> P a) -> P a+lexNumber cont sp ('0':c:s)+  | c `elem` "bB"  = lexBinary      cont nullCont (incrSpan sp 2) s+  | c `elem` "oO"  = lexOctal       cont nullCont (incrSpan sp 2) s+  | c `elem` "xX"  = lexHexadecimal cont nullCont (incrSpan sp 2) s+  where nullCont _ _ = cont (intTok 10 "0") (nextSpan sp) (c:s)+lexNumber cont sp s = lexOptFraction cont (intTok 10 digits) digits+                     (incrSpan sp $ length digits) rest+  where (digits, rest) = span isDigit s++-- Lex a binary literal.+lexBinary :: (Token -> P a) -> P a -> P a+lexBinary cont nullCont sp s+  | null digits = nullCont undefined undefined+  | otherwise   = cont (intTok 2 digits) (incrSpan sp $ length digits) rest+  where (digits, rest) = span isBinDigit s+        isBinDigit c   = c >= '0' && c <= '1'++-- Lex an octal literal.+lexOctal :: (Token -> P a) -> P a -> P a+lexOctal cont nullCont sp s+  | null digits = nullCont undefined undefined+  | otherwise   = cont (intTok 8 digits) (incrSpan sp $ length digits) rest+  where (digits, rest) = span isOctDigit s++-- Lex a hexadecimal literal.+lexHexadecimal :: (Token -> P a) -> P a -> P a+lexHexadecimal cont nullCont sp s+  | null digits = nullCont undefined undefined+  | otherwise   = cont (intTok 16 digits) (incrSpan sp $ length digits) rest+  where (digits, rest) = span isHexDigit s++-- Lex an optional fractional part (float literal).+lexOptFraction :: (Token -> P a) -> Token -> String -> P a+lexOptFraction cont _ mant sp ('.':c:s)+  | isDigit c = lexOptExponent cont (floatTok mant frac 0 "") mant frac+                               (incrSpan sp (length frac+1)) rest+  where (frac,rest) = span isDigit (c:s)+lexOptFraction cont token mant sp (c:s)+  | c `elem` "eE" = lexSignedExponent cont intCont mant "" [c] (nextSpan sp) s+  where intCont _ _ = cont token sp (c:s)+lexOptFraction cont token _ sp s = cont token sp s++-- Lex an optional exponent (float literal).+lexOptExponent :: (Token -> P a) -> Token -> String -> String -> P a+lexOptExponent cont token mant frac sp (c:s)+  | c `elem` "eE" = lexSignedExponent cont floatCont mant frac [c] (nextSpan sp) s+  where floatCont _ _ = cont token sp (c:s)+lexOptExponent cont token _    _    sp s = cont token sp s++-- Lex an exponent with sign (float literal).+lexSignedExponent :: (Token -> P a) -> P a -> String -> String -> String+                  -> P a+lexSignedExponent cont floatCont mant frac e sp str = case str of+  ('+':c:s) | isDigit c -> lexExpo (e ++ "+") id     (nextSpan sp) (c:s)+  ('-':c:s) | isDigit c -> lexExpo (e ++ "-") negate (nextSpan sp) (c:s)+  (c:_)     | isDigit c -> lexExpo e          id     sp            str+  _                     -> floatCont                 sp            str+  where lexExpo = lexExponent cont mant frac++-- Lex an exponent without sign (float literal).+lexExponent :: (Token -> P a) -> String -> String -> String -> (Int -> Int)+            -> P a+lexExponent cont mant frac e expSign sp s =+  cont (floatTok mant frac expo (e ++ digits)) (incrSpan sp $ length digits) rest+  where (digits, rest) = span isDigit s+        expo           = expSign (convertIntegral 10 digits)++-- Lex a character literal.+lexChar :: Span -> Lexer Token a+lexChar sp0 _       fail sp []    = fail sp0 "Illegal character constant" sp []+lexChar sp0 success fail sp (c:s)+  | c == '\\' = lexEscape sp (\d o -> lexCharEnd d o sp0 success fail)+                          fail (nextSpan sp) s+  | c == '\n' = fail sp0 "Illegal character constant" sp (c:s)+  | c == '\t' = lexCharEnd c "\t" sp0 success fail (tabSpan  sp) s+  | otherwise = lexCharEnd c [c]  sp0 success fail (nextSpan sp) s++-- Lex the end of a character literal.+lexCharEnd :: Char -> String -> Span -> Lexer Token a+lexCharEnd c o sp0 suc _    sp ('\'':s) = suc sp0 (charTok c o) (nextSpan sp) s+lexCharEnd _ _ sp0 _   fail sp s        =+  fail sp0 "Improperly terminated character constant" sp s++-- Lex a String literal.+lexString :: Span -> Lexer Token a+lexString sp0 suc fail = lexStringRest "" id+  where+  lexStringRest _  _  sp []    = improperTermination sp+  lexStringRest s0 so sp (c:s)+    | c == '\n' = improperTermination sp+    | c == '\"' = suc sp0 (stringTok (reverse s0) (so "")) (nextSpan sp) s+    | c == '\\' = lexStringEscape sp s0 so lexStringRest fail (nextSpan sp) s+    | c == '\t' = lexStringRest (c:s0) (so . (c:)) (tabSpan  sp) s+    | otherwise = lexStringRest (c:s0) (so . (c:)) (nextSpan sp) s+  improperTermination sp = fail sp0 "Improperly terminated string constant" sp []++-- Lex an escaped character inside a string.+lexStringEscape ::  Span -> String -> (String -> String)+                -> (String -> (String -> String) -> P a)+                -> FailP a -> P a+lexStringEscape sp0 _  _  _   fail sp []      = lexEscape sp0 undefined fail sp []+lexStringEscape sp0 s0 so suc fail sp cs@(c:s)+    -- The escape sequence represents an empty character of length zero+  | c == '&'  = suc s0 (so . ("\\&" ++)) (nextSpan sp) s+  | isSpace c = lexStringGap so (suc s0) fail sp cs+  | otherwise = lexEscape sp0 (\ c' s' -> suc (c': s0) (so . (s' ++))) fail sp cs++-- Lex a string gap.+lexStringGap :: (String -> String) -> ((String -> String) -> P a)+             -> FailP a -> P a+lexStringGap _  _   fail sp []    = fail sp "End-of-file in string gap" sp []+lexStringGap so suc fail sp (c:s)+  | c == '\\' = suc          (so . (c:))          (nextSpan sp) s+  | c == '\t' = lexStringGap (so . (c:)) suc fail (tabSpan  sp) s+  | c == '\n' = lexStringGap (so . (c:)) suc fail (nlSpan   sp) s+  | isSpace c = lexStringGap (so . (c:)) suc fail (nextSpan sp) s+  | otherwise = fail sp ("Illegal character in string gap: " ++ show c) sp s++-- Lex an escaped character.+lexEscape :: Span -> (Char -> String -> P a) -> FailP a -> P a+lexEscape sp0 suc fail sp str = case str of+  -- character escape+  ('a' :s) -> suc '\a' "\\a"  (nextSpan sp) s+  ('b' :s) -> suc '\b' "\\b"  (nextSpan sp) s+  ('f' :s) -> suc '\f' "\\f"  (nextSpan sp) s+  ('n' :s) -> suc '\n' "\\n"  (nextSpan sp) s+  ('r' :s) -> suc '\r' "\\r"  (nextSpan sp) s+  ('t' :s) -> suc '\t' "\\t"  (nextSpan sp) s+  ('v' :s) -> suc '\v' "\\v"  (nextSpan sp) s+  ('\\':s) -> suc '\\' "\\\\" (nextSpan sp) s+  ('"' :s) -> suc '\"' "\\\"" (nextSpan sp) s+  ('\'':s) -> suc '\'' "\\\'" (nextSpan sp) s+  -- control characters+  ('^':c:s) | isControlEsc c -> controlEsc c (incrSpan sp 2) s+  -- numeric escape+  ('o':c:s) | isOctDigit c   -> numEsc  8 isOctDigit ("\\o" ++) (nextSpan sp) (c:s)+  ('x':c:s) | isHexDigit c   -> numEsc 16 isHexDigit ("\\x" ++) (nextSpan sp) (c:s)+  (c:s)     | isDigit    c   -> numEsc 10 isDigit    ("\\"  ++) sp            (c:s)+  -- ascii escape+  _        -> asciiEscape sp0 suc fail sp str+  where numEsc         = numEscape sp0 suc fail+        controlEsc   c = suc (chr (ord c `mod` 32)) ("\\^" ++ [c])+        isControlEsc c = isUpper c || c `elem` "@[\\]^_"++numEscape :: Span -> (Char -> String -> P a) -> FailP a -> Int+          -> (Char -> Bool) -> (String -> String) -> P a+numEscape sp0 suc fail b isDigit' so sp s+  | n >= ord minBound && n <= ord maxBound+   = suc (chr n) (so digits) (incrSpan sp $ length digits) rest+  | otherwise+  = fail sp0 "Numeric escape out-of-range" sp s+  where (digits, rest) = span isDigit' s+        n = convertIntegral b digits++asciiEscape :: Span -> (Char -> String -> P a) -> FailP a -> P a+asciiEscape sp0 suc fail sp str = case str of+  ('N':'U':'L':s) -> suc '\NUL' "\\NUL" (incrSpan sp 3) s+  ('S':'O':'H':s) -> suc '\SOH' "\\SOH" (incrSpan sp 3) s+  ('S':'T':'X':s) -> suc '\STX' "\\STX" (incrSpan sp 3) s+  ('E':'T':'X':s) -> suc '\ETX' "\\ETX" (incrSpan sp 3) s+  ('E':'O':'T':s) -> suc '\EOT' "\\EOT" (incrSpan sp 3) s+  ('E':'N':'Q':s) -> suc '\ENQ' "\\ENQ" (incrSpan sp 3) s+  ('A':'C':'K':s) -> suc '\ACK' "\\ACK" (incrSpan sp 3) s+  ('B':'E':'L':s) -> suc '\BEL' "\\BEL" (incrSpan sp 3) s+  ('B':'S'    :s) -> suc '\BS'  "\\BS"  (incrSpan sp 2) s+  ('H':'T'    :s) -> suc '\HT'  "\\HT"  (incrSpan sp 2) s+  ('L':'F'    :s) -> suc '\LF'  "\\LF"  (incrSpan sp 2) s+  ('V':'T'    :s) -> suc '\VT'  "\\VT"  (incrSpan sp 2) s+  ('F':'F'    :s) -> suc '\FF'  "\\FF"  (incrSpan sp 2) s+  ('C':'R'    :s) -> suc '\CR'  "\\CR"  (incrSpan sp 2) s+  ('S':'O'    :s) -> suc '\SO'  "\\SO"  (incrSpan sp 2) s+  ('S':'I'    :s) -> suc '\SI'  "\\SI"  (incrSpan sp 2) s+  ('D':'L':'E':s) -> suc '\DLE' "\\DLE" (incrSpan sp 3) s+  ('D':'C':'1':s) -> suc '\DC1' "\\DC1" (incrSpan sp 3) s+  ('D':'C':'2':s) -> suc '\DC2' "\\DC2" (incrSpan sp 3) s+  ('D':'C':'3':s) -> suc '\DC3' "\\DC3" (incrSpan sp 3) s+  ('D':'C':'4':s) -> suc '\DC4' "\\DC4" (incrSpan sp 3) s+  ('N':'A':'K':s) -> suc '\NAK' "\\NAK" (incrSpan sp 3) s+  ('S':'Y':'N':s) -> suc '\SYN' "\\SYN" (incrSpan sp 3) s+  ('E':'T':'B':s) -> suc '\ETB' "\\ETB" (incrSpan sp 3) s+  ('C':'A':'N':s) -> suc '\CAN' "\\CAN" (incrSpan sp 3) s+  ('E':'M'    :s) -> suc '\EM'  "\\EM"  (incrSpan sp 2) s+  ('S':'U':'B':s) -> suc '\SUB' "\\SUB" (incrSpan sp 3) s+  ('E':'S':'C':s) -> suc '\ESC' "\\ESC" (incrSpan sp 3) s+  ('F':'S'    :s) -> suc '\FS'  "\\FS"  (incrSpan sp 2) s+  ('G':'S'    :s) -> suc '\GS'  "\\GS"  (incrSpan sp 2) s+  ('R':'S'    :s) -> suc '\RS'  "\\RS"  (incrSpan sp 2) s+  ('U':'S'    :s) -> suc '\US'  "\\US"  (incrSpan sp 2) s+  ('S':'P'    :s) -> suc '\SP'  "\\SP"  (incrSpan sp 2) s+  ('D':'E':'L':s) -> suc '\DEL' "\\DEL" (incrSpan sp 3) s+  s               -> fail sp0 "Illegal escape sequence" sp s
− src/Curry/Syntax/Lexer.lhs 
@@ -1,630 +0,0 @@--% $Id: CurryLexer.lhs,v 1.40 2004/03/04 22:39:12 wlux Exp $-%-% Copyright (c) 1999-2004, Wolfgang Lux-% See LICENSE for the full license.-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-%-\nwfilename{CurryLexer.lhs}-\section{A Lexer for Curry}-In this section a lexer for Curry is implemented.-\begin{verbatim}- -> module Curry.Syntax.Lexer (lexFile,lexer, Token (..), Category(..), Attributes(..)) where--> import Data.Char -> import Data.List-> import qualified Data.Map as Map--> import Curry.Syntax.LexComb-> import Curry.Base.Position----\end{verbatim}-\paragraph{Tokens} Note that the equality and ordering instances of-\texttt{Token} disregard the attributes.-\begin{verbatim}--> data Token = Token Category Attributes--> instance Eq Token where->   Token t1 _ == Token t2 _ = t1 == t2-> instance Ord Token where->   Token t1 _ `compare` Token t2 _ = t1 `compare` t2--> data Category =->   -- literals->     CharTok | IntTok | FloatTok | IntegerTok | StringTok->   -- identifiers->   | Id | QId | Sym | QSym->   -- punctuation symbols->   | LeftParen | RightParen | Semicolon | LeftBrace | RightBrace->   | LeftBracket | RightBracket | Comma | Underscore | Backquote->   -- turn off layout (inserted by bbr)->   | LeftBraceSemicolon->   -- virtual punctation (inserted by layout)->   | VSemicolon | VRightBrace->   -- reserved identifiers->   | KW_case | KW_choice | KW_data | KW_do | KW_else | KW_eval | KW_external->   | KW_free | KW_if | KW_import | KW_in | KW_infix | KW_infixl | KW_infixr->   | KW_let | KW_module | KW_newtype | KW_of | KW_rigid | KW_then | KW_type->   | KW_where->   -- reserved operators->   | At | Colon | DotDot | DoubleColon | Equals | Backslash | Bar->   | LeftArrow | RightArrow | Tilde | Binds->   -- special identifiers->   | Id_as | Id_ccall | Id_forall | Id_hiding | Id_interface | Id_primitive->   | Id_qualified->   -- special operators->   | Sym_Dot | Sym_Minus | Sym_MinusDot->   -- end-of-file token->   | EOF->   -- comments (only for full lexer) inserted by men & bbr->   | LineComment | NestedComment ->   deriving (Eq,Ord)--\end{verbatim}-There are different kinds of attributes associated with the tokens.-Most attributes simply save the string corresponding to the token.-However, for qualified identifiers, we also record the list of module-qualifiers. The values corresponding to a literal token are properly-converted already. To simplify the creation and extraction of-attribute values we make use of records.-\begin{verbatim}--> data Attributes =->     NoAttributes->   | CharAttributes{ cval :: Char, original :: String}->   | IntAttributes{ ival :: Int , original :: String}->   | FloatAttributes{ fval :: Double, original :: String}->   | IntegerAttributes{ intval :: Integer, original :: String}->   | StringAttributes{ sval :: String, original :: String}->   | IdentAttributes{ modul :: [String], sval :: String}--> instance Show Attributes where->   showsPrec _ NoAttributes = showChar '_'->   showsPrec _ (CharAttributes cval _) = shows cval->   showsPrec _ (IntAttributes ival _) = shows ival->   showsPrec _ (FloatAttributes fval _) = shows fval->   showsPrec _ (IntegerAttributes intval _) = shows intval->   showsPrec _ (StringAttributes sval _) = shows sval->   showsPrec _ (IdentAttributes mIdent ident) =->     showString ("`" ++ concat (intersperse "." (mIdent ++ [ident])) ++ "'")--\end{verbatim}-The following functions can be used to construct tokens with-specific attributes.-\begin{verbatim}--> tok :: Category -> Token-> tok t = Token t NoAttributes--> idTok :: Category -> [String] -> String -> Token-> idTok t mIdent ident = Token t IdentAttributes{ modul = mIdent, sval = ident }--> charTok :: Char -> String -> Token-> charTok c o = Token CharTok CharAttributes{ cval = c, original = o }--> intTok :: Int -> String -> Token-> intTok base digits =->   Token IntTok IntAttributes{ ival = convertIntegral base digits,->                               original = digits}--> floatTok :: String -> String -> Int -> String -> Token-> floatTok mant frac exp rest =->   Token FloatTok FloatAttributes{ fval = convertFloating mant frac exp, ->                                   original = mant++"."++frac++rest}- -> integerTok :: Integer -> String -> Token-> integerTok base digits =->   Token IntegerTok->         IntegerAttributes{intval = (convertIntegral base digits) :: Integer,->                           original = digits}--> stringTok :: String -> String -> Token-> stringTok cs o = Token StringTok StringAttributes{ sval = cs, original = o }--> lineCommentTok :: String -> Token-> lineCommentTok s = Token LineComment StringAttributes{ sval = s, original = s}--> nestedCommentTok :: String -> Token-> nestedCommentTok s = Token NestedComment StringAttributes{ sval = s, original = s }--\end{verbatim}-The \texttt{Show} instance of \texttt{Token} is designed to display-all tokens in their source representation.-\begin{verbatim}--> instance Show Token where->   showsPrec _ (Token Id a) = showString "identifier " . shows a->   showsPrec _ (Token QId a) = showString "qualified identifier " . shows a->   showsPrec _ (Token Sym a) = showString "operator " . shows a->   showsPrec _ (Token QSym a) = showString "qualified operator " . shows a->   showsPrec _ (Token IntTok a) = showString "integer " . shows a->   showsPrec _ (Token FloatTok a) = showString "float " . shows a->   showsPrec _ (Token CharTok a) = showString "character " . shows a->   showsPrec _ (Token IntegerTok a) = showString "integer " . shows a->   showsPrec _ (Token StringTok a) = showString "string " . shows a->   showsPrec _ (Token LeftParen _) = showString "`('"->   showsPrec _ (Token RightParen _) = showString "`)'"->   showsPrec _ (Token Semicolon _) = showString "`;'"->   showsPrec _ (Token LeftBrace _) = showString "`{'"->   showsPrec _ (Token RightBrace _) = showString "`}'"->   showsPrec _ (Token LeftBracket _) = showString "`['"->   showsPrec _ (Token RightBracket _) = showString "`]'"->   showsPrec _ (Token Comma _) = showString "`,'"->   showsPrec _ (Token Underscore _) = showString "`_'"->   showsPrec _ (Token Backquote _) = showString "``'"->   showsPrec _ (Token VSemicolon _) =->     showString "`;' (inserted due to layout)"->   showsPrec _ (Token VRightBrace _) =->     showString "`}' (inserted due to layout)"->   showsPrec _ (Token At _) = showString "`@'"->   showsPrec _ (Token Colon _) = showString "`:'"->   showsPrec _ (Token DotDot _) = showString "`..'"->   showsPrec _ (Token DoubleColon _) = showString "`::'"->   showsPrec _ (Token Equals _) = showString "`='"->   showsPrec _ (Token Backslash _) = showString "`\\'"->   showsPrec _ (Token Bar _) = showString "`|'"->   showsPrec _ (Token LeftArrow _) = showString "`<-'"->   showsPrec _ (Token RightArrow _) = showString "`->'"->   showsPrec _ (Token Tilde _) = showString "`~'"->   showsPrec _ (Token Binds _) = showString "`:='"->   showsPrec _ (Token Sym_Dot _) = showString "operator `.'"->   showsPrec _ (Token Sym_Minus _) = showString "operator `-'"->   showsPrec _ (Token Sym_MinusDot _) = showString "operator `-.'"->   showsPrec _ (Token KW_case _) = showString "`case'"->   showsPrec _ (Token KW_choice _) = showString "`choice'"->   showsPrec _ (Token KW_data _) = showString "`data'"->   showsPrec _ (Token KW_do _) = showString "`do'"->   showsPrec _ (Token KW_else _) = showString "`else'"->   showsPrec _ (Token KW_eval _) = showString "`eval'"->   showsPrec _ (Token KW_external _) = showString "`external'"->   showsPrec _ (Token KW_free _) = showString "`free'"->   showsPrec _ (Token KW_if _) = showString "`if'"->   showsPrec _ (Token KW_import _) = showString "`import'"->   showsPrec _ (Token KW_in _) = showString "`in'"->   showsPrec _ (Token KW_infix _) = showString "`infix'"->   showsPrec _ (Token KW_infixl _) = showString "`infixl'"->   showsPrec _ (Token KW_infixr _) = showString "`infixr'"->   showsPrec _ (Token KW_let _) = showString "`let'"->   showsPrec _ (Token KW_module _) = showString "`module'"->   showsPrec _ (Token KW_newtype _) = showString "`newtype'"->   showsPrec _ (Token KW_of _) = showString "`of'"->   showsPrec _ (Token KW_rigid _) = showString "`rigid'"->   showsPrec _ (Token KW_then _) = showString "`then'"->   showsPrec _ (Token KW_type _) = showString "`type'"->   showsPrec _ (Token KW_where _) = showString "`where'"->   showsPrec _ (Token Id_as _) = showString "identifier `as'"->   showsPrec _ (Token Id_ccall _) = showString "identifier `ccall'"->   showsPrec _ (Token Id_forall _) = showString "identifier `forall'"->   showsPrec _ (Token Id_hiding _) = showString "identifier `hiding'"->   showsPrec _ (Token Id_interface _) = showString "identifier `interface'"->   showsPrec _ (Token Id_primitive _) = showString "identifier `primitive'"->   showsPrec _ (Token Id_qualified _) = showString "identifier `qualified'"->   showsPrec _ (Token EOF _) = showString "<end-of-file>"->   showsPrec _ (Token LineComment a) = shows a->   showsPrec _ (Token NestedComment a) = shows a--\end{verbatim}-Tables for reserved operators and identifiers-\begin{verbatim}--> reserved_ops, reserved_and_special_ops :: Map.Map String Category-> reserved_ops = Map.fromList [->     ("@",  At),->     ("::", DoubleColon),->     ("..", DotDot),->     ("=",  Equals),->     ("\\", Backslash),->     ("|",  Bar),->     ("<-", LeftArrow),->     ("->", RightArrow),->     ("~",  Tilde),->     (":=", Binds)->   ]-> reserved_and_special_ops = foldr (uncurry Map.insert) reserved_ops [->     (":",  Colon),->     (".",  Sym_Dot),->     ("-",  Sym_Minus),->     ("-.", Sym_MinusDot)->   ]--> reserved_ids, reserved_and_special_ids :: Map.Map String Category-> reserved_ids = Map.fromList [->     ("case",     KW_case),->     ("choice",   KW_choice),->     ("data",     KW_data),->     ("do",       KW_do),->     ("else",     KW_else),->     ("eval",     KW_eval),->     ("external", KW_external),->     ("free",     KW_free),->     ("if",       KW_if),->     ("import",   KW_import),->     ("in",       KW_in),->     ("infix",    KW_infix),->     ("infixl",   KW_infixl),->     ("infixr",   KW_infixr),->     ("let",      KW_let),->     ("module",   KW_module),->     ("newtype",  KW_newtype),->     ("of",       KW_of),->     ("rigid",    KW_rigid),->     ("then",     KW_then),->     ("type",     KW_type),->     ("where",    KW_where)->   ]-> reserved_and_special_ids = foldr (uncurry Map.insert) reserved_ids [->     ("as",        Id_as),->     ("ccall",     Id_ccall),->     ("forall",    Id_forall),->     ("hiding",    Id_hiding),->     ("interface", Id_interface),->     ("primitive", Id_primitive),->     ("qualified", Id_qualified)->   ]--\end{verbatim}-Character classes-\begin{verbatim}--> isIdent, isSym, isOctit, isHexit :: Char -> Bool-> isIdent c = isAlphaNum c || c `elem` "'_"-> isSym c = c `elem` "~!@#$%^&*+-=<>:?./|\\"-> isOctit c = c >= '0' && c <= '7'-> isHexit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f'--inserted for full lexing (men&bbr)--> isLineComment, isNestedComment :: String -> Bool-> isLineComment ('-':'-':_) = True-> isLineComment _ = False-> isNestedComment ('{':'-':s) = True-> isNestedComment _ = False---\end{verbatim}-Lexing functions-\begin{verbatim}--> type SuccessP a = Position -> Token -> P a-> type FailP a = Position -> String -> P a--> lexFile :: P [(Position,Token)]-> lexFile = fullLexer tokens failP->   where tokens p t@(Token c _)->           | c == EOF = returnP [(p,t)]->           | otherwise = lexFile `thenP` returnP . ((p,t):)--> lexer :: SuccessP a -> FailP a -> P a-> lexer success fail = skipBlanks->   where -- skipBlanks moves past whitespace and comments->         skipBlanks p [] bol = success p (tok EOF) p [] bol->         skipBlanks p ('\t':s) bol = skipBlanks (tab p) s bol->         skipBlanks p ('\n':s) bol = skipBlanks (nl p) s True->         skipBlanks p ('-':'-':s) bol =->           skipBlanks (nl p) (tail' (dropWhile (/= '\n') s)) True->         skipBlanks p ('{':'-':s) bol =->           nestedComment p skipBlanks fail (incr p 2) s bol->         skipBlanks p (c:s) bol->           | isSpace c = skipBlanks (next p) s bol->           | otherwise =->               (if bol then lexBOL else lexToken) success fail p (c:s) bol->         tail' [] = []->         tail' (_:tl) = tl--> fullLexer :: SuccessP a -> FailP a -> P a-> fullLexer success fail = skipBlanks->   where -- skipBlanks moves past whitespace ->         skipBlanks p [] bol = success p (tok EOF) p [] bol->         skipBlanks p ('\t':s) bol = skipBlanks (tab p) s bol->         skipBlanks p ('\n':s) bol = skipBlanks (nl p) s True->         skipBlanks p s@('-':'-':_) bol = lexLineComment success p s bol->         skipBlanks p s@('{':'-':_) bol =->           lexNestedComment 0 id p success fail p s bol->         skipBlanks p (c:s) bol->           | isSpace c = skipBlanks (next p) s bol->           | otherwise =->               (if bol then lexBOL else lexToken) success fail p (c:s) bol->         tail' [] = []->         tail' (_:tl) = tl--> lexLineComment :: SuccessP a -> P a-> lexLineComment success p s = case break (=='\n') s of->   (comment,rest) -> success p (lineCommentTok comment) (incr p (length comment)) rest- -> lexNestedComment :: Int -> (String -> String) -> ->                     Position -> SuccessP a -> FailP a -> P a-> lexNestedComment 1 comment p0 success fail p ('-':'}':s) = ->   success p0 (nestedCommentTok (comment "-}") ) (incr p 2) s -> lexNestedComment n comment p0 success fail p ('{':'-':s) = ->   lexNestedComment (n+1) (comment . ("{-"++)) p0 success fail (incr p 2) s-> lexNestedComment n comment p0 success fail p ('-':'}':s) = ->   lexNestedComment (n-1) (comment . ("-}"++)) p0 success fail (incr p 2) s-> lexNestedComment n comment p0 success fail p (c@'\t':s) = ->   lexNestedComment n (comment . (c:)) p0 success fail (tab p) s-> lexNestedComment n comment p0 success fail p (c@'\n':s) = ->   lexNestedComment n (comment . (c:)) p0 success fail (nl p) s-> lexNestedComment n comment p0 success fail p (c:s) = ->   lexNestedComment n (comment . (c:)) p0 success fail (next p) s-> lexNestedComment n comment p0 success fail p "" = ->   fail p0 "Unterminated nested comment" p []--> nestedComment :: Position -> P a -> FailP a -> P a-> nestedComment p0 success fail p ('-':'}':s) = success (incr p 2) s-> nestedComment p0 success fail p ('{':'-':s) =->   nestedComment p (nestedComment p0 success fail) fail (incr p 2) s-> nestedComment p0 success fail p ('\t':s) =->   nestedComment p0 success fail (tab p) s-> nestedComment p0 success fail p ('\n':s) =->   nestedComment p0 success fail (nl p) s-> nestedComment p0 success fail p (_:s) =->   nestedComment p0 success fail (next p) s-> nestedComment p0 success fail p [] =->   fail p0 "Unterminated nested comment at end-of-file" p []---> lexBOL :: SuccessP a -> FailP a -> P a-> lexBOL success fail p s _ [] = lexToken success fail p s False []-> lexBOL success fail p s _ ctxt@(n:rest)->   | col < n = success p (tok VRightBrace) p s True rest->   | col == n = success p (tok VSemicolon) p s False ctxt->   | otherwise = lexToken success fail p s False ctxt->   where col = column p--> lexToken :: SuccessP a -> FailP a -> P a-> lexToken success fail p [] = success p (tok EOF) p []-> lexToken success fail p (c:s)->   | c == '(' = token LeftParen->   | c == ')' = token RightParen->   | c == ',' = token Comma->   | c == ';' = token Semicolon->   | c == '[' = token LeftBracket->   | c == ']' = token RightBracket->   | c == '_' = token Underscore->   | c == '`' = token Backquote->   | c == '{' = lexLeftBrace (token LeftBrace) (next p) (success p) s ->   | c == '}' = \bol -> token RightBrace bol . drop 1->   | c == '\'' = lexChar p success fail (next p) s->   | c == '\"' = lexString p success fail (next p) s->   | isAlpha c = lexIdent (success p) p (c:s)->   | isSym c = lexSym (success p) p (c:s)->   | isDigit c = lexNumber (success p) p (c:s)->   | otherwise = fail p ("Illegal character " ++ show c) p s->   where token t = success p (tok t) (next p) s--> lexIdent :: (Token -> P a) -> P a-> lexIdent cont p s =->   maybe (lexOptQual cont (token Id) [ident]) (cont . token)->         (Map.lookup ident reserved_and_special_ids)->         (incr p (length ident)) rest->   where (ident,rest) = span isIdent s->         token t = idTok t [] ident--> lexSym :: (Token -> P a) -> P a-> lexSym cont p s =->   cont (idTok (maybe Sym id (Map.lookup sym reserved_and_special_ops)) [] sym)->        (incr p (length sym)) rest->   where (sym,rest) = span isSym s--> lexLeftBrace leftBrace _ _       []    = leftBrace-> lexLeftBrace leftBrace p cont (c:s) ->   | c==';'    = cont (tok LeftBraceSemicolon) (next p) s->   | otherwise = leftBrace--\end{verbatim}-{\em Note:} the function \texttt{lexOptQual} has been extended to provide-the qualified use of the Prelude list operators and tuples.-\begin{verbatim}--> lexOptQual :: (Token -> P a) -> Token -> [String] -> P a-> lexOptQual cont token mIdent p ('.':c:s)->   | isAlpha c = lexQualIdent cont identCont mIdent (next p) (c:s)->   | isSym c = lexQualSym cont identCont mIdent (next p) (c:s)->   | c=='(' || c=='[' ->     = lexQualPreludeSym cont token identCont mIdent (next p) (c:s)->  where identCont _ _ = cont token p ('.':c:s)-> lexOptQual cont token mIdent p s = cont token p s--> lexQualIdent :: (Token -> P a) -> P a -> [String] -> P a-> lexQualIdent cont identCont mIdent p s =->   maybe (lexOptQual cont (idTok QId mIdent ident) (mIdent ++ [ident]))->         (const identCont)->         (Map.lookup ident reserved_ids)->         (incr p (length ident)) rest->   where (ident,rest) = span isIdent s--> lexQualSym :: (Token -> P a) -> P a -> [String] -> P a-> lexQualSym cont identCont mIdent p s =->   maybe (cont (idTok QSym mIdent sym)) (const identCont)->         (Map.lookup sym reserved_ops)->         (incr p (length sym)) rest->   where (sym,rest) = span isSym s---> lexQualPreludeSym :: (Token -> P a) -> Token -> P a -> [String] -> P a-> lexQualPreludeSym cont _ identCont mIdent p ('[':']':rest) =->   cont (idTok QId mIdent "[]") (incr p 2) rest-> lexQualPreludeSym cont _ identCont mIdent p ('(':rest)->   | not (null rest') && head rest'==')' ->   = cont (idTok QId mIdent ('(':tup++")")) (incr p (length tup+2)) (tail rest')->   where (tup,rest') = span (==',') rest-> lexQualPreludeSym cont token _ _ p s =  cont token p s---\end{verbatim}-{\em Note:} since Curry allows an unlimited range of integer numbers,-read numbers must be converted to Haskell type \texttt{Integer}.-\begin{verbatim}--> lexNumber :: (Token -> P a) -> P a-> lexNumber cont p ('0':c:s)->   | c `elem` "oO" = lexOctal cont nullCont (incr p 2) s->   | c `elem` "xX" = lexHexadecimal cont nullCont (incr p 2) s->   where nullCont _ _ = cont (intTok 10 "0") (next p) (c:s)-> lexNumber cont p s->     = lexOptFraction cont (integerTok 10 digits) digits->                      (incr p (length digits)) rest->   where (digits,rest) = span isDigit s->         num           = (read digits) :: Integer--> lexOctal :: (Token -> P a) -> P a -> P a-> lexOctal cont nullCont p s->   | null digits = nullCont undefined undefined->   | otherwise = cont (integerTok 8 digits) (incr p (length digits)) rest->   where (digits,rest) = span isOctit s--> lexHexadecimal :: (Token -> P a) -> P a -> P a-> lexHexadecimal cont nullCont p s->   | null digits = nullCont undefined undefined->   | otherwise = cont (integerTok 16 digits) (incr p (length digits)) rest->   where (digits,rest) = span isHexit s--> lexOptFraction :: (Token -> P a) -> Token -> String -> P a-> lexOptFraction cont _ mant p ('.':c:s)->   | isDigit c = lexOptExponent cont (floatTok mant frac 0 "") mant frac->                                (incr p (length frac+1)) rest->   where (frac,rest) = span isDigit (c:s)-> lexOptFraction cont token mant p (c:s)->   | c `elem` "eE" = lexSignedExponent cont intCont mant "" [c] (next p) s->   where intCont _ _ = cont token p (c:s)-> lexOptFraction cont token _ p s = cont token p s--> lexOptExponent :: (Token -> P a) -> Token -> String -> String -> P a-> lexOptExponent cont token mant frac p (c:s)->   | c `elem` "eE" = lexSignedExponent cont floatCont mant frac [c] (next p) s->   where floatCont _ _ = cont token p (c:s)-> lexOptExponent cont token mant frac p s = cont token p s--> lexSignedExponent :: (Token -> P a) -> P a -> String -> String -> String -> P a-> lexSignedExponent cont floatCont mant frac e p ('+':c:s)->   | isDigit c = lexExponent cont mant frac (e++"+") id (next p) (c:s)-> lexSignedExponent cont floatCont mant frac e p ('-':c:s)->   | isDigit c = lexExponent cont mant frac (e++"-") negate (next p) (c:s)-> lexSignedExponent cont floatCont mant frac e p (c:s)->   | isDigit c = lexExponent cont mant frac e id p (c:s)-> lexSignedExponent cont floatCont mant frac e p s = floatCont p s--> lexExponent :: (Token -> P a) -> String -> String -> String -> (Int -> Int) -> P a-> lexExponent cont mant frac e expSign p s =->   cont (floatTok mant frac exp (e++digits)) (incr p (length digits)) rest->   where (digits,rest) = span isDigit s->         exp = expSign (convertIntegral 10 digits)--> lexChar :: Position -> SuccessP a -> FailP a -> P a-> lexChar p0 success fail p [] = fail p0 "Illegal character constant" p []-> lexChar p0 success fail p (c:s)->   | c == '\\' = lexEscape p (lexCharEnd p0 success fail) fail (next p) s->   | c == '\n' = fail p0 "Illegal character constant" p (c:s)->   | c == '\t' = lexCharEnd p0 success fail c "\t" (tab p) s->   | otherwise = lexCharEnd p0 success fail c [c] (next p) s--> lexCharEnd :: Position -> SuccessP a -> FailP a -> Char -> String -> P a-> lexCharEnd p0 success fail c o p ('\'':s) = success p0 (charTok c o) (next p) s-> lexCharEnd p0 success fail c o p s =->   fail p0 "Improperly terminated character constant" p s--> lexString :: Position -> SuccessP a -> FailP a -> P a-> lexString p0 success fail = lexStringRest p0 success fail "" id--> lexStringRest :: Position -> SuccessP a -> FailP a -> String -> (String -> String) -> P a-> lexStringRest p0 success fail s0 so p [] = ->   fail p0 "Improperly terminated string constant" p []-> lexStringRest p0 success fail s0 so p (c:s)->   | c == '\\' =->       lexStringEscape p (lexStringRest p0 success fail) fail s0 so (next p) s->   | c == '\"' = success p0 (stringTok (reverse s0) (so "")) (next p) s->   | c == '\n' = fail p0 "Improperly terminated string constant" p []->   | c == '\t' = lexStringRest p0 success fail (c:s0) (so . (c:)) (tab p) s->   | otherwise = lexStringRest p0 success fail (c:s0) (so . (c:)) (next p) s--> lexStringEscape ::  Position -> (String -> (String -> String) -> P a) -> FailP a -> ->                                  String -> (String -> String) -> P a-> lexStringEscape p0 success fail s0 so p [] = lexEscape p0 undefined fail p []-> lexStringEscape p0 success fail s0 so p (c:s)->   | c == '&' = success s0 (so . ("\\&"++)) (next p) s->   | isSpace c = lexStringGap (success s0) fail so p (c:s)->   | otherwise = lexEscape p0 (\ c' s' -> success (c':s0) (so . (s'++))) fail p (c:s)--> lexStringGap :: ((String -> String) -> P a) -> FailP a -> (String -> String) -> P a-> lexStringGap success fail so p [] = fail p "End of file in string gap" p []-> lexStringGap success fail so p (c:s)->   | c == '\\' = success (so . (c:)) (next p) s->   | c == '\t' = lexStringGap success fail (so . (c:)) (tab p) s->   | c == '\n' = lexStringGap success fail (so . (c:)) (nl p) s->   | isSpace c = lexStringGap success fail (so . (c:)) (next p) s->   | otherwise = fail p ("Illegal character in string gap " ++ show c) p s--> lexEscape :: Position -> (Char -> String -> P a) -> FailP a -> P a-> lexEscape p0 success fail p ('a':s) = success '\a' "\\a" (next p) s-> lexEscape p0 success fail p ('b':s) = success '\b' "\\b" (next p) s-> lexEscape p0 success fail p ('f':s) = success '\f' "\\f" (next p) s-> lexEscape p0 success fail p ('n':s) = success '\n' "\\n" (next p) s-> lexEscape p0 success fail p ('r':s) = success '\r' "\\r" (next p) s-> lexEscape p0 success fail p ('t':s) = success '\t' "\\t" (next p) s-> lexEscape p0 success fail p ('v':s) = success '\v' "\\v" (next p) s-> lexEscape p0 success fail p ('\\':s) = success '\\' "\\\\" (next p) s-> lexEscape p0 success fail p ('"':s) = success '\"' "\\\"" (next p) s-> lexEscape p0 success fail p ('\'':s) = success '\'' "\\\'" (next p) s-> lexEscape p0 success fail p ('^':c:s)->   | isUpper c || c `elem` "@[\\]^_" =->       success (chr (ord c `mod` 32)) ("\\^"++[c]) (incr p 2) s-> lexEscape p0 success fail p ('o':c:s)->   | isOctit c = numEscape p0 success fail 8 isOctit ("\\o"++) (next p) (c:s)-> lexEscape p0 success fail p ('x':c:s)->   | isHexit c = numEscape p0 success fail 16 isHexit ("\\x"++) (next p) (c:s)-> lexEscape p0 success fail p (c:s)->   | isDigit c = numEscape p0 success fail 10 isDigit ("\\"++) p (c:s)-> lexEscape p0 success fail p s = asciiEscape p0 success fail p s--> asciiEscape :: Position -> (Char -> String -> P a) -> FailP a -> P a-> asciiEscape p0 success fail p ('N':'U':'L':s) = success '\NUL' "\\NUL" (incr p 3) s-> asciiEscape p0 success fail p ('S':'O':'H':s) = success '\SOH' "\\SOH" (incr p 3) s-> asciiEscape p0 success fail p ('S':'T':'X':s) = success '\STX' "\\STX" (incr p 3) s-> asciiEscape p0 success fail p ('E':'T':'X':s) = success '\ETX' "\\ETX" (incr p 3) s-> asciiEscape p0 success fail p ('E':'O':'T':s) = success '\EOT' "\\EOT" (incr p 3) s-> asciiEscape p0 success fail p ('E':'N':'Q':s) = success '\ENQ' "\\ENQ" (incr p 3) s-> asciiEscape p0 success fail p ('A':'C':'K':s) = success '\ACK' "\\ACK" (incr p 3) s -> asciiEscape p0 success fail p ('B':'E':'L':s) = success '\BEL' "\\BEL" (incr p 3) s-> asciiEscape p0 success fail p ('B':'S':s) = success '\BS' "\\BS" (incr p 2) s-> asciiEscape p0 success fail p ('H':'T':s) = success '\HT' "\\HT" (incr p 2) s-> asciiEscape p0 success fail p ('L':'F':s) = success '\LF' "\\LF" (incr p 2) s-> asciiEscape p0 success fail p ('V':'T':s) = success '\VT' "\\VT" (incr p 2) s-> asciiEscape p0 success fail p ('F':'F':s) = success '\FF' "\\FF" (incr p 2) s-> asciiEscape p0 success fail p ('C':'R':s) = success '\CR' "\\CR" (incr p 2) s-> asciiEscape p0 success fail p ('S':'O':s) = success '\SO' "\\SO" (incr p 2) s-> asciiEscape p0 success fail p ('S':'I':s) = success '\SI' "\\SI" (incr p 2) s-> asciiEscape p0 success fail p ('D':'L':'E':s) = success '\DLE' "\\DLE" (incr p 3) s -> asciiEscape p0 success fail p ('D':'C':'1':s) = success '\DC1' "\\DC1" (incr p 3) s-> asciiEscape p0 success fail p ('D':'C':'2':s) = success '\DC2' "\\DC2" (incr p 3) s-> asciiEscape p0 success fail p ('D':'C':'3':s) = success '\DC3' "\\DC3" (incr p 3) s-> asciiEscape p0 success fail p ('D':'C':'4':s) = success '\DC4' "\\DC4" (incr p 3) s-> asciiEscape p0 success fail p ('N':'A':'K':s) = success '\NAK' "\\NAK" (incr p 3) s-> asciiEscape p0 success fail p ('S':'Y':'N':s) = success '\SYN' "\\SYN" (incr p 3) s-> asciiEscape p0 success fail p ('E':'T':'B':s) = success '\ETB' "\\ETB" (incr p 3) s-> asciiEscape p0 success fail p ('C':'A':'N':s) = success '\CAN' "\\CAN" (incr p 3) s -> asciiEscape p0 success fail p ('E':'M':s) = success '\EM' "\\EM" (incr p 2) s-> asciiEscape p0 success fail p ('S':'U':'B':s) = success '\SUB' "\\SUB" (incr p 3) s-> asciiEscape p0 success fail p ('E':'S':'C':s) = success '\ESC' "\\ESC" (incr p 3) s-> asciiEscape p0 success fail p ('F':'S':s) = success '\FS' "\\FS" (incr p 2) s-> asciiEscape p0 success fail p ('G':'S':s) = success '\GS' "\\GS" (incr p 2) s-> asciiEscape p0 success fail p ('R':'S':s) = success '\RS' "\\RS" (incr p 2) s-> asciiEscape p0 success fail p ('U':'S':s) = success '\US' "\\US" (incr p 2) s-> asciiEscape p0 success fail p ('S':'P':s) = success '\SP' "\\SP" (incr p 2) s-> asciiEscape p0 success fail p ('D':'E':'L':s) = success '\DEL' "\\DEL" (incr p 3) s-> asciiEscape p0 success fail p s = fail p0 "Illegal escape sequence" p s--> numEscape :: Position -> (Char -> String -> P a) -> FailP a -> Int->           -> (Char -> Bool) -> (String -> String) -> P a-> numEscape p0 success fail b isDigit so p s->   | n >= min && n <= max = success (chr n) (so digits) (incr p (length digits)) rest->   | otherwise = fail p0 "Numeric escape out-of-range" p s->   where (digits,rest) = span isDigit s->         n = convertIntegral b digits->         min = ord minBound->         max = ord maxBound--\end{verbatim}
+ src/Curry/Syntax/Parser.hs view
@@ -0,0 +1,1428 @@+{- |+    Module      :  $Header$+    Description :  A Parser for Curry+    Copyright   :  (c) 1999 - 2004 Wolfgang Lux+                       2005        Martin Engelke+                       2011 - 2015 Björn Peemöller+                       2016 - 2017 Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    The Curry parser is implemented using the (mostly) LL(1) parsing+    combinators implemented in 'Curry.Base.LLParseComb'.+-}+module Curry.Syntax.Parser+  ( parseSource, parseHeader, parsePragmas, parseInterface, parseGoal+  ) where++import Curry.Base.Ident+import Curry.Base.Monad       (CYM)+import Curry.Base.Position    (Position(..), getPosition, setPosition, incr)+import Curry.Base.LLParseComb+import Curry.Base.Span        hiding (file) -- clash with Position.file+import Curry.Base.SpanInfo++import Curry.Syntax.Extension+import Curry.Syntax.Lexer (Token (..), Category (..), Attributes (..), lexer)+import Curry.Syntax.Type++-- |Parse a 'Module'+parseSource :: FilePath -> String -> CYM (Module ())+parseSource = fullParser (mkMod <$> moduleHeader <*> layout moduleDecls) lexer+  where mkMod f ((im, ds), lay) = f lay im ds++-- |Parse only pragmas of a 'Module'+parsePragmas :: FilePath -> String -> CYM (Module ())+parsePragmas+  = prefixParser ((\ps sp -> setEndPosition NoPos+                              (Module (spanInfo sp []) WhitespaceLayout+                                 ps mainMIdent Nothing [] []))+                    <$> modulePragmas <*> spanPosition)+      lexer++-- |Parse a 'Module' header+parseHeader :: FilePath -> String -> CYM (Module ())+parseHeader = prefixParser+  (mkMod <$> moduleHeader <*> startLayout importDecls) lexer+  where+    importDecls = mkImport <$> many ((,) <$> importDecl+                                         <*> many (spanPosition <*-> semicolon))+    mkImport xs = let (im, spss) = unzip xs in (im, concat spss)+    mkMod f (im, lay) = f lay im []++-- |Parse an 'Interface'+parseInterface :: FilePath -> String -> CYM Interface+parseInterface = fullParser interface lexer++-- |Parse a 'Goal'+parseGoal :: String -> CYM (Goal ())+parseGoal = fullParser goal lexer ""++-- ---------------------------------------------------------------------------+-- Module header+-- ---------------------------------------------------------------------------++-- |Parser for a module header+moduleHeader :: Parser a Token+                  (LayoutInfo -> [ImportDecl] -> [Decl b] -> Module b)+moduleHeader =+  (\sp ps (m, es, inf) lay is ds -> updateEndPos $+      Module (spanInfo sp inf) lay ps m es is ds)+    <$> spanPosition+    <*> modulePragmas+    <*> header+  where header = (\sp1 m es sp2 -> (m, es, [sp1,sp2]))+                    <$>  tokenSpan KW_module+                    <*>  modIdent+                    <*>  option exportSpec+                    <*>  spanPosition+                    <*-> expectWhere+                `opt` (mainMIdent, Nothing, [])++modulePragmas :: Parser a Token [ModulePragma]+modulePragmas = many (languagePragma <|> optionsPragma)++languagePragma :: Parser a Token ModulePragma+languagePragma =   languagePragma'+              <$>  tokenSpan PragmaLanguage+              <*>  (languageExtension `sepBy1Sp` comma)+              <*>  tokenSpan PragmaEnd+  where languageExtension = classifyExtension <$> ident+        languagePragma' sp1 (ex, ss) sp2 = updateEndPos $+          LanguagePragma (spanInfo sp1 (sp1 : ss ++ [sp2])) ex++-- TODO The span info is not 100% complete due to the lexer+-- combining OPTIONS, toolVal and toolArgs+optionsPragma :: Parser a Token ModulePragma+optionsPragma = optionsPragma'+           <$>  spanPosition+           <*>  token PragmaOptions+           <*>  tokenSpan PragmaEnd+  where optionsPragma' sp1 a sp2 = updateEndPos $+          OptionsPragma (spanInfo sp1 [sp1, sp2])+                        (classifyTool <$> toolVal a)+                        (toolArgs a)++-- |Parser for an export specification+exportSpec :: Parser a Token ExportSpec+exportSpec = exportSpec' <$> spanPosition <*> parensSp (export `sepBySp` comma)+  where exportSpec' sp1 ((ex, ss),sp2,sp3) = updateEndPos $+          Exporting (spanInfo sp1 (sp2:(ss ++ [sp3]))) ex++-- |Parser for an export item+export :: Parser a Token Export+export =  qtycon <**> (tcExportWith <$> parensSp spec `opt` tcExport)+      <|> tcExport <$> qfun <\> qtycon+      <|> exportModule' <$> tokenSpan KW_module <*> modIdent+  where spec =  (\sp      -> (ExportTypeAll    , [sp])) <$> tokenSpan DotDot+            <|> (\(c, ss) -> (exportTypeWith' c,  ss )) <$> con `sepBySp` comma+        tcExport qtc = updateEndPos $ Export (fromSrcSpan (getSrcSpan qtc)) qtc+        tcExportWith ((spc, ss), sp1, sp2) qtc =+          updateEndPos $ setSrcInfoPoints (sp1 : (ss ++ [sp2])) $+          spc (fromSrcSpan (getSrcSpan qtc)) qtc+        exportTypeWith' c spi qtc = ExportTypeWith spi qtc c+        exportModule' sp = updateEndPos . ExportModule (spanInfo sp [sp])++moduleDecls :: Parser a Token (([ImportDecl], [Decl ()]), [Span])+moduleDecls = mkImpDecl <$> importDecl+                        <*> (moduleDecls' `opt` ([], [], []))+          <|> mkTopDecl <$> topDecls+  where+    mkImpDecl i (is, ds, sps) = ((i:is, ds), sps)+    mkTopDecl (ds, sps) = (([], ds), sps)++    moduleDecls' = mkDecls <$> spanPosition <*-> semicolon <*> moduleDecls+    mkDecls sp ((im, ds), sps) = (im, ds, sp:sps)++-- |Parser for a single import declaration+importDecl :: Parser a Token ImportDecl+importDecl =  importDecl'+          <$> tokenSpan KW_import+          <*> option (tokenSpan Id_qualified)+          <*> modIdent+          <*> option ((,) <$> tokenSpan Id_as <*> modIdent)+          <*> option importSpec+  where+    importDecl' sp1 (Just sp2) mid (Just (sp3, alias)) = updateEndPos .+      ImportDecl (spanInfo sp1 [sp1, sp2, sp3]) mid True  (Just alias)+    importDecl' sp1 Nothing    mid (Just (sp3, alias)) = updateEndPos .+      ImportDecl (spanInfo sp1      [sp1, sp3]) mid False (Just alias)+    importDecl' sp1 (Just sp2) mid Nothing             = updateEndPos .+      ImportDecl (spanInfo sp1      [sp1, sp2]) mid True  Nothing+    importDecl' sp1 Nothing    mid Nothing             = updateEndPos .+      ImportDecl (spanInfo sp1           [sp1]) mid False Nothing++-- |Parser for an import specification+importSpec :: Parser a Token ImportSpec+importSpec =   spanPosition+          <**> (hiding' <$-> token Id_hiding `opt` importing')+          <*>  parensSp (importSp `sepBySp` comma)+  where+    hiding' sp1 ((specs, ss), sp2, sp3) = updateEndPos $+      Hiding    (spanInfo sp1 (sp1 : sp2 : (ss ++ [sp3]))) specs+    importing' sp1 ((specs, ss), sp2, sp3) = updateEndPos $+      Importing (spanInfo sp1 (      sp2 : (ss ++ [sp3]))) specs++importSp :: Parser a Token Import+importSp = tycon <**> (tcImportWith <$> parensSp spec `opt` tcImport)+      <|> tcImport <$> fun <\> tycon+  where spec =  (\sp      -> (ImportTypeAll    , [sp])) <$> tokenSpan DotDot+            <|> (\(c, ss) -> (importTypeWith' c,  ss )) <$> con `sepBySp` comma+        tcImport tc = updateEndPos $ Import (fromSrcSpan (getSrcSpan tc)) tc+        tcImportWith ((spc, ss), sp1, sp2) tc =+          updateEndPos $ setSrcInfoPoints (sp1 : (ss ++ [sp2])) $+          spc (fromSrcSpan (getSrcSpan tc)) tc+        importTypeWith' c spi tc = ImportTypeWith spi tc c+-- ---------------------------------------------------------------------------+-- Interfaces+-- ---------------------------------------------------------------------------++-- |Parser for an interface+interface :: Parser a Token Interface+interface = uncurry <$> intfHeader <*> braces intfDecls++intfHeader :: Parser a Token ([IImportDecl] -> [IDecl] -> Interface)+intfHeader = Interface <$-> token Id_interface <*> modIdent <*-> expectWhere++intfDecls :: Parser a Token ([IImportDecl], [IDecl])+intfDecls = impDecl <$> iImportDecl+                    <*> (semicolon <-*> intfDecls `opt` ([], []))+        <|> (,) [] <$> intfDecl `sepBy` semicolon+  where impDecl i (is, ds) = (i:is, ds)++-- |Parser for a single interface import declaration+iImportDecl :: Parser a Token IImportDecl+iImportDecl = IImportDecl <$> tokenPos KW_import <*> modIdent++-- |Parser for a single interface declaration+intfDecl :: Parser a Token IDecl+intfDecl = choice [ iInfixDecl, iHidingDecl, iDataDecl, iNewtypeDecl+                  , iTypeDecl , iFunctionDecl <\> token Id_hiding+                  , iClassDecl, iInstanceDecl ]++-- |Parser for an interface infix declaration+iInfixDecl :: Parser a Token IDecl+iInfixDecl = infixDeclLhs iInfixDecl' <*> integer <*> qfunop+  where iInfixDecl' sp = IInfixDecl (span2Pos sp)++-- |Parser for an interface hiding declaration+iHidingDecl :: Parser a Token IDecl+iHidingDecl = tokenPos Id_hiding <**> (hDataDecl <|> hClassDecl)+  where+  hDataDecl = hiddenData <$-> token KW_data <*> withKind qtycon <*> many tyvar+  hClassDecl = hiddenClass <$> classInstHead KW_class (withKind qtycls) clsvar+  hiddenData (tc, k) tvs p = HidingDataDecl p tc k tvs+  hiddenClass (_, _, cx, (qcls, k), tv) p = HidingClassDecl p cx qcls k tv++-- |Parser for an interface data declaration+iDataDecl :: Parser a Token IDecl+iDataDecl = iTypeDeclLhs IDataDecl KW_data <*> constrs <*> iHiddenPragma+  where constrs = equals <-*> constrDecl `sepBy1` bar `opt` []++-- |Parser for an interface newtype declaration+iNewtypeDecl :: Parser a Token IDecl+iNewtypeDecl = iTypeDeclLhs INewtypeDecl KW_newtype+               <*-> equals <*> newConstrDecl <*> iHiddenPragma++-- |Parser for an interface type synonym declaration+iTypeDecl :: Parser a Token IDecl+iTypeDecl = iTypeDeclLhs ITypeDecl KW_type+            <*-> equals <*> type0++-- |Parser for an interface hiding pragma+iHiddenPragma :: Parser a Token [Ident]+iHiddenPragma = token PragmaHiding+                <-*> (con `sepBy` comma)+                <*-> token PragmaEnd+                `opt` []++-- |Parser for an interface function declaration+iFunctionDecl :: Parser a Token IDecl+iFunctionDecl = IFunctionDecl <$> position <*> qfun <*> option iMethodPragma+                <*> arity <*-> token DoubleColon <*> qualType++-- |Parser for an interface method pragma+iMethodPragma :: Parser a Token Ident+iMethodPragma = token PragmaMethod <-*> clsvar <*-> token PragmaEnd++-- |Parser for function's arity+arity :: Parser a Token Int+arity = int `opt` 0++iTypeDeclLhs :: (Position -> QualIdent -> Maybe KindExpr -> [Ident] -> a)+             -> Category -> Parser b Token a+iTypeDeclLhs f kw = f' <$> tokenPos kw <*> withKind qtycon <*> many tyvar+  where f' p (tc, k) = f p tc k++-- |Parser for an interface class declaration+iClassDecl :: Parser a Token IDecl+iClassDecl = (\(sp, _, cx, (qcls, k), tv) ->+               IClassDecl (span2Pos sp) cx qcls k tv)+        <$> classInstHead KW_class (withKind qtycls) clsvar+        <*> braces (iMethod `sepBy` semicolon)+        <*> iClassHidden++-- |Parser for an interface method declaration+iMethod :: Parser a Token IMethodDecl+iMethod = IMethodDecl <$> position+                      <*> fun <*> option int <*-> token DoubleColon <*> qualType++-- |Parser for an interface hiding pragma+iClassHidden :: Parser a Token [Ident]+iClassHidden = token PragmaHiding+          <-*> (fun `sepBy` comma)+          <*-> token PragmaEnd+          `opt` []++-- |Parser for an interface instance declaration+iInstanceDecl :: Parser a Token IDecl+iInstanceDecl = (\(sp, _, cx, qcls, inst) ->+                   IInstanceDecl (span2Pos sp) cx qcls inst)+           <$> classInstHead KW_instance qtycls type2+           <*> braces (iImpl `sepBy` semicolon)+           <*> option iModulePragma++-- |Parser for an interface method implementation+iImpl :: Parser a Token IMethodImpl+iImpl = (,) <$> fun <*> arity++iModulePragma :: Parser a Token ModuleIdent+iModulePragma = token PragmaModule <-*> modIdent <*-> token PragmaEnd++-- ---------------------------------------------------------------------------+-- Top-Level Declarations+-- ---------------------------------------------------------------------------++topDecls :: Parser a Token ([Decl ()], [Span])+topDecls = topDecl `sepBySp` semicolon++topDecl :: Parser a Token (Decl ())+topDecl = choice [ dataDecl, externalDataDecl, newtypeDecl, typeDecl+                 , classDecl, instanceDecl, defaultDecl+                 , infixDecl, functionDecl ]++dataDecl :: Parser a Token (Decl ())+dataDecl = combineWithSpans+             <$> typeDeclLhs dataDecl' KW_data+             <*> ((addSpan <$> tokenSpan Equals <*> constrs) `opt` ([],[]))+             <*> deriv+  where constrs = constrDecl `sepBy1Sp` bar+        dataDecl' sp = DataDecl (spanInfo sp [sp])++externalDataDecl :: Parser a Token (Decl ())+externalDataDecl = decl <$> tokenSpan KW_external <*> typeDeclLhs (,,) KW_data+  where decl sp1 (sp2, tc, tvs) = updateEndPos $+          ExternalDataDecl (spanInfo sp1 [sp1, sp2]) tc tvs++newtypeDecl :: Parser a Token (Decl ())+newtypeDecl = combineWithSpans+             <$> typeDeclLhs newtypeDecl' KW_newtype+             <*> ((\sp c -> (c, [sp]))  <$> tokenSpan Equals <*> newConstrDecl)+             <*> deriv+  where newtypeDecl' sp = NewtypeDecl (spanInfo sp [sp])++combineWithSpans :: HasSpanInfo a =>+                    (t1 -> t2 -> a) -> (t1, [Span]) -> (t2, [Span]) -> a+combineWithSpans df (cs, sps1) (cls, sps2)+  = updateEndPos $ setSrcInfoPoints (getSrcInfoPoints res ++ sps1 ++ sps2) res+  where res = df cs cls++typeDecl :: Parser a Token (Decl ())+typeDecl = typeDeclLhs typeDecl' KW_type <*> tokenSpan Equals <*> type0+  where typeDecl' sp1 tyc tyv sp2 txp = updateEndPos $+          TypeDecl (spanInfo sp1 [sp1, sp2]) tyc tyv txp++typeDeclLhs :: (Span -> Ident -> [Ident] -> a) -> Category+            -> Parser b Token a+typeDeclLhs f kw = f <$> tokenSpan kw <*> tycon <*> many anonOrTyvar++constrDecl :: Parser a Token ConstrDecl+constrDecl = spanPosition <**> constr+  where+  constr =  conId     <**> identDecl+        <|> tokenSpan LeftParen <**> parenDecl+        <|> type1 <\> conId <\> leftParen <**> opDecl+  identDecl =  many type2 <**> (conType <$> opDecl `opt` conDecl)+           <|> recDecl <$> recFields+  parenDecl =  conOpDeclPrefix+           <$> conSym    <*>   tokenSpan RightParen <*> type2 <*> type2+           <|> tupleType <**> (tokenSpan RightParen <**> opDeclParen)+  opDecl = conOpDecl <$> conop <*> type1+  opDeclParen = conOpDeclParen <$> conop <*> type1+  recFields = layoutOff <-*> bracesSp (fieldDecl `sepBySp` comma)+  conType f tys c = f $ foldl mkApply (mkConstructorType $ qualify c) tys+  mkApply t1 t2 = updateEndPos $ ApplyType (fromSrcSpan (getSrcSpan t1)) t1 t2+  mkConstructorType qid = ConstructorType (fromSrcSpan (getSrcSpan qid)) qid+  conDecl tys c sp = updateEndPos $+    ConstrDecl (SpanInfo sp []) c tys+  conOpDecl op ty2 ty1 sp = updateEndPos $+    ConOpDecl (SpanInfo sp []) ty1 op ty2+  conOpDeclParen op ty2 sp1 ty1 sp2 sp5 = updateEndPos $+    ConOpDecl (SpanInfo sp5 [sp2, sp1]) ty1 op ty2+  conOpDeclPrefix op sp1 ty1 ty2 sp2 sp3 = updateEndPos $+    ConOpDecl (SpanInfo sp3 [sp2, sp1]) ty1 op ty2+  recDecl ((fs, ss), sp1, sp2) c sp3 = updateEndPos $+    RecordDecl (SpanInfo sp3 (sp1 : ss ++ [sp2])) c fs++fieldDecl :: Parser a Token FieldDecl+fieldDecl = mkFieldDecl <$> spanPosition <*> labels+                        <*> tokenSpan DoubleColon <*> type0+  where labels = fun `sepBy1Sp` comma+        mkFieldDecl sp1 (idt,ss) sp2 ty = updateEndPos $+          FieldDecl (spanInfo sp1 (ss ++ [sp2])) idt ty++newConstrDecl :: Parser a Token NewConstrDecl+newConstrDecl = spanPosition <**> (con <**> newConstr)+  where newConstr =  newConDecl <$> type2+                 <|> newRecDecl <$> newFieldDecl+        newConDecl ty  c sp = updateEndPos $ NewConstrDecl (spanInfo sp []) c ty+        newRecDecl ((idt, sp2, ty), sp3, sp4) c sp1 = updateEndPos $+          NewRecordDecl (spanInfo sp1 [sp3,sp2,sp4]) c (idt, ty)++newFieldDecl :: Parser a Token ((Ident, Span, TypeExpr), Span, Span)+newFieldDecl = layoutOff <-*> bracesSp labelDecl+  where labelDecl = (,,) <$> fun <*> tokenSpan DoubleColon <*> type0++deriv :: Parser a Token ([QualIdent], [Span])+deriv = (addSpan <$> tokenSpan KW_deriving <*> classes) `opt` ([], [])+  where classes = ((\q -> ([q], [])) <$> qtycls)+               <|> ((\sp1 (qs, ss) sp2 -> (qs, sp1 : (ss ++ [sp2])))+                      <$> tokenSpan LeftParen+                      <*> (qtycls `sepBySp` comma)+                      <*> tokenSpan RightParen)++functionDecl :: Parser a Token (Decl ())+functionDecl = spanPosition <**> decl+  where decl = fun `sepBy1Sp` comma <**> funListDecl <|?> funRule++funRule :: Parser a Token (Span -> Decl ())+funRule = mkFunDecl <$> lhs <*> declRhs+  where lhs = (\f ->+                 (f, updateEndPos $ FunLhs (fromSrcSpan (getSrcSpan f)) f []))+                 <$> fun <|?> funLhs++funListDecl :: Parser a Token (([Ident],[Span]) -> Span -> Decl ())+funListDecl = typeSig <|> mkExtFun <$> tokenSpan KW_external+  where mkExtFun sp1 (vs,ss) sp2 = updateEndPos $+          ExternalDecl (spanInfo sp2 (ss++[sp1])) (map (Var ()) vs)+++typeSig :: Parser a Token (([Ident],[Span]) -> Span -> Decl ())+typeSig = sig <$> tokenSpan DoubleColon <*> qualType+  where sig sp1 qty (vs,ss) sp2 = updateEndPos $+          TypeSig (spanInfo sp2 (ss++[sp1])) vs qty++mkFunDecl :: (Ident, Lhs ()) -> Rhs () -> Span -> Decl ()+mkFunDecl (f, lhs) rhs' p = updateEndPos $+    FunctionDecl (spanInfo p []) () f [updateEndPos $+                                         Equation (spanInfo p []) lhs rhs']++funLhs :: Parser a Token (Ident, Lhs ())+funLhs = mkFunLhs    <$> fun      <*> many1 pattern2+    <|?> flip ($ updateEndPos) <$> pattern1 <*> opLhs+    <|?> curriedLhs+  where+  opLhs  =                opLHS funSym (gConSym <\> funSym)+       <|> tokenSpan Backquote <**>+             opLHSSp ((,) <$> funId            <*>  spanPosition+                                               <*-> expectBackquote)+                     ((,) <$> qConId <\> funId <*>  spanPosition+                                               <*-> expectBackquote)+  opLHS funP consP   = mkOpLhs       <$> funP  <*> pattern0+                    <|> mkInfixPat   <$> consP <*> pattern1 <*> opLhs+  opLHSSp funP consP = mkOpLhsSp     <$> funP  <*> pattern0+                    <|> mkInfixPatSp <$> consP <*> pattern1 <*> opLhs+  mkFunLhs f ts = (f , updateEndPos $ FunLhs (fromSrcSpan (getSrcSpan f)) f ts)+  mkOpLhs op t2 f t1      =+    let t1' = f t1+    in (op, updateEndPos $ OpLhs (fromSrcSpan (getSrcSpan t1')) t1' op t2)+  mkInfixPat op t2 f g t1 =+    f (g . InfixPattern (fromSrcSpan (getSrcSpan t1)) () t1 op) t2+  mkOpLhsSp (op, sp1)    t2   sp2 f t1 =+    let t1' = f t1+    in (op, updateEndPos $+              OpLhs (spanInfo (getSrcSpan t1') [sp2, sp1]) t1' op t2)++  mkInfixPatSp (op, sp1) t2 g sp2 f t1 =+    g (f . InfixPattern (spanInfo (getSrcSpan t1) [sp2, sp1]) () t1 op) t2+++curriedLhs :: Parser a Token (Ident, Lhs ())+curriedLhs = apLhs <$> parensSp funLhs <*> many1 pattern2+  where apLhs ((f, lhs), sp1, sp2) ts =+          let spi = fromSrcSpan sp1+          in (f, updateEndPos $ setSrcInfoPoints [sp1, sp2] $ ApLhs spi lhs ts)++declRhs :: Parser a Token (Rhs ())+declRhs = rhs equals++rhs :: Parser a Token b -> Parser a Token (Rhs ())+rhs eq = rhsExpr <*> localDecls+  where rhsExpr =  mkSimpleRhs  <$> spanPosition <*-> eq <*> expr+               <|> mkGuardedRhs <$> spanPosition <*>  many1 (condExpr eq)+        mkSimpleRhs  sp1 e  (Just sp2, ds, li) = updateEndPos $+          SimpleRhs  (SpanInfo sp1 [sp1, sp2]) li e ds+        mkSimpleRhs  sp1 e  (Nothing, ds, li) = updateEndPos $+          SimpleRhs  (SpanInfo sp1 [sp1]) li e ds+        mkGuardedRhs sp1 ce (Just sp2, ds, li) = updateEndPos $+          GuardedRhs (SpanInfo sp1 [sp1, sp2]) li ce ds+        mkGuardedRhs sp1 ce (Nothing, ds, li) = updateEndPos $+          GuardedRhs (SpanInfo sp1 [sp1]) li ce ds++whereClause :: Parser a Token b -> Parser a Token (Maybe Span, [b], LayoutInfo)+whereClause decl = (\sp (ds, li) -> (Just sp, ds, li))+  <$> tokenSpan KW_where+  <*> layoutWhere decl `opt` (Nothing, [], WhitespaceLayout)++localDecls :: Parser a Token (Maybe Span, [Decl ()], LayoutInfo)+localDecls = whereClause valueOrInfixDecl++valueDecls :: Parser a Token ([Decl ()], [Span])+valueDecls = valueOrInfixDecl `sepBySp` semicolon++valueOrInfixDecl :: Parser a Token (Decl ())+valueOrInfixDecl = choice [infixDecl, valueDecl]++infixDecl :: Parser a Token (Decl ())+infixDecl = infixDeclLhs infixDecl'+              <*> option ((,) <$> spanPosition <*> integer)+              <*> funop `sepBy1Sp` comma+  where infixDecl' sp1 inf (Just (sp2, pr)) (ids, ss) =+          updateEndPos $ InfixDecl (spanInfo sp1 (sp1:sp2:ss)) inf (Just pr) ids+        infixDecl' sp1 inf Nothing          (ids, ss) =+          updateEndPos $ InfixDecl (spanInfo sp1 (sp1    :ss)) inf Nothing   ids++infixDeclLhs :: (Span -> Infix -> a) -> Parser b Token a+infixDeclLhs f = f <$> spanPosition <*> tokenOps infixKW+  where infixKW = [(KW_infix, Infix), (KW_infixl, InfixL), (KW_infixr, InfixR)]++valueDecl :: Parser a Token (Decl ())+valueDecl = spanPosition <**> decl+  where+  decl =   var `sepBy1Sp` comma       <**> valListDecl+      <|?> patOrFunDecl <$> pattern0   <*> declRhs+      <|?> mkFunDecl    <$> curriedLhs <*> declRhs++  valListDecl =  funListDecl+             <|> mkFree <$> tokenSpan KW_free+    where mkFree sp1 (vs, ss) sp2 = updateEndPos $+            FreeDecl (spanInfo sp2 (ss ++ [sp1])) (map (Var ()) vs)++  patOrFunDecl (ConstructorPattern spi _ c ts)+    | not (isConstrId c) = mkFunDecl (f, FunLhs spi f ts)+    where f = unqualify c+  patOrFunDecl t = patOrOpDecl updateEndPos t++  patOrOpDecl f (InfixPattern spi a t1 op t2)+    | isConstrId op = patOrOpDecl (f . InfixPattern spi a t1 op) t2+    | otherwise     = mkFunDecl (op', updateEndPos $ OpLhs spi (f t1) op' t2)+    where op' = unqualify op+  patOrOpDecl f t = mkPatDecl (f t)++  mkPatDecl t rhs' sp = updateEndPos $ PatternDecl (fromSrcSpan sp) t rhs'++  isConstrId c = c == qConsId || isQualified c || isQTupleId c++defaultDecl :: Parser a Token (Decl ())+defaultDecl = mkDefaultDecl <$> tokenSpan KW_default+                            <*> parensSp (type0 `sepBySp` comma)+  where mkDefaultDecl sp1 ((ty, ss), sp2, sp3) = updateEndPos $+          DefaultDecl (spanInfo sp1 (sp1 : sp2 : (ss ++ [sp3]))) ty++classInstHead :: Category -> Parser a Token b -> Parser a Token c+              -> Parser a Token (Span, [Span], Context, b, c)+classInstHead kw cls ty = f <$> tokenSpan kw+                            <*> optContext (,,) ((,) <$> cls <*> ty)+  where f sp (cx, ss, (cls', ty')) = (sp, ss, cx, cls', ty')++classDecl :: Parser a Token (Decl ())+classDecl = mkClass+        <$> classInstHead KW_class tycls clsvar+        <*> whereClause innerDecl+  where+    --TODO: Refactor by left-factorization+    --TODO: Support infixDecl+    innerDecl = foldr1 (<|?>)+      [ spanPosition <**> (fun `sepBy1Sp` comma <**> typeSig)+      , spanPosition <**> funRule+      {-, infixDecl-} ]+    mkClass (sp1, ss, cx, cls, tv) (Just sp2, ds, li) = updateEndPos $+      ClassDecl (SpanInfo sp1 (sp1 : (ss ++ [sp2]))) li cx cls tv ds+    mkClass (sp1, ss, cx, cls, tv) (Nothing, ds, li) = updateEndPos $+      ClassDecl (SpanInfo sp1 (sp1 : ss)) li cx cls tv ds++instanceDecl :: Parser a Token (Decl ())+instanceDecl = mkInstance+           <$> classInstHead KW_instance qtycls type2+           <*> whereClause innerDecl+  where+    innerDecl = spanPosition <**> funRule+    mkInstance (sp1, ss, cx, qcls, inst) (Just sp2, ds, li) = updateEndPos $+      InstanceDecl (SpanInfo sp1 (sp1 : (ss ++ [sp2]))) li cx qcls inst ds+    mkInstance (sp1, ss, cx, qcls, inst) (Nothing, ds, li) = updateEndPos $+      InstanceDecl (SpanInfo sp1 (sp1 : ss)) li cx qcls inst ds+-- ---------------------------------------------------------------------------+-- Type classes+-- ---------------------------------------------------------------------------++optContext :: (Context -> [Span] -> a -> b)+           -> Parser c Token a+           -> Parser c Token b+optContext f p = combine <$> context <*> tokenSpan DoubleArrow <*> p+            <|?> f [] [] <$> p+  where combine (ctx, ss) sp = f ctx (ss ++ [sp])++context :: Parser a Token (Context, [Span])+context = (\c -> ([c], [])) <$> constraint+      <|> combine <$> parensSp (constraint `sepBySp` comma)+  where combine ((ctx, ss), sp1, sp2) = (ctx, sp1 : (ss ++ [sp2]))++constraint :: Parser a Token Constraint+constraint = mkConstraint <$> spanPosition <*> qtycls <*> conType+  where varType = mkVariableType <$> spanPosition <*> clsvar+        conType = fmap ((,) []) varType+               <|> mk <$> parensSp+                            (foldl mkApplyType <$> varType <*> many1 type2)+        mkConstraint sp qtc (ss, ty) = updateEndPos $+          Constraint (spanInfo sp ss) qtc ty+        mkVariableType sp = VariableType (fromSrcSpan sp)+        mkApplyType t1 t2 =+          ApplyType (fromSrcSpan (combineSpans (getSrcSpan t1)+                                               (getSrcSpan t2)))+                    t1 t2+        mk (a, sp1, sp2) = ([sp1, sp2], a)++-- ---------------------------------------------------------------------------+-- Kinds+-- ---------------------------------------------------------------------------++withKind :: Parser a Token b -> Parser a Token (b, Maybe KindExpr)+withKind p = implicitKind <$> p+        <|?> parens (explicitKind <$> p <*-> token DoubleColon <*> kind0)+  where implicitKind x   = (x, Nothing)+        explicitKind x k = (x, Just k)++-- kind0 ::= kind1 ['->' kind0]+kind0 :: Parser a Token KindExpr+kind0 = kind1 `chainr1` (ArrowKind <$-> token RightArrow)++-- kind1 ::= * | '(' kind0 ')'+kind1 :: Parser a Token KindExpr+kind1 = Star <$-> token SymStar+    <|> parens kind0++-- ---------------------------------------------------------------------------+-- Types+-- ---------------------------------------------------------------------------++-- qualType ::= [context '=>']  type0+qualType :: Parser a Token QualTypeExpr+qualType = mkQualTypeExpr <$> spanPosition <*> optContext (,,) type0+  where mkQualTypeExpr sp (cx, ss, ty) = updateEndPos $+          QualTypeExpr (spanInfo sp ss) cx ty++-- type0 ::= type1 ['->' type0]+type0 :: Parser a Token TypeExpr+type0 = type1 `chainr1` (mkArrowType <$> tokenSpan RightArrow)+  where mkArrowType sp ty1 ty2 = updateEndPos $+          ArrowType (spanInfo (getSrcSpan ty1) [sp]) ty1 ty2++-- type1 ::= [type1] type2+type1 :: Parser a Token TypeExpr+type1 = foldl1 mkApplyType <$> many1 type2+  where mkApplyType ty1 ty2 = updateEndPos $+          ApplyType (fromSrcSpan (getSrcSpan ty1)) ty1 ty2++-- type2 ::= anonType | identType | parenType | bracketType+type2 :: Parser a Token TypeExpr+type2 = anonType <|> identType <|> parenType <|> bracketType++-- anonType ::= '_'+anonType :: Parser a Token TypeExpr+anonType = mkVariableType <$> spanPosition <*> anonIdent+  where mkVariableType sp = VariableType (fromSrcSpan sp)++-- identType ::= <identifier>+identType :: Parser a Token TypeExpr+identType =  mkVariableType    <$> spanPosition <*> tyvar+         <|> mkConstructorType <$> spanPosition <*> qtycon <\> tyvar+  where mkVariableType    sp = VariableType    (fromSrcSpan sp)+        mkConstructorType sp = ConstructorType (fromSrcSpan sp)++-- parenType ::= '(' tupleType ')'+parenType :: Parser a Token TypeExpr+parenType = fmap updateSpanWithBrackets (parensSp tupleType)++-- tupleType ::= type0                         (parenthesized type)+--            |  type0 ',' type0 { ',' type0 } (tuple type)+--            |  '->'                          (function type constructor)+--            |  ',' { ',' }                   (tuple type constructor)+--            |                                (unit type)+tupleType :: Parser a Token TypeExpr+tupleType = type0 <**> (mkTuple <$> many1 ((,) <$> tokenSpan Comma <*> type0)+                          `opt` ParenType NoSpanInfo)+        <|> tokenSpan RightArrow <**> succeed (mkConstructorType qArrowId)+        <|> mkConstructorTupleType <$> many1 (tokenSpan Comma)+        <|> succeed (ConstructorType NoSpanInfo qUnitId)+  where mkTuple stys ty = let (ss, tys) = unzip stys+                          in TupleType (fromSrcInfoPoints ss) (ty : tys)+        mkConstructorType qid sp = ConstructorType (fromSrcInfoPoints [sp]) qid+        mkConstructorTupleType ss = ConstructorType (fromSrcInfoPoints ss)+                                                    (qTupleId (length ss + 1))++-- bracketType ::= '[' listType ']'+bracketType :: Parser a Token TypeExpr+bracketType = fmap updateSpanWithBrackets (bracketsSp listType)++-- listType ::= type0 (list type)+--           |        (list type constructor)+listType :: Parser a Token TypeExpr+listType = ListType NoSpanInfo <$> type0+             `opt` ConstructorType NoSpanInfo qListId++-- ---------------------------------------------------------------------------+-- Literals+-- ---------------------------------------------------------------------------++-- literal ::= '\'' <escaped character> '\''+--          |  <integer>+--          |  <float>+--          |  '"' <escaped string> '"'+literal :: Parser a Token Literal+literal = Char   <$> char+      <|> Int    <$> integer+      <|> Float  <$> float+      <|> String <$> string++-- ---------------------------------------------------------------------------+-- Patterns+-- ---------------------------------------------------------------------------++-- pattern0 ::= pattern1 [ gconop pattern0 ]+pattern0 :: Parser a Token (Pattern ())+pattern0 = pattern1 `chainr1` (mkInfixPattern <$> gconop)+  where mkInfixPattern qid p1 p2 =+          InfixPattern (fromSrcSpan (combineSpans (getSrcSpan p1)+                                                  (getSrcSpan p2)))+            () p1 qid p2++-- pattern1 ::= varId+--           |  QConId { pattern2 }+--           |  '-'  Integer+--           |  '-.' Float+--           |  '(' parenPattern'+--           | pattern2+pattern1 :: Parser a Token (Pattern ())+pattern1 = varId <**> identPattern'            -- unqualified+        <|> qConId <\> varId <**> constrPattern -- qualified+        <|> mkNegNum <$> minus <*> negNum+        <|> tokenSpan LeftParen <**> parenPattern'+        <|> pattern2  <\> qConId <\> leftParen+  where+  identPattern' =  optAsRecPattern+               <|> mkConsPattern qualify <$> many1 pattern2++  constrPattern =  mkConsPattern id <$> many1 pattern2+               <|> optRecPattern+++  parenPattern' =  minus <**> minusPattern+      <|> mkGconPattern <$> gconId <*> tokenSpan RightParen <*> many pattern2+      <|> mkFunIdentP <$> funSym <\> minus <*> tokenSpan RightParen+                                           <*> identPattern'+      <|> mkParenTuple <$> parenTuplePattern <\> minus <*> tokenSpan RightParen+  minusPattern = flip mkParenMinus <$> tokenSpan RightParen <*> identPattern'+         <|> mkParenMinus <$> parenMinusPattern <*> tokenSpan RightParen++  mkNegNum idt = setEndPosition (end (getSrcSpan idt))+  mkParenTuple p sp1 sp2 =+    setSpanInfo (spanInfo (combineSpans sp2 sp1) [sp2, sp1]) p+  mkFunIdentP idt sp1 f sp2 = setSrcSpan (combineSpans sp2 sp1) (f idt)+  mkParenMinus f sp1 idt sp2 = setSrcSpan (combineSpans sp2 sp1) (f idt)+  mkConsPattern f ts c = updateEndPos $+    ConstructorPattern (fromSrcSpan (getSrcSpan (f c))) () (f c) ts+  mkGconPattern qid sp1 ps sp2 = updateEndPos $+    ConstructorPattern (spanInfo (getSrcSpan qid) [sp2,sp1]) () qid ps++pattern2 :: Parser a Token (Pattern ())+pattern2 =  literalPattern <|> anonPattern <|> identPattern+        <|> parenPattern   <|> listPattern <|> lazyPattern++-- literalPattern ::= <integer> | <char> | <float> | <string>+literalPattern :: Parser a Token (Pattern ())+literalPattern = flip LiteralPattern () <$> fmap fromSrcSpan spanPosition+                                        <*> literal++-- anonPattern ::= '_'+anonPattern :: Parser a Token (Pattern ())+anonPattern = flip VariablePattern () <$> fmap fromSrcSpan spanPosition+                                      <*> anonIdent++-- identPattern ::= Variable [ '@' pattern2 | '{' fields '}'+--               |  qConId   [ '{' fields '}' ]+identPattern :: Parser a Token (Pattern ())+identPattern =  varId <**> optAsRecPattern -- unqualified+            <|> qConId <\> varId <**> optRecPattern               -- qualified++-- TODO: document me!+parenPattern :: Parser a Token (Pattern ())+parenPattern = tokenSpan LeftParen <**> parenPattern'+  where+  parenPattern' = minus <**> minusPattern+      <|> mkConstructorPattern <$> gconId <*> tokenSpan RightParen+      <|> mkFunAsRec <$> funSym <\> minus <*> tokenSpan RightParen+                     <*> optAsRecPattern+      <|> mkParenTuple <$> parenTuplePattern <\> minus <*> tokenSpan RightParen+  minusPattern = mkOptAsRec <$> tokenSpan RightParen <*> optAsRecPattern+      <|> mkParen <$> parenMinusPattern <*> tokenSpan RightParen++  mkConstructorPattern qid sp1 sp2 =+    ConstructorPattern (fromSrcSpan (combineSpans sp2 sp1)) () qid []+  mkFunAsRec = flip (flip . mkOptAsRec)+  mkParenTuple p sp1 sp2 =+    let ss  = getSrcInfoPoints p+        spi = spanInfo (combineSpans sp2 sp1) (sp2 : (ss ++ [sp1]))+    in setSpanInfo spi p+  mkOptAsRec sp1 f idt sp2 =+    let p   = f idt+        ss  = getSrcInfoPoints p+        spi = spanInfo (combineSpans sp2 sp1) ([sp2, sp1] ++ ss)+    in setSpanInfo spi p+  mkParen f sp1 idt sp2 =+    let p   = f idt+        ss  = getSrcInfoPoints p+        spi = spanInfo (combineSpans sp2 sp1) (sp2 : (ss ++ [sp1]))+    in setSpanInfo spi p++-- listPattern ::= '[' pattern0s ']'+-- pattern0s   ::= {- empty -}+--              |  pattern0 ',' pattern0s+listPattern :: Parser a Token (Pattern ())+listPattern = mkListPattern <$> bracketsSp (pattern0 `sepBySp` comma)+  where mkListPattern ((ps, ss), sp1, sp2) = updateEndPos $+          ListPattern (spanInfo sp1 (sp1 : (ss ++ [sp2]))) () ps++-- lazyPattern ::= '~' pattern2+lazyPattern :: Parser a Token (Pattern ())+lazyPattern = mkLazyPattern <$> tokenSpan Tilde <*> pattern2+  where mkLazyPattern sp p = updateEndPos $ LazyPattern (spanInfo sp [sp]) p++-- optRecPattern ::= [ '{' fields '}' ]+optRecPattern :: Parser a Token (QualIdent -> Pattern ())+optRecPattern = mkRecordPattern <$> fieldsSp pattern0 `opt` mkConPattern+  where+  mkRecordPattern ((fs, ss), sp1, sp2) c = updateEndPos $+    RecordPattern (spanInfo (getSrcSpan c) (sp1 : (ss ++ [sp2]))) () c fs+  mkConPattern c = ConstructorPattern (fromSrcSpan (getSrcSpan c)) () c []++-- ---------------------------------------------------------------------------+-- Partial patterns used in the combinators above, but also for parsing+-- the left-hand side of a declaration.+-- ---------------------------------------------------------------------------++gconId :: Parser a Token QualIdent+gconId = colon <|> tupleCommas++negNum :: Parser a Token (Pattern ())+negNum = mkNegativePattern <$> spanPosition <*>+                             (Int <$> integer <|> Float <$> float)+  where mkNegativePattern sp = NegativePattern (fromSrcSpan sp) ()++optAsRecPattern :: Parser a Token (Ident -> Pattern ())+optAsRecPattern =  mkAsPattern     <$> tokenSpan At <*> pattern2+               <|> mkRecordPattern <$> fieldsSp pattern0+               `opt` mkVariablePattern+  where mkRecordPattern ((fs,ss),sp1,sp2) v =+          let s = getPosition v+              e = end sp2+              f = file s+              spi = spanInfo (Span f s e) (sp1 : (ss ++ [sp2]))+          in updateEndPos $ RecordPattern spi () (qualify v) fs+        mkAsPattern sp p idt =+          AsPattern (spanInfo (getSrcSpan idt) [sp]) idt p+        mkVariablePattern idt =+          VariablePattern (fromSrcSpan (getSrcSpan idt)) () idt++optInfixPattern :: Parser a Token (Pattern () -> Pattern ())+optInfixPattern = mkInfixPat <$> gconop <*> pattern0+            `opt` id+  where mkInfixPat op t2 t1 =+          let s = getPosition t1+              e = getSrcSpanEnd t2+              f = file s+          in InfixPattern (fromSrcSpan (Span f s e)) () t1 op t2++optTuplePattern :: Parser a Token (Pattern () -> Pattern ())+optTuplePattern = mkTuple <$> many1 ((,) <$> tokenSpan Comma <*> pattern0)+            `opt` ParenPattern NoSpanInfo+  where mkTuple ts t = let (ss, ps) = unzip ts+                       in TuplePattern (fromSrcInfoPoints ss) (t:ps)++parenMinusPattern :: Parser a Token (Ident -> Pattern ())+parenMinusPattern = mkNeg <$> negNum <.> optInfixPattern <.> optTuplePattern+  where mkNeg neg idt = setEndPosition (end (getSrcSpan idt)) neg++parenTuplePattern :: Parser a Token (Pattern ())+parenTuplePattern = pattern0 <**> optTuplePattern+              `opt` ConstructorPattern NoSpanInfo () qUnitId []++-- ---------------------------------------------------------------------------+-- Expressions+-- ---------------------------------------------------------------------------++-- condExpr ::= '|' expr0 eq expr+--+-- Note: The guard is an `expr0` instead of `expr` since conditional expressions+-- may also occur in case expressions, and an expression like+-- @+-- case a of { _ -> True :: Bool -> a }+-- @+-- can not be parsed with a limited parser lookahead.+condExpr :: Parser a Token b -> Parser a Token (CondExpr ())+condExpr eq = mkCondExpr <$> spanPosition <*-> bar <*> expr0+                         <*> spanPosition <*-> eq  <*> expr+  where mkCondExpr sp1 e1 sp2 e2 = updateEndPos $+          CondExpr (spanInfo sp1 [sp1, sp2]) e1 e2++-- expr ::= expr0 [ '::' type0 ]+expr :: Parser a Token (Expression ())+expr = expr0 <??> (mkTyped <$> tokenSpan DoubleColon <*> qualType)+  where mkTyped sp qty e = updateEndPos $ setSrcSpan (getSrcSpan e) $+          Typed (fromSrcInfoPoints [sp]) e qty++-- expr0 ::= expr1 { infixOp expr1 }+expr0 :: Parser a Token (Expression ())+expr0 = expr1 `chainr1` (mkInfixApply <$> infixOp)+  where mkInfixApply op e1 e2 = InfixApply+          (fromSrcSpan (combineSpans (getSrcSpan e1) (getSrcSpan e2))) e1 op e2++-- expr1 ::= - expr2 | -. expr2 | expr2+expr1 :: Parser a Token (Expression ())+expr1 =  mkUnaryMinus <$> minus <*> expr2+     <|> expr2+  where mkUnaryMinus idt ex =+          let p = getPosition idt+              e = getSrcSpanEnd ex+              f = file p+          in UnaryMinus (spanInfo (Span f p e) [Span f p (incr p 1)]) ex++-- expr2 ::= lambdaExpr | letExpr | doExpr | ifExpr | caseExpr | expr3+expr2 :: Parser a Token (Expression ())+expr2 = choice [ lambdaExpr, letExpr, doExpr, ifExpr, caseExpr+               , foldl1 mkApply <$> many1 expr3+               ]+  where mkApply e1 e2 = updateEndPos $ Apply (fromSrcSpan (getSrcSpan e1)) e1 e2++expr3 :: Parser a Token (Expression ())+expr3 = foldl mkRecordUpdate <$> expr4 <*> many recUpdate+  where recUpdate = layoutOff <-*> bracesSp (field expr0 `sepBy1Sp` comma)+        mkRecordUpdate e ((fs,ss), sp1, sp2) = updateEndPos $+          setSrcInfoPoints (sp1 : (ss ++ [sp2])) $+          RecordUpdate (fromSrcSpan (getSrcSpan e)) e fs++expr4 :: Parser a Token (Expression ())+expr4 = choice+  [constant, anonFreeVariable, variable, parenExpr, listExpr]++constant :: Parser a Token (Expression ())+constant = mkLiteral <$> spanPosition <*> literal+  where mkLiteral sp = Literal (fromSrcSpan sp) ()++anonFreeVariable :: Parser a Token (Expression ())+anonFreeVariable =  (\ p v -> mkVariable $ qualify $ addPositionIdent p v)+                <$> position <*> anonIdent+  where mkVariable qid = Variable (fromSrcSpan (getSrcSpan qid)) () qid++variable :: Parser a Token (Expression ())+variable = qFunId <**> optRecord+  where optRecord = mkRecord <$> fieldsSp expr0 `opt` mkVariable+        mkRecord ((fs,ss), sp1, sp2) qid =+          let spi = spanInfo (getSrcSpan qid) (sp1 : (ss ++ [sp2]))+          in updateEndPos $ Record spi () qid fs+        mkVariable qid = Variable (fromSrcSpan (getSrcSpan qid)) () qid++parenExpr :: Parser a Token (Expression ())+parenExpr = fmap updateSpanWithBrackets (parensSp pExpr)+  where+  pExpr = minus <**> minusOrTuple+      <|> mkConstructor () <$> tupleCommas+      <|> leftSectionOrTuple <\> minus+      <|> opOrRightSection <\> minus+      `opt` Constructor (fromSrcInfoPoints []) () qUnitId+  minusOrTuple = mkUnaryMinus <$> expr1 <.> infixOrTuple+            `opt` mkVariable . qualify+  leftSectionOrTuple = expr1 <**> infixOrTuple+  infixOrTuple = ($ updateEndPos) <$> infixOrTuple'+  infixOrTuple' = infixOp <**> leftSectionOrExp+              <|> (.) <$> (optType <.> tupleExpr)+  leftSectionOrExp = expr1 <**> (infixApp <$> infixOrTuple')+                `opt` leftSection+  optType   = mkTyped <$> tokenSpan DoubleColon <*> qualType `opt` id+  tupleExpr = mkTuple <$> many1 ((,) <$> tokenSpan Comma <*> expr)+               `opt` Paren NoSpanInfo+  opOrRightSection =  qFunSym <**> optRightSection+                  <|> colon   <**> optCRightSection+                  <|> infixOp <\> colon <\> qFunSym <**> rightSection+  optRightSection  = (. InfixOp ()    ) <$> rightSection+                       `opt` Variable NoSpanInfo ()+  optCRightSection = (. InfixConstr ()) <$> rightSection+                       `opt` Constructor NoSpanInfo ()+  rightSection     = mkRightSection <$> expr0+  infixApp f e2 op g e1 = f (g . mkInfixApply e1 op) e2+  leftSection op f e = mkLeftSection (f e) op+  mkTuple ses e = let (ss,es) = unzip ses+                  in Tuple (fromSrcInfoPoints ss) (e:es)+  mkConstructor = Constructor NoSpanInfo+  mkTyped sp ty e = Typed (fromSrcInfoPoints [sp]) e ty+  mkRightSection = flip (RightSection NoSpanInfo)+  mkLeftSection  = LeftSection  NoSpanInfo+  mkInfixApply e1 op e2 = InfixApply (fromSrcSpan+    (combineSpans (getSrcSpan e1) (getSrcSpan e2))) e1 op e2+  mkVariable = Variable NoSpanInfo ()+  mkUnaryMinus ex idt =+    let p = getPosition idt+        e = getSrcSpanEnd ex+        f = file p+    in UnaryMinus (spanInfo (Span f p e) [Span f p (incr p 1)]) ex++infixOp :: Parser a Token (InfixOp ())+infixOp = InfixOp () <$> qfunop <|> InfixConstr () <$> colon++listExpr :: Parser a Token (Expression ())+listExpr = updateSpanWithBrackets <$>+             bracketsSp (elements `opt` List (fromSrcInfoPoints []) () [])+  where+  elements = expr <**> rest+  rest = comprehension+      <|> enumeration mkEnumFromTo mkEnumFrom+      <|> (tokenSpan Comma <**> (expr <**>(+           enumeration mkEnumFromThenTo mkEnumFromThen+          <|> list <$> many ((,) <$> tokenSpan Comma <*> expr)))+    `opt` (\ e -> List (fromSrcInfoPoints []) () [e]))+  comprehension = mkListCompr <$> tokenSpan Bar <*> quals+  enumeration enumTo enum =+    tokenSpan DotDot <**> (enumTo <$> expr `opt` enum)++  mkEnumFrom                 sp     =+    EnumFrom (fromSrcInfoPoints [sp])+  mkEnumFromTo            e1 sp  e2 =+    EnumFromTo (fromSrcInfoPoints [sp]) e2 e1+  mkEnumFromThen      sp1 e1 sp2 e2 =+    EnumFromThen (fromSrcInfoPoints [sp2,sp1]) e2 e1+  mkEnumFromThenTo e1 sp1 e2 sp2 e3 =+    EnumFromThenTo (fromSrcInfoPoints [sp2,sp1]) e3 e2 e1+  mkListCompr sp qu e = ListCompr (fromSrcInfoPoints [sp]) e qu++  list xs e2 sp e1 = let (ss, es) = unzip xs+                     in List (fromSrcInfoPoints (sp:ss)) () (e1:e2:es)++updateSpanWithBrackets :: HasSpanInfo a => (a, Span, Span) -> a+updateSpanWithBrackets (ex, sp1, sp2) =+  let ss = getSrcInfoPoints ex+      s  = getPosition sp1+      e  = end sp2+      f  = file s+      spi = spanInfo (Span f s e) (sp1 : (ss ++ [sp2]))+  in setSpanInfo spi ex++lambdaExpr :: Parser a Token (Expression ())+lambdaExpr = mkLambda <$> tokenSpan Backslash <*> many1 pattern2+                      <*> spanPosition <*-> expectRightArrow+                      <*> expr+  where mkLambda sp1 ps sp2 e = updateEndPos $ Lambda (spanInfo sp1 [sp1, sp2]) ps e++letExpr :: Parser a Token (Expression ())+letExpr = mkLet <$>  tokenSpan KW_let <*> layout valueDecls+                <*> (tokenSpan KW_in <?> "in expected") <*> expr+  where+    mkLet sp1 (ds, lay) sp2 e = updateEndPos $+      Let (spanInfo sp1 [sp1, sp2])lay ds e++doExpr :: Parser a Token (Expression ())+doExpr = mkDo <$> tokenSpan KW_do <*> layout stmts+  where+    mkDo sp ((stms, ex), lay) = updateEndPos $+      Do (spanInfo sp [sp]) lay stms ex++ifExpr :: Parser a Token (Expression ())+ifExpr = mkIfThenElse+    <$>  tokenSpan KW_if                        <*> expr+    <*> (tokenSpan KW_then <?> "then expected") <*> expr+    <*> (tokenSpan KW_else <?> "else expected") <*> expr+  where mkIfThenElse sp1 e1 sp2 e2 sp3 e3 = updateEndPos $+          IfThenElse (spanInfo sp1 [sp1, sp2, sp3]) e1 e2 e3++caseExpr :: Parser a Token (Expression ())+caseExpr = (mkCase Flex  <$> tokenSpan KW_fcase+        <|> mkCase Rigid <$> tokenSpan KW_case)+          <*> expr+          <*> (tokenSpan KW_of <?> "of expected")+          <*> layout (alt `sepBy1Sp` semicolon)+  where+    mkCase ct sp1 e sp2 (alts, lay) = updateEndPos $+      Case (spanInfo sp1 [sp1, sp2]) lay ct e alts++alt :: Parser a Token (Alt ())+alt = mkAlt <$> spanPosition <*> pattern0+            <*> spanPosition <*> rhs expectRightArrow+  where mkAlt sp1 p sp2 = updateEndPos . Alt (spanInfo sp1 [sp2]) p++fieldsSp :: Parser a Token b -> Parser a Token (([Field b], [Span]), Span, Span)+fieldsSp p = layoutOff <-*> bracesSp (field p `sepBySp` comma)++field :: Parser a Token b -> Parser a Token (Field b)+field p = mkField <$> spanPosition <*> qfun+                  <*> spanPosition <*-> expectEquals+                  <*> p+  where mkField sp1 q sp2 = updateEndPos . Field (spanInfo sp1 [sp2]) q++-- ---------------------------------------------------------------------------+-- \paragraph{Statements in list comprehensions and \texttt{do} expressions}+-- Parsing statements is a bit difficult because the syntax of patterns+-- and expressions largely overlaps. The parser will first try to+-- recognize the prefix \emph{Pattern}~\texttt{<-} of a binding statement+-- and if this fails fall back into parsing an expression statement. In+-- addition, we have to be prepared that the sequence+-- \texttt{let}~\emph{LocalDefs} can be either a let-statement or the+-- prefix of a let expression.+-- ---------------------------------------------------------------------------++stmts :: Parser a Token (([Statement ()], Expression ()), [Span])+stmts = stmt reqStmts optStmts++reqStmts :: Parser a Token (Statement ()+                        -> (([Statement ()], Expression ()), [Span]))+reqStmts = mkStmts <$> spanPosition <*-> semicolon <*> stmts+  where mkStmts sp ((sts, e), sps) st = ((st : sts, e), sp:sps)++optStmts :: Parser a Token (Expression ()+                        -> (([Statement ()], Expression ()), [Span]))+optStmts = succeed mkStmtExpr <.> reqStmts `opt` (\e -> (([], e), []))+  where mkStmtExpr e = StmtExpr (fromSrcSpan (getSrcSpan e)) e++quals :: Parser a Token [Statement ()]+quals = stmt (succeed id) (succeed mkStmtExpr) `sepBy1` comma+  where mkStmtExpr e = StmtExpr (fromSrcSpan (getSrcSpan e)) e++stmt :: Parser a Token (Statement () -> b)+     -> Parser a Token (Expression () -> b) -> Parser a Token b+stmt stmtCont exprCont =  letStmt stmtCont exprCont+                      <|> exprOrBindStmt stmtCont exprCont++letStmt :: Parser a Token (Statement () -> b)+        -> Parser a Token (Expression () -> b) -> Parser a Token b+letStmt stmtCont exprCont = ((,) <$> tokenSpan KW_let <*> layout valueDecls)+                              <**> optExpr+  where optExpr =  let' <$> tokenSpan KW_in <*> expr <.> exprCont+               <|> succeed stmtDecl' <.> stmtCont+          where+            let' sp1 e (sp2, (ds, lay)) = updateEndPos $+              Let (spanInfo sp2 [sp2, sp1]) lay ds e+            stmtDecl'  (sp2, (ds, lay)) = updateEndPos $+              StmtDecl (spanInfo sp2 [sp2]) lay ds++exprOrBindStmt :: Parser a Token (Statement () -> b)+               -> Parser a Token (Expression () -> b)+               -> Parser a Token b+exprOrBindStmt stmtCont exprCont =+       stmtBind' <$> spanPosition <*> pattern0 <*> tokenSpan LeftArrow <*> expr+         <**> stmtCont+  <|?> expr <\> token KW_let <**> exprCont+  where+    stmtBind' sp1 p sp2 e = updateEndPos $+      StmtBind (spanInfo sp1 [sp2]) p e++-- ---------------------------------------------------------------------------+-- Goals+-- ---------------------------------------------------------------------------++goal :: Parser a Token (Goal ())+goal = mkGoal <$> spanPosition <*> expr <*> localDecls+  where+    mkGoal sp1 ex (Just sp2, ds, li) = updateEndPos $+      Goal (SpanInfo sp1 [sp2]) li ex ds+    mkGoal sp1 ex (Nothing, ds, li) = updateEndPos $+            Goal (SpanInfo sp1 []) li ex ds++-- ---------------------------------------------------------------------------+-- Literals, identifiers, and (infix) operators+-- ---------------------------------------------------------------------------++char :: Parser a Token Char+char = cval <$> token CharTok++float :: Parser a Token Double+float = fval <$> token FloatTok++int :: Parser a Token Int+int = fromInteger <$> integer++integer :: Parser a Token Integer+integer = ival <$> token IntTok++string :: Parser a Token String+string = sval <$> token StringTok++tycon :: Parser a Token Ident+tycon = conId++anonOrTyvar :: Parser a Token Ident+anonOrTyvar = anonIdent <|> tyvar++tyvar :: Parser a Token Ident+tyvar = varId++clsvar :: Parser a Token Ident+clsvar = tyvar++tycls :: Parser a Token Ident+tycls = conId++qtycls :: Parser a Token QualIdent+qtycls = qConId++qtycon :: Parser a Token QualIdent+qtycon = qConId++varId :: Parser a Token Ident+varId = ident++funId :: Parser a Token Ident+funId = ident++conId :: Parser a Token Ident+conId = ident++funSym :: Parser a Token Ident+funSym = sym++conSym :: Parser a Token Ident+conSym = sym++modIdent :: Parser a Token ModuleIdent+modIdent = mIdent <?> "module name expected"++var :: Parser a Token Ident+var = varId <|> updateSpanWithBrackets+                     <$> parensSp (funSym <?> "operator symbol expected")++fun :: Parser a Token Ident+fun = funId <|> updateSpanWithBrackets+                     <$> parensSp (funSym <?> "operator symbol expected")++con :: Parser a Token Ident+con = conId <|> updateSpanWithBrackets+                     <$> parensSp (conSym <?> "operator symbol expected")++funop :: Parser a Token Ident+funop = funSym <|> updateSpanWithBrackets+                     <$> backquotesSp (funId <?> "operator name expected")++conop :: Parser a Token Ident+conop = conSym <|> updateSpanWithBrackets+                     <$> backquotesSp (conId <?> "operator name expected")++qFunId :: Parser a Token QualIdent+qFunId = qIdent++qConId :: Parser a Token QualIdent+qConId = qIdent++qFunSym :: Parser a Token QualIdent+qFunSym = qSym++qConSym :: Parser a Token QualIdent+qConSym = qSym++gConSym :: Parser a Token QualIdent+gConSym = qConSym <|> colon++qfun :: Parser a Token QualIdent+qfun = qFunId <|> updateSpanWithBrackets+                     <$> parensSp (qFunSym <?> "operator symbol expected")++qfunop :: Parser a Token QualIdent+qfunop = qFunSym <|> updateSpanWithBrackets+                     <$> backquotesSp (qFunId <?> "operator name expected")++gconop :: Parser a Token QualIdent+gconop = gConSym <|> updateSpanWithBrackets+                     <$> backquotesSp (qConId <?> "operator name expected")++anonIdent :: Parser a Token Ident+anonIdent = (`setSpanInfo` anonId) . fromSrcSpanBoth <$> tokenSpan Underscore++mIdent :: Parser a Token ModuleIdent+mIdent = mIdent' <$> spanPosition <*>+     tokens [Id,QId,Id_as,Id_ccall,Id_forall,Id_hiding,+             Id_interface,Id_primitive,Id_qualified]+  where mIdent' sp a = ModuleIdent (fromSrcSpanBoth sp) (modulVal a ++ [sval a])++ident :: Parser a Token Ident+ident = (\ sp t -> setSpanInfo (fromSrcSpanBoth sp) (mkIdent (sval t)))+          <$> spanPosition <*> tokens [Id,Id_as,Id_ccall,Id_forall,Id_hiding,+                                       Id_interface,Id_primitive,Id_qualified]++qIdent :: Parser a Token QualIdent+qIdent = qualify <$> ident <|> qIdentWith QId++sym :: Parser a Token Ident+sym = (\ sp t -> setSpanInfo (fromSrcSpanBoth sp) (mkIdent (sval t)))+        <$> spanPosition <*> tokens [Sym, SymDot, SymMinus, SymStar]++qSym :: Parser a Token QualIdent+qSym = qualify <$> sym <|> qIdentWith QSym++qIdentWith :: Category -> Parser a Token QualIdent+qIdentWith c = mkQIdent <$> spanPosition <*> token c+  where mkQIdent :: Span -> Attributes -> QualIdent+        mkQIdent sp a =+          let mid  = ModuleIdent (fromSrcSpan sp) (modulVal a)+              p    = incr (getPosition sp) (mIdentLength mid - 1)+              mid' = setEndPosition p mid+              idt  = setSrcSpan sp $ mkIdent (sval a)+              idt' = setPosition (incr p 1) idt+          in QualIdent (fromSrcSpanBoth sp) (Just mid') idt'++colon :: Parser a Token QualIdent+colon = qualify . (`setSpanInfo` consId) . fromSrcSpanBoth <$> tokenSpan Colon++minus :: Parser a Token Ident+minus = (`setSpanInfo` minusId) . fromSrcSpanBoth <$> tokenSpan SymMinus++tupleCommas :: Parser a Token QualIdent+tupleCommas = (\ sp ss -> qualify $ updateEndPos $ setSpanInfo (spanInfo sp ss)+                                  $ tupleId      $ succ $ length  ss)+              <$> spanPosition <*> many1 (tokenSpan Comma)++-- ---------------------------------------------------------------------------+-- Layout+-- ---------------------------------------------------------------------------++-- |This function starts a new layout block but does not wait for its end.+-- This is only used for parsing the module header.+startLayout :: Parser a Token (b, [Span]) -> Parser a Token (b, LayoutInfo)+startLayout p =  layoutOff <-*>+                   (createExpli1Layout <$> tokenSpan LeftBrace <*> p)+             <|> layoutOn  <-*>+                   (createWhiteLayout  <$> p)++layout :: Parser a Token (b, [Span]) -> Parser a Token (b, LayoutInfo)+layout p =  (createExpliLayout+              <$> (layoutOff <-*> bracesSp p))+        <|> (createWhiteLayout+              <$> (layoutOn  <-*> p <*-> (token VRightBrace <|> layoutEnd)))++createExpli1Layout :: Span -> (b, [Span]) -> (b, LayoutInfo)+createExpli1Layout sp1 (b, ss) = (b, ExplicitLayout (sp1:ss))++createExpliLayout :: ((b, [Span]), Span, Span) -> (b, LayoutInfo)+createExpliLayout ((b, ss), sp1, spe) = (b, ExplicitLayout (sp1:ss ++ [spe]))++createWhiteLayout :: (b, [Span]) -> (b, LayoutInfo)+createWhiteLayout (b, _) = (b, WhitespaceLayout)++-- We have to remove an additional context on an empty where-clause+layoutWhere :: Parser a Token b -> Parser a Token ([b], LayoutInfo)+layoutWhere p =  (createExpliLayout+                    <$> (layoutOff <-*> bracesSp (p `sepBySp` semicolon)))+             <|> (createWhiteLayout+                    <$> (layoutOn  <-*> (p `sepBy1Sp` semicolon)+                                   <*-> (token VRightBrace <|> layoutEnd)))+             <|> succeed ([], WhitespaceLayout)++-- ---------------------------------------------------------------------------+-- Bracket combinators+-- ---------------------------------------------------------------------------++braces :: Parser a Token b -> Parser a Token b+braces p = between leftBrace p rightBrace++bracesSp :: Parser a Token b -> Parser a Token (b, Span, Span)+bracesSp p = (\sp1 b sp2 -> (b, sp1, sp2))+               <$> tokenSpan LeftBrace+               <*> p+               <*> tokenSpan RightBrace++bracketsSp :: Parser a Token b -> Parser a Token (b, Span, Span)+bracketsSp p = (\sp1 b sp2 -> (b, sp1, sp2))+                 <$> tokenSpan LeftBracket+                 <*> p+                 <*> tokenSpan RightBracket++parens :: Parser a Token b -> Parser a Token b+parens p = between leftParen p rightParen++parensSp :: Parser a Token b -> Parser a Token (b, Span, Span)+parensSp p = (\sp1 b sp2 -> (b, sp1, sp2))+               <$> tokenSpan LeftParen+               <*> p+               <*> tokenSpan RightParen++backquotesSp :: Parser a Token b -> Parser a Token (b, Span, Span)+backquotesSp p = (\sp1 b sp2 -> (b, sp1, sp2))+                   <$> tokenSpan Backquote+                   <*> p+                   <*> spanPosition <*-> expectBackquote++-- ---------------------------------------------------------------------------+-- Simple token parsers+-- ---------------------------------------------------------------------------++token :: Category -> Parser a Token Attributes+token c = attr <$> symbol (Token c NoAttributes)+  where attr (Token _ a) = a++tokens :: [Category] -> Parser a Token Attributes+tokens = foldr1 (<|>) . map token++tokenPos :: Category -> Parser a Token Position+tokenPos c = position <*-> token c++tokenSpan :: Category -> Parser a Token Span+tokenSpan c = spanPosition <*-> token c++tokenOps :: [(Category, b)] -> Parser a Token b+tokenOps cs = ops [(Token c NoAttributes, x) | (c, x) <- cs]++comma :: Parser a Token Attributes+comma = token Comma++semicolon :: Parser a Token Attributes+semicolon = token Semicolon <|> token VSemicolon++bar :: Parser a Token Attributes+bar = token Bar++equals :: Parser a Token Attributes+equals = token Equals++expectEquals :: Parser a Token Attributes+expectEquals = equals <?> "= expected"++expectWhere :: Parser a Token Attributes+expectWhere = token KW_where <?> "where expected"++expectRightArrow :: Parser a Token Attributes+expectRightArrow  = token RightArrow <?> "-> expected"++backquote :: Parser a Token Attributes+backquote = token Backquote++expectBackquote :: Parser a Token Attributes+expectBackquote = backquote <?> "backquote (`) expected"++leftParen :: Parser a Token Attributes+leftParen = token LeftParen++rightParen :: Parser a Token Attributes+rightParen = token RightParen++leftBrace :: Parser a Token Attributes+leftBrace = token LeftBrace++rightBrace :: Parser a Token Attributes+rightBrace = token RightBrace
− src/Curry/Syntax/Parser.lhs 
@@ -1,806 +0,0 @@--% $Id: CurryParser.lhs,v 1.75 2004/02/15 23:11:28 wlux Exp $-%-% Copyright (c) 1999-2004, Wolfgang Lux-% See LICENSE for the full license.-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-%-\nwfilename{CurryParser.lhs}-\section{A Parser for Curry}-The Curry parser is implemented using the (mostly) LL(1) parsing-combinators described in appendix~\ref{sec:ll-parsecomb}.-\begin{verbatim}--> module Curry.Syntax.Parser where--> import Curry.Base.Ident-> import Curry.Base.Position-> import Curry.Base.MessageMonad-> import Curry.Syntax.LLParseComb-> import Curry.Syntax.Type-> import Curry.Syntax.Lexer--> instance Symbol Token where->   isEOF (Token c _) = c == EOF--\end{verbatim}-\paragraph{Modules}-\begin{verbatim}--> parseSource :: Bool -> FilePath -> String -> MsgMonad Module-> parseSource flat path = ->    fmap addSrcRefs . applyParser ( moduleHeader <*> decls flat) lexer path--> parseHeader :: FilePath -> String -> MsgMonad Module-> parseHeader = prefixParser (moduleHeader <*->->                             (leftBrace `opt` undefined) <*>->                             many (importDecl <*-> many semicolon))->                            lexer--> moduleHeader :: Parser Token ([Decl] -> Module) a-> moduleHeader = Module <$-> token KW_module->                       <*> (mIdent <?> "module name expected")->                       <*> ((Just <$> exportSpec) `opt` Nothing)->                       <*-> (token KW_where <?> "where expected")->          `opt` Module mainMIdent Nothing--> exportSpec :: Parser Token ExportSpec a-> exportSpec = Exporting <$> position <*> parens (export `sepBy` comma)--> export :: Parser Token Export a-> export = qtycon <**> (parens spec `opt` Export)->      <|> Export <$> qfun <\> qtycon->      <|> ExportModule <$-> token KW_module <*> mIdent->   where spec = ExportTypeAll <$-> token DotDot->            <|> flip ExportTypeWith <$> con `sepBy` comma--\end{verbatim}-\paragraph{Interfaces}-Since this modified version of MCC uses FlatCurry interfaces instead of-".icurry" files, a separate parser is not required any longer.-\begin{verbatim}--> --parseInterface :: FilePath -> String -> Error Interface-> --parseInterface fn s = applyParser parseIface lexer fn s--> --parseIface :: Parser Token Interface a-> --parseIface = Interface <$-> token Id_interface-> --                       <*> (mIdent <?> "module name expected")-> --                       <*-> (token KW_where <?> "where expected")-> --                       <*> braces intfDecls--\end{verbatim}----\paragraph{Declarations}-\begin{verbatim}--> decls :: Bool -> Parser Token [Decl] a-> decls = layout . globalDecls--> globalDecls :: Bool -> Parser Token [Decl] a-> globalDecls flat =->       (:) <$> importDecl <*> (semicolon <-*> globalDecls flat `opt` [])->   <|> topDecl flat `sepBy` semicolon--> topDecl :: Bool -> Parser Token Decl a-> topDecl flat->   | flat = infixDecl <|> dataDecl flat <|> typeDecl <|> functionDecl flat->   | otherwise = infixDecl->             <|> dataDecl flat <|> newtypeDecl <|> typeDecl->             <|> functionDecl flat <|> externalDecl--> localDefs :: Bool -> Parser Token [Decl] a-> localDefs flat = token KW_where <-*> layout (valueDecls flat)->            `opt` []--> valueDecls :: Bool -> Parser Token [Decl] a-> valueDecls flat = localDecl flat `sepBy` semicolon->   where localDecl flat->           | flat = infixDecl <|> valueDecl flat->           | otherwise = infixDecl <|> valueDecl flat <|> externalDecl--> importDecl :: Parser Token Decl a-> importDecl =->   flip . ImportDecl <$> position <*-> token KW_import ->                     <*> (True <$-> token Id_qualified `opt` False)->                     <*> mIdent->                     <*> (Just <$-> token Id_as <*> mIdent `opt` Nothing)->                     <*> (Just <$> importSpec `opt` Nothing)--> importSpec :: Parser Token ImportSpec a-> importSpec = position <**> (Hiding <$-> token Id_hiding `opt` Importing)->                       <*> parens (spec `sepBy` comma)->   where spec = tycon <**> (parens constrs `opt` Import)->            <|> Import <$> fun <\> tycon->         constrs = ImportTypeAll <$-> token DotDot->               <|> flip ImportTypeWith <$> con `sepBy` comma--> infixDecl :: Parser Token Decl a-> infixDecl = infixDeclLhs InfixDecl <*> funop `sepBy1` comma--> infixDeclLhs :: (Position -> Infix -> Integer -> a) -> Parser Token a b-> infixDeclLhs f = f <$> position <*> tokenOps infixKW <*> integer->   where infixKW = [(KW_infix,Infix),(KW_infixl,InfixL),(KW_infixr,InfixR)]--> dataDecl :: Bool -> Parser Token Decl a-> dataDecl flat = typeDeclLhs DataDecl KW_data <*> constrs->   where constrs = equals <-*> constrDecl flat `sepBy1` bar->             `opt` []--> newtypeDecl :: Parser Token Decl a-> newtypeDecl =->   typeDeclLhs NewtypeDecl KW_newtype <*-> equals <*> newConstrDecl--> typeDecl :: Parser Token Decl a-> typeDecl = typeDeclLhs TypeDecl KW_type <*-> equals <*> typeDeclRhs --type0--> typeDeclLhs :: (Position -> Ident -> [Ident] -> a) -> Category->             -> Parser Token a b-> typeDeclLhs f kw = f <$> position <*-> token kw <*> tycon <*> many typeVar->   where typeVar = tyvar <|> anonId <$-> token Underscore--> typeDeclRhs :: Parser Token TypeExpr a-> typeDeclRhs = type0->	        <|> flip RecordType Nothing->		   <$> (layoutOff <-*> braces (labelDecls `sepBy` comma))--> labelDecls = (,) <$> labId `sepBy1` comma <*-> token DoubleColon <*> type0--> constrDecl :: Bool -> Parser Token ConstrDecl a-> constrDecl flat = position <**> (existVars <**> constr)->   where constr = conId <**> identDecl->              <|> leftParen <-*> parenDecl->              <|> type1 <\> conId <\> leftParen <**> opDecl->         identDecl = many type2 <**> (conType <$> opDecl `opt` conDecl)->         parenDecl = conOpDeclPrefix ->	              <$> conSym <*-> rightParen <*> type2 <*> type2->                 <|> tupleType <*-> rightParen <**> opDecl->         opDecl = conOpDecl <$> conop <*> type1->         conType f tys c = f (ConstructorType (qualify c) tys)->         conDecl tys c tvs p = ConstrDecl p tvs c tys->         conOpDecl op ty2 ty1 tvs p = ConOpDecl p tvs ty1 op ty2->         conOpDeclPrefix op ty1 ty2 tvs p = ConOpDecl p tvs ty1 op ty2--> newConstrDecl :: Parser Token NewConstrDecl a-> newConstrDecl =->   NewConstrDecl <$> position <*> existVars <*> con <*> type2--> existVars :: Parser Token [Ident] a-> {--> existVars flat->   | flat = succeed []->   | otherwise = token Id_forall <-*> many1 tyvar <*-> dot `opt` []-> -}-> existVars = succeed []--> functionDecl :: Bool -> Parser Token Decl a-> functionDecl flat = position <**> decl->   where decl = fun `sepBy1` comma <**> funListDecl flat->           <|?> funDecl <$> lhs <*> declRhs flat->         lhs = (\f -> (f,FunLhs f [])) <$> fun->          <|?> funLhs--> valueDecl :: Bool -> Parser Token Decl a-> valueDecl flat = position <**> decl->   where decl = var `sepBy1` comma <**> valListDecl flat->           <|?> valDecl <$> constrTerm0 <*> declRhs flat->           <|?> funDecl <$> curriedLhs <*> declRhs flat->         valDecl t@(ConstructorPattern c ts)->           | not (isConstrId c) = funDecl (f,FunLhs f ts)->           where f = unqualify c->         valDecl t = opDecl id t->         opDecl f (InfixPattern t1 op t2)->           | isConstrId op = opDecl (f . InfixPattern t1 op) t2->           | otherwise = funDecl (op',OpLhs (f t1) op' t2)->           where op' = unqualify op->         opDecl f t = patDecl (f t)->         isConstrId c = c == qConsId || isQualified c || isQTupleId c--> funDecl :: (Ident,Lhs) -> Rhs -> Position -> Decl-> funDecl (f,lhs) rhs p = FunctionDecl p f [Equation p lhs rhs]--> patDecl :: ConstrTerm -> Rhs -> Position -> Decl-> patDecl t rhs p = PatternDecl p t rhs--> funListDecl :: Bool -> Parser Token ([Ident] -> Position -> Decl) a-> funListDecl flat->   | flat = typeSig <$-> token DoubleColon <*> type0->        <|> evalAnnot <$-> token KW_eval <*> tokenOps evalKW->        <|> externalDecl <$-> token KW_external->   | otherwise = typeSig <$-> token DoubleColon <*> type0->             <|> evalAnnot <$-> token KW_eval <*> tokenOps evalKW->   where typeSig ty vs p = TypeSig p vs ty->         evalAnnot ev vs p = EvalAnnot p vs ev->         evalKW = [(KW_rigid,EvalRigid),(KW_choice,EvalChoice)]->         externalDecl vs p = FlatExternalDecl p vs--> valListDecl :: Bool -> Parser Token ([Ident] -> Position -> Decl) a-> valListDecl flat = funListDecl flat <|> extraVars <$-> token KW_free->   where extraVars vs p = ExtraVariables p vs--> funLhs :: Parser Token (Ident,Lhs) a-> funLhs = funLhs <$> fun <*> many1 constrTerm2->     <|?> flip ($ id) <$> constrTerm1 <*> opLhs'->     <|?> curriedLhs->   where opLhs' = opLhs <$> funSym <*> constrTerm0->              <|> infixPat <$> gConSym <\> funSym <*> constrTerm1 <*> opLhs'->              <|> backquote <-*> opIdLhs->         opIdLhs = opLhs <$> funId <*-> checkBackquote <*> constrTerm0->               <|> infixPat <$> qConId <\> funId <*-> backquote <*> constrTerm1->                            <*> opLhs'->         funLhs f ts = (f,FunLhs f ts)->         opLhs op t2 f t1 = (op,OpLhs (f t1) op t2)->         infixPat op t2 f g t1 = f (g . InfixPattern t1 op) t2--> curriedLhs :: Parser Token (Ident,Lhs) a-> curriedLhs = apLhs <$> parens funLhs <*> many1 constrTerm2->   where apLhs (f,lhs) ts = (f,ApLhs lhs ts)--> declRhs :: Bool -> Parser Token Rhs a-> declRhs flat = rhs flat equals--> rhs :: Bool -> Parser Token a b -> Parser Token Rhs b-> rhs flat eq = rhsExpr <*> localDefs flat->   where rhsExpr = SimpleRhs <$-> eq <*> position <*> expr flat->               <|> GuardedRhs <$> many1 (condExpr flat eq)--> externalDecl :: Parser Token Decl a-> externalDecl =->   ExternalDecl <$> position <*-> token KW_external->                <*> callConv <*> (Just <$> string `opt` Nothing)->                <*> fun <*-> token DoubleColon <*> type0->   where callConv = CallConvPrimitive <$-> token Id_primitive->                <|> CallConvCCall <$-> token Id_ccall->                <?> "Unsupported calling convention"--\end{verbatim}-\paragraph{Interface declarations}-\begin{verbatim}--> --intfDecls :: Parser Token [IDecl] a-> --intfDecls = (:) <$> iImportDecl <*> (semicolon <-*> intfDecls `opt` [])-> --        <|> intfDecl `sepBy` semicolon--> --intfDecl :: Parser Token IDecl a-> --intfDecl = iInfixDecl-> --       <|> iHidingDecl <|> iDataDecl <|> iNewtypeDecl <|> iTypeDecl-> --       <|> iFunctionDecl <\> token Id_hiding--> --iImportDecl :: Parser Token IDecl a-> --iImportDecl = IImportDecl <$> position <*-> token KW_import <*> mIdent--> --iInfixDecl :: Parser Token IDecl a-> --iInfixDecl = infixDeclLhs IInfixDecl <*> qfunop--> --iHidingDecl :: Parser Token IDecl a-> --iHidingDecl = position <*-> token Id_hiding <**> (dataDecl <|> funcDecl)-> --  where dataDecl = hiddenData <$-> token KW_data <*> tycon <*> many tyvar-> --        funcDecl = hidingFunc <$-> token DoubleColon <*> type0-> --        hiddenData tc tvs p = HidingDataDecl p tc tvs-> --        hidingFunc ty p = IFunctionDecl p hidingId ty-> --        hidingId = qualify (mkIdent "hiding")--> --iDataDecl :: Parser Token IDecl a-> --iDataDecl = iTypeDeclLhs IDataDecl KW_data <*> constrs-> --  where constrs = equals <-*> iConstrDecl `sepBy1` bar-> --            `opt` []-> --        iConstrDecl = Just <$> constrDecl False <\> token Underscore-> --                  <|> Nothing <$-> token Underscore--> --iNewtypeDecl :: Parser Token IDecl a-> --iNewtypeDecl =-> --  iTypeDeclLhs INewtypeDecl KW_newtype <*-> equals <*> newConstrDecl--> --iTypeDecl :: Parser Token IDecl a-> --iTypeDecl = iTypeDeclLhs ITypeDecl KW_type <*-> equals <*> type0--> --iTypeDeclLhs :: (Position -> QualIdent -> [Ident] -> a) -> Category-> --             -> Parser Token a b-> --iTypeDeclLhs f kw = f <$> position <*-> token kw <*> qtycon <*> many tyvar--> --iFunctionDecl :: Parser Token IDecl a-> --iFunctionDecl = IFunctionDecl <$> position <*> qfun <*-> token DoubleColon-> --                              <*> type0--\end{verbatim}-\paragraph{Types}-\begin{verbatim}--> type0 :: Parser Token TypeExpr a-> type0 = type1 `chainr1` (ArrowType <$-> token RightArrow)--> type1 :: Parser Token TypeExpr a-> type1 = ConstructorType <$> qtycon <*> many type2->     <|> type2 <\> qtycon--> type2 :: Parser Token TypeExpr a-> type2 = anonType <|> identType <|> parenType <|> listType--> anonType :: Parser Token TypeExpr a-> anonType = VariableType anonId <$-> token Underscore--> identType :: Parser Token TypeExpr a-> identType = VariableType <$> tyvar->         <|> flip ConstructorType [] <$> qtycon <\> tyvar--> parenType :: Parser Token TypeExpr a-> parenType = parens tupleType--> tupleType :: Parser Token TypeExpr a-> tupleType = type0 <??> (tuple <$> many1 (comma <-*> type0))->       `opt` TupleType []->   where tuple tys ty = TupleType (ty:tys)--> listType :: Parser Token TypeExpr a-> listType = ListType <$> brackets type0--\end{verbatim}-\paragraph{Literals}-\begin{verbatim}--> literal :: Parser Token Literal a-> literal = mk Char   <$> char->       <|> mkInt     <$> integer->       <|> mk Float  <$> float->       <|> mk String <$> string--\end{verbatim}-\paragraph{Patterns}-\begin{verbatim}--> constrTerm0 :: Parser Token ConstrTerm a-> constrTerm0 = constrTerm1 `chainr1` (flip InfixPattern <$> gconop)--> constrTerm1 :: Parser Token ConstrTerm a-> constrTerm1 = varId <**> identPattern->	    <|> ConstructorPattern <$> qConId <\> varId <*> many constrTerm2->           <|> minus <**> negNum->           <|> fminus <**> negFloat->           <|> leftParen <-*> parenPattern->           <|> constrTerm2 <\> qConId <\> leftParen->   where identPattern = optAsPattern->                    <|> conPattern <$> many1 constrTerm2->         parenPattern = minus <**> minusPattern negNum->                    <|> fminus <**> minusPattern negFloat->                    <|> gconPattern->                    <|> funSym <\> minus <\> fminus <*-> rightParen->                                                    <**> identPattern->                    <|> parenTuplePattern <\> minus <\> fminus <*-> rightParen->         minusPattern p = rightParen <-*> identPattern->                      <|> parenMinusPattern p <*-> rightParen->         gconPattern = ConstructorPattern <$> gconId <*-> rightParen->                                          <*> many constrTerm2->         conPattern ts = flip ConstructorPattern ts . qualify--> constrTerm2 :: Parser Token ConstrTerm a-> constrTerm2 = literalPattern <|> anonPattern <|> identPattern->           <|> parenPattern <|> listPattern <|> lazyPattern->	    <|> recordPattern--> literalPattern :: Parser Token ConstrTerm a-> literalPattern = LiteralPattern <$> literal--> anonPattern :: Parser Token ConstrTerm a-> anonPattern = VariablePattern anonId <$-> token Underscore--> identPattern :: Parser Token ConstrTerm a-> identPattern = varId <**> optAsPattern->            <|> flip ConstructorPattern [] <$> qConId <\> varId--> parenPattern :: Parser Token ConstrTerm a-> parenPattern = leftParen <-*> parenPattern->   where parenPattern = minus <**> minusPattern negNum->                    <|> fminus <**> minusPattern negFloat->                    <|> flip ConstructorPattern [] <$> gconId <*-> rightParen->                    <|> funSym <\> minus <\> fminus <*-> rightParen->                                                    <**> optAsPattern->                    <|> parenTuplePattern <\> minus <\> fminus <*-> rightParen->         minusPattern p = rightParen <-*> optAsPattern->                      <|> parenMinusPattern p <*-> rightParen--> listPattern :: Parser Token ConstrTerm a-> listPattern = mk' ListPattern <$> brackets (constrTerm0 `sepBy` comma)--> lazyPattern :: Parser Token ConstrTerm a-> lazyPattern = mk LazyPattern <$-> token Tilde <*> constrTerm2--> recordPattern :: Parser Token ConstrTerm a-> recordPattern = layoutOff <-*> braces content->   where->   content = RecordPattern <$> fields <*> record->   fields = fieldPatt `sepBy` comma->   fieldPatt = Field <$> position <*> labId <*-> checkEquals <*> constrTerm0->   record = Just <$-> checkBar <*> constrTerm2 `opt` Nothing--\end{verbatim}-Partial patterns used in the combinators above, but also for parsing-the left-hand side of a declaration.-\begin{verbatim}--> gconId :: Parser Token QualIdent a-> gconId = colon <|> tupleCommas--> negNum,negFloat :: Parser Token (Ident -> ConstrTerm) a-> negNum = flip NegativePattern ->          <$> (mkInt <$> integer <|> mk Float <$> float)-> negFloat = flip NegativePattern . mk Float ->            <$> (fromIntegral <$> integer <|> float)--> optAsPattern :: Parser Token (Ident -> ConstrTerm) a-> optAsPattern = flip AsPattern <$-> token At <*> constrTerm2->          `opt` VariablePattern--> optInfixPattern :: Parser Token (ConstrTerm -> ConstrTerm) a-> optInfixPattern = infixPat <$> gconop <*> constrTerm0->             `opt` id->   where infixPat op t2 t1 = InfixPattern t1 op t2--> optTuplePattern :: Parser Token (ConstrTerm -> ConstrTerm) a-> optTuplePattern = tuple <$> many1 (comma <-*> constrTerm0)->             `opt` ParenPattern->   where tuple ts t = mk TuplePattern (t:ts)--> parenMinusPattern :: Parser Token (Ident -> ConstrTerm) a->                   -> Parser Token (Ident -> ConstrTerm) a-> parenMinusPattern p = p <.> optInfixPattern <.> optTuplePattern--> parenTuplePattern :: Parser Token ConstrTerm a-> parenTuplePattern = constrTerm0 <**> optTuplePattern->               `opt` mk TuplePattern []--\end{verbatim}-\paragraph{Expressions}-\begin{verbatim}--> condExpr :: Bool -> Parser Token a b -> Parser Token CondExpr b-> condExpr flat eq =->   CondExpr <$> position <*-> bar <*> expr0 flat <*-> eq <*> expr flat--> expr :: Bool -> Parser Token Expression a-> expr flat = expr0 flat <??> (flip Typed <$-> token DoubleColon <*> type0)--> expr0 :: Bool -> Parser Token Expression a-> expr0 flat = expr1 flat `chainr1` (flip InfixApply <$> infixOp)--> expr1 :: Bool -> Parser Token Expression a-> expr1 flat = UnaryMinus <$> (minus <|> fminus) <*> expr2 flat->          <|> expr2 flat--> expr2 :: Bool -> Parser Token Expression a-> expr2 flat = lambdaExpr flat <|> letExpr flat <|> doExpr flat->          <|> ifExpr flat <|> caseExpr flat->          <|> expr3 flat <**> applicOrSelect->   where->   applicOrSelect = flip RecordSelection ->	                  <$-> (token RightArrow <?> "-> expected")->			  <*> labId->		 <|?> (\es e -> foldl1 Apply (e:es))->		          <$> many (expr3 flat) --> expr3 :: Bool -> Parser Token Expression a-> expr3 flat = expr3' ->   where->   expr3' = constant <|> variable <|> parenExpr flat->        <|> listExpr flat <|> recordExpr flat--> constant :: Parser Token Expression a-> constant = Literal <$> literal--> variable :: Parser Token Expression a-> variable = Variable <$> qFunId--> parenExpr :: Bool -> Parser Token Expression a-> parenExpr flat = parens pExpr->   where pExpr = (minus <|> fminus) <**> minusOrTuple->             <|> Constructor <$> tupleCommas->             <|> leftSectionOrTuple <\> minus <\> fminus->             <|> opOrRightSection <\> minus <\> fminus->           `opt` mk Tuple []->         minusOrTuple = flip UnaryMinus <$> expr1 flat <.> infixOrTuple->                  `opt` Variable . qualify->         leftSectionOrTuple = expr1 flat <**> infixOrTuple->         infixOrTuple = ($ id) <$> infixOrTuple'->         infixOrTuple' = infixOp <**> leftSectionOrExp->                     <|> (.) <$> (optType <.> tupleExpr)->         leftSectionOrExp = expr1 flat <**> (infixApp <$> infixOrTuple')->                      `opt` leftSection->         optType = flip Typed <$-> token DoubleColon <*> type0->             `opt` id->         tupleExpr = tuple <$> many1 (comma <-*> expr flat)->               `opt` Paren->         opOrRightSection = qFunSym <**> optRightSection->                        <|> colon <**> optCRightSection->                        <|> infixOp <\> colon <\> qFunSym <**> rightSection->         optRightSection = (. InfixOp) <$> rightSection `opt` Variable->         optCRightSection = (. InfixConstr) <$> rightSection `opt` Constructor->         rightSection = flip RightSection <$> expr0 flat->         infixApp f e2 op g e1 = f (g . InfixApply e1 op) e2->         leftSection op f e = LeftSection (f e) op->         tuple es e = mk Tuple (e:es)--> infixOp :: Parser Token InfixOp a-> infixOp = InfixOp <$> qfunop->       <|> InfixConstr <$> colon--> listExpr :: Bool -> Parser Token Expression a-> listExpr flat = brackets (elements `opt` mk' List [])->   where elements = expr flat <**> rest->         rest = comprehension->            <|> enumeration (flip EnumFromTo) EnumFrom->            <|> comma <-*> expr flat <**>->                (enumeration (flip3 EnumFromThenTo) (flip EnumFromThen)->                <|> list <$> many (comma <-*> expr flat))->          `opt` (\e -> mk' List [e])->         comprehension = flip (mk ListCompr) <$-> bar <*> quals flat->         enumeration enumTo enum =->           token DotDot <-*> (enumTo <$> expr flat `opt` enum)->         list es e2 e1 = mk' List (e1:e2:es)->         flip3 f x y z = f z y x--> recordExpr :: Bool -> Parser Token Expression a-> recordExpr flat = layoutOff <-*> braces content->   where content = RecordConstr <$> fieldConstr `sepBy` comma->	            <|?> RecordUpdate <$> fieldUpdate `sepBy` comma->		                      <*-> checkBar <*> expr flat->	  fieldConstr = Field <$> position <*> labId ->		              <*-> checkEquals <*> expr flat->	  fieldUpdate = Field <$> position <*> labId ->		              <*-> checkBinds <*> expr flat--> lambdaExpr :: Bool -> Parser Token Expression a-> lambdaExpr flat =->   mk Lambda <$-> token Backslash <*> many1 constrTerm2->          <*-> (token RightArrow <?> "-> expected") <*> expr flat--> letExpr :: Bool -> Parser Token Expression a-> letExpr flat = Let <$-> token KW_let <*> layout (valueDecls flat)->                    <*-> (token KW_in <?> "in expected") <*> expr flat--> doExpr :: Bool -> Parser Token Expression a-> doExpr flat = uncurry Do <$-> token KW_do <*> layout (stmts flat)--> ifExpr :: Bool -> Parser Token Expression a-> ifExpr flat =->   mk IfThenElse <$-> token KW_if <*> expr flat->              <*-> (token KW_then <?> "then expected") <*> expr flat->              <*-> (token KW_else <?> "else expected") <*> expr flat--> caseExpr :: Bool -> Parser Token Expression a-> caseExpr flat = mk Case <$-> token KW_case <*> expr flat->                 <*-> (token KW_of <?> "of expected") <*> layout (alts flat)--> alts :: Bool -> Parser Token [Alt] a-> alts flat = alt flat `sepBy1` semicolon--> alt :: Bool -> Parser Token Alt a-> alt flat = Alt <$> position <*> constrTerm0->                <*> rhs flat (token RightArrow <?> "-> expected")--\end{verbatim}-\paragraph{Statements in list comprehensions and \texttt{do} expressions}-Parsing statements is a bit difficult because the syntax of patterns-and expressions largely overlaps. The parser will first try to-recognize the prefix \emph{Pattern}~\texttt{<-} of a binding statement-and if this fails fall back into parsing an expression statement. In-addition, we have to be prepared that the sequence-\texttt{let}~\emph{LocalDefs} can be either a let-statement or the-prefix of a let expression.-\begin{verbatim}--> stmts :: Bool -> Parser Token ([Statement],Expression) a-> stmts flat = stmt flat (reqStmts flat) (optStmts flat)--> reqStmts :: Bool -> Parser Token (Statement -> ([Statement],Expression)) a-> reqStmts flat = (\(sts,e) st -> (st : sts,e)) <$-> semicolon <*> stmts flat--> optStmts :: Bool -> Parser Token (Expression -> ([Statement],Expression)) a-> optStmts flat = succeed (mk StmtExpr) <.> reqStmts flat->           `opt` (,) []--> quals :: Bool -> Parser Token [Statement] a-> quals flat = stmt flat (succeed id) (succeed $ mk StmtExpr) `sepBy1` comma--> stmt :: Bool -> Parser Token (Statement -> a) b->      -> Parser Token (Expression -> a) b -> Parser Token a b-> stmt flat stmtCont exprCont = letStmt flat stmtCont exprCont->                           <|> exprOrBindStmt flat stmtCont exprCont--> letStmt :: Bool -> Parser Token (Statement -> a) b->         -> Parser Token (Expression -> a) b -> Parser Token a b-> letStmt flat stmtCont exprCont =->   token KW_let <-*> layout (valueDecls flat) <**> optExpr->   where optExpr = flip Let <$-> token KW_in <*> expr flat <.> exprCont->               <|> succeed StmtDecl <.> stmtCont--> exprOrBindStmt :: Bool -> Parser Token (Statement -> a) b->                -> Parser Token (Expression -> a) b->                -> Parser Token a b-> exprOrBindStmt flat stmtCont exprCont =->        mk StmtBind <$> constrTerm0 <*-> leftArrow <*> expr flat <**> stmtCont->   <|?> expr flat <\> token KW_let <**> exprCont--\end{verbatim}-\paragraph{Literals, identifiers, and (infix) operators}-\begin{verbatim}--> char :: Parser Token Char a-> char = cval <$> token CharTok--> int, checkInt :: Parser Token Int a-> int = ival <$> token IntTok-> checkInt = int <?> "integer number expected"--> float, checkFloat :: Parser Token Double a-> float = fval <$> token FloatTok-> checkFloat = float <?> "floating point number expected"--> integer, checkInteger :: Parser Token Integer a-> integer = intval <$> token IntegerTok-> checkInteger = integer <?> "integer number expected"--> string :: Parser Token String a-> string = sval <$> token StringTok--> tycon, tyvar :: Parser Token Ident a-> tycon = conId-> tyvar = varId--> qtycon :: Parser Token QualIdent a-> qtycon = qConId--> varId, funId, conId, labId :: Parser Token Ident a-> varId = ident-> funId = ident-> conId = ident-> labId = renameLabel <$> ident--> funSym, conSym :: Parser Token Ident a-> funSym = sym-> conSym = sym--> var, fun, con :: Parser Token Ident a-> var = varId <|> parens (funSym <?> "operator symbol expected")-> fun = funId <|> parens (funSym <?> "operator symbol expected")-> con = conId <|> parens (conSym <?> "operator symbol expected")--> funop, conop :: Parser Token Ident a-> funop = funSym <|> backquotes (funId <?> "operator name expected")-> conop = conSym <|> backquotes (conId <?> "operator name expected")--> qFunId, qConId, qLabId :: Parser Token QualIdent a-> qFunId = qIdent-> qConId = qIdent-> qLabId = qIdent--> qFunSym, qConSym :: Parser Token QualIdent a-> qFunSym = qSym-> qConSym = qSym-> gConSym = qConSym <|> colon--> qfun, qcon :: Parser Token QualIdent a-> qfun = qFunId <|> parens (qFunSym <?> "operator symbol expected")-> qcon = qConId <|> parens (qConSym <?> "operator symbol expected")--> qfunop, qconop, gconop :: Parser Token QualIdent a-> qfunop = qFunSym <|> backquotes (qFunId <?> "operator name expected")-> qconop = qConSym <|> backquotes (qConId <?> "operator name expected")-> gconop = gConSym <|> backquotes (qConId <?> "operator name expected")--> ident :: Parser Token Ident a-> ident = (\ pos -> mkIdentPosition pos . sval) <$> position <*> ->        tokens [Id,Id_as,Id_ccall,Id_forall,Id_hiding,->                Id_interface,Id_primitive,Id_qualified]--> qIdent :: Parser Token QualIdent a-> qIdent = qualify <$> ident <|> mkQIdent <$> position <*> token QId->   where mkQIdent p a = qualifyWith (mkMIdent (modul a)) ->                                    (mkIdentPosition p (sval a))--> mIdent :: Parser Token ModuleIdent a-> mIdent = mIdent <$> position <*> ->      tokens [Id,QId,Id_as,Id_ccall,Id_forall,Id_hiding,->              Id_interface,Id_primitive,Id_qualified]->   where mIdent p a = addPositionModuleIdent p $ ->                      mkMIdent (modul a ++ [sval a])--> sym :: Parser Token Ident a-> sym = (\ pos -> mkIdentPosition pos . sval) <$> position <*> ->       tokens [Sym,Sym_Dot,Sym_Minus,Sym_MinusDot]--> qSym :: Parser Token QualIdent a-> qSym = qualify <$> sym <|> mkQIdent <$> position <*> token QSym->   where mkQIdent p a = qualifyWith (mkMIdent (modul a)) ->                                    (mkIdentPosition p (sval a))--> colon :: Parser Token QualIdent a-> colon = (\ p _ -> qualify $ addPositionIdent p consId) <$> ->         position <*> token Colon--> minus :: Parser Token Ident a-> minus = (\ p _ -> addPositionIdent p minusId) <$> ->         position <*> token Sym_Minus--> fminus :: Parser Token Ident a-> fminus = (\ p _ -> addPositionIdent p fminusId) <$> ->         position <*> token Sym_MinusDot--> tupleCommas :: Parser Token QualIdent a-> tupleCommas = (\ p -> qualify . addPositionIdent p . tupleId . succ . length )->               <$> position <*> many1 comma--\end{verbatim}-\paragraph{Layout}-\begin{verbatim}--> layout :: Parser Token a b -> Parser Token a b-> layout p = layoutOff <-*> bracket leftBraceSemicolon p rightBrace->        <|> layoutOn <-*> p <*-> (token VRightBrace <|> layoutEnd)--\end{verbatim}-\paragraph{More combinators}-\begin{verbatim}--> braces, brackets, parens, backquotes :: Parser Token a b -> Parser Token a b-> braces p = bracket leftBrace p rightBrace-> brackets p = bracket leftBracket p rightBracket-> parens p = bracket leftParen p rightParen-> backquotes p = bracket backquote p checkBackquote--\end{verbatim}-\paragraph{Simple token parsers}-\begin{verbatim}--> token :: Category -> Parser Token Attributes a-> token c = attr <$> symbol (Token c NoAttributes)->   where attr (Token _ a) = a--> tokens :: [Category] -> Parser Token Attributes a-> tokens = foldr1 (<|>) . map token--> tokenOps :: [(Category,a)] -> Parser Token a b-> tokenOps cs = ops [(Token c NoAttributes,x) | (c,x) <- cs]--> dot, comma, semicolon, bar, equals, binds :: Parser Token Attributes a-> dot = token Sym_Dot-> comma = token Comma-> semicolon = token Semicolon <|> token VSemicolon-> bar = token Bar-> equals = token Equals-> binds = token Binds--> checkBar, checkEquals, checkBinds :: Parser Token Attributes a-> checkBar = bar <?> "| expected"-> checkEquals = equals <?> "= expected"-> checkBinds = binds <?> ":= expected"--> backquote, checkBackquote :: Parser Token Attributes a-> backquote = token Backquote-> checkBackquote = backquote <?> "backquote (`) expected"--> leftParen, rightParen :: Parser Token Attributes a-> leftParen = token LeftParen-> rightParen = token RightParen--> leftBracket, rightBracket :: Parser Token Attributes a-> leftBracket = token LeftBracket-> rightBracket = token RightBracket--> leftBrace, leftBraceSemicolon, rightBrace :: Parser Token Attributes a-> leftBrace = token LeftBrace-> leftBraceSemicolon = token LeftBraceSemicolon-> rightBrace = token RightBrace--> leftArrow :: Parser Token Attributes a-> leftArrow = token LeftArrow--\end{verbatim}-\paragraph{Ident}-\begin{verbatim}--> mkIdentPosition :: Position -> String -> Ident-> mkIdentPosition pos = addPositionIdent pos . mkIdent--\end{verbatim}
+ src/Curry/Syntax/Pretty.hs view
@@ -0,0 +1,463 @@+{- |+    Module      :  $Header$+    Description :  A pretty printer for Curry+    Copyright   :  (c) 1999 - 2004 Wolfgang Lux+                       2005        Martin Engelke+                       2011 - 2015 Björn Peemöller+                       2016        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module implements a pretty printer for Curry expressions. It was+    derived from the Haskell pretty printer provided in Simon Marlow's+    Haskell parser.+-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Curry.Syntax.Pretty+  ( pPrint, pPrintPrec, ppContext, ppInstanceType, ppIMethodImpl+  , ppIdent, ppQIdent, ppInfixOp, ppQInfixOp, ppMIdent+  ) where++import Prelude hiding ((<>))++import Curry.Base.Ident+import Curry.Base.Pretty++import Curry.Syntax.Type+import Curry.Syntax.Utils (opName)++instance Pretty (Module a) where+  pPrint (Module _ _ ps m es is ds) = ppModuleHeader ps m es is $$ ppSepBlock ds++ppModuleHeader :: [ModulePragma] -> ModuleIdent -> Maybe ExportSpec+               -> [ImportDecl] -> Doc+ppModuleHeader ps m es is+  | null is   = header+  | otherwise = header $+$ text "" $+$ vcat (map pPrint is)+  where header = vcat (map pPrint ps)+                 $+$ text "module" <+> ppMIdent m+                 <+> maybePP pPrint es <+> text "where"++instance Pretty ModulePragma where+  pPrint (LanguagePragma _      exts) =+    ppPragma "LANGUAGE" $ list $ map pPrint exts+  pPrint (OptionsPragma  _ tool args) =+    ppPragma "OPTIONS" $ maybe empty ((text "_" <>) . pPrint) tool <+> text args++ppPragma :: String -> Doc -> Doc+ppPragma kw doc = text "{-#" <+> text kw <+> doc <+> text "#-}"++instance Pretty Extension where+  pPrint (KnownExtension   _ e) = text (show e)+  pPrint (UnknownExtension _ e) = text e++instance Pretty Tool where+  pPrint (UnknownTool t) = text t+  pPrint t               = text (show t)++instance Pretty ExportSpec where+  pPrint (Exporting _ es) = parenList (map pPrint es)++instance Pretty Export where+  pPrint (Export             _ x) = ppQIdent x+  pPrint (ExportTypeWith _ tc cs) = ppQIdent tc <> parenList (map ppIdent cs)+  pPrint (ExportTypeAll     _ tc) = ppQIdent tc <> text "(..)"+  pPrint (ExportModule       _ m) = text "module" <+> ppMIdent m++instance Pretty ImportDecl where+  pPrint (ImportDecl _ m q asM is) =+    text "import" <+> ppQualified q <+> ppMIdent m <+> maybePP ppAs asM+                  <+> maybePP pPrint is+    where+      ppQualified q' = if q' then text "qualified" else empty+      ppAs m' = text "as" <+> ppMIdent m'++instance Pretty ImportSpec where+  pPrint (Importing _ is) = parenList (map pPrint is)+  pPrint (Hiding    _ is) = text "hiding" <+> parenList (map pPrint is)++instance Pretty Import where+  pPrint (Import             _ x) = ppIdent x+  pPrint (ImportTypeWith _ tc cs) = ppIdent tc <> parenList (map ppIdent cs)+  pPrint (ImportTypeAll     _ tc) = ppIdent tc <> text "(..)"++ppBlock :: Pretty a => [a] -> Doc+ppBlock = vcat . map pPrint++ppSepBlock :: Pretty a => [a] -> Doc+ppSepBlock = vcat . map (\d -> text "" $+$ pPrint d)++instance Pretty (Decl a) where+  pPrint (InfixDecl _ fix p ops) = ppPrec fix p <+> list (map ppInfixOp ops)+  pPrint (DataDecl _ tc tvs cs clss) =+    sep (ppTypeDeclLhs "data" tc tvs :+      map indent (zipWith (<+>) (equals : repeat vbar) (map pPrint cs) +++                   [ppDeriving clss]))+  pPrint (ExternalDataDecl _ tc tvs) = ppTypeDeclLhs "external data" tc tvs+  pPrint (NewtypeDecl _ tc tvs nc clss) =+    sep (ppTypeDeclLhs "newtype" tc tvs <+> equals :+      map indent [pPrint nc, ppDeriving clss])+  pPrint (TypeDecl _ tc tvs ty) =+    sep [ppTypeDeclLhs "type" tc tvs <+> equals,indent (pPrintPrec 0 ty)]+  pPrint (TypeSig _ fs ty) =+    list (map ppIdent fs) <+> text "::" <+> pPrintPrec 0 ty+  pPrint (FunctionDecl _ _ _ eqs) = vcat (map pPrint eqs)+  pPrint (ExternalDecl   _ vs) = list (map pPrint vs) <+> text "external"+  pPrint (PatternDecl _ t rhs) = ppRule (pPrintPrec 0 t) equals rhs+  pPrint (FreeDecl       _ vs) = list (map pPrint vs) <+> text "free"+  pPrint (DefaultDecl   _ tys) =+    text "default" <+> parenList (map (pPrintPrec 0) tys)+  pPrint (ClassDecl _ _ cx cls clsvar ds) =+    ppClassInstHead "class" cx (ppIdent cls) (ppIdent clsvar) <+>+      ppIf (not $ null ds) (text "where") $$+      ppIf (not $ null ds) (indent $ ppBlock ds)+  pPrint (InstanceDecl _ _ cx qcls inst ds) =+    ppClassInstHead "instance" cx (ppQIdent qcls) (ppInstanceType inst) <+>+      ppIf (not $ null ds) (text "where") $$+      ppIf (not $ null ds) (indent $ ppBlock ds)++ppClassInstHead :: String -> Context -> Doc -> Doc -> Doc+ppClassInstHead kw cx cls ty = text kw <+> ppContext cx <+> cls <+> ty++ppContext :: Context -> Doc+ppContext []  = empty+ppContext [c] = pPrint c <+> darrow+ppContext cs  = parenList (map pPrint cs) <+> darrow++instance Pretty Constraint where+  pPrint (Constraint _ qcls ty) = ppQIdent qcls <+> pPrintPrec 2 ty++ppInstanceType :: InstanceType -> Doc+ppInstanceType = pPrintPrec 2++ppDeriving :: [QualIdent] -> Doc+ppDeriving []     = empty+ppDeriving [qcls] = text "deriving" <+> ppQIdent qcls+ppDeriving qclss  = text "deriving" <+> parenList (map ppQIdent qclss)++ppPrec :: Infix -> Maybe Precedence -> Doc+ppPrec fix p = pPrint fix <+> ppPrio p+  where+    ppPrio Nothing   = empty+    ppPrio (Just p') = integer p'++ppTypeDeclLhs :: String -> Ident -> [Ident] -> Doc+ppTypeDeclLhs kw tc tvs = text kw <+> ppIdent tc <+> hsep (map ppIdent tvs)++instance Pretty ConstrDecl where+  pPrint (ConstrDecl     _ c tys) =+    sep [ ppIdent c <+> fsep (map (pPrintPrec 2) tys) ]+  pPrint (ConOpDecl _ ty1 op ty2) =+    sep [ pPrintPrec 1 ty1, ppInfixOp op <+> pPrintPrec 1 ty2 ]+  pPrint (RecordDecl _ c fs)      =+    sep [ ppIdent c <+> record (list (map pPrint fs)) ]++instance Pretty FieldDecl where+  pPrint (FieldDecl _ ls ty) = list (map ppIdent ls)+                            <+> text "::" <+> pPrintPrec 0 ty++instance Pretty NewConstrDecl where+  pPrint (NewConstrDecl _ c ty) = sep [ppIdent c <+> pPrintPrec 2 ty]+  pPrint (NewRecordDecl _ c (i,ty)) =+    sep [ppIdent c <+> record (ppIdent i <+> text "::" <+> pPrintPrec 0 ty)]++ppQuantifiedVars :: [Ident] -> Doc+ppQuantifiedVars tvs+  | null tvs = empty+  | otherwise = text "forall" <+> hsep (map ppIdent tvs) <+> char '.'++instance Pretty (Equation a) where+  pPrint (Equation _ lhs rhs) = ppRule (pPrint lhs) equals rhs++instance Pretty (Lhs a) where+  pPrint (FunLhs   _ f ts) =+    ppIdent f <+> fsep (map (pPrintPrec 2) ts)+  pPrint (OpLhs _ t1 f t2) =+    pPrintPrec 1 t1 <+> ppInfixOp f <+> pPrintPrec 1 t2+  pPrint (ApLhs  _ lhs ts) =+    parens (pPrint lhs) <+> fsep (map (pPrintPrec 2) ts)++ppRule :: Doc -> Doc -> Rhs a -> Doc+ppRule lhs eq (SimpleRhs _ _ e ds) =+  sep [lhs <+> eq, indent (pPrintPrec 0 e)] $$ ppLocalDefs ds+ppRule lhs eq (GuardedRhs _ _ es ds) =+  sep [lhs, indent (vcat (map (ppCondExpr eq) es))] $$ ppLocalDefs ds++ppLocalDefs :: [Decl a] -> Doc+ppLocalDefs ds+  | null ds   = empty+  | otherwise = indent (text "where" <+> ppBlock ds)++-- ---------------------------------------------------------------------------+-- Interfaces+-- ---------------------------------------------------------------------------++instance Pretty Interface where+  pPrint (Interface m is ds) =+    text "interface" <+> ppMIdent m <+> text "where" <+> lbrace+      $$ vcat (punctuate semi $ map pPrint is ++ map pPrint ds)+      $$ rbrace++instance Pretty IImportDecl where+  pPrint (IImportDecl _ m) = text "import" <+> ppMIdent m++instance Pretty IDecl where+  pPrint (IInfixDecl   _ fix p op) = ppPrec fix (Just p) <+> ppQInfixOp op+  pPrint (HidingDataDecl _ tc k tvs) =+    text "hiding" <+> ppITypeDeclLhs "data" tc k tvs+  pPrint (IDataDecl   _ tc k tvs cs hs) =+    sep (ppITypeDeclLhs "data" tc k tvs :+      map indent (zipWith (<+>) (equals : repeat vbar) (map pPrint cs)) +++      [indent (ppHiding hs)])+  pPrint (INewtypeDecl _ tc k tvs nc hs) =+    sep [ ppITypeDeclLhs "newtype" tc k tvs <+> equals+        , indent (pPrint nc)+        , indent (ppHiding hs)+        ]+  pPrint (ITypeDecl _ tc k tvs ty) =+    sep [ppITypeDeclLhs "type" tc k tvs <+> equals,indent (pPrintPrec 0 ty)]+  pPrint (IFunctionDecl _ f cm a ty) =+    sep [ ppQIdent f, maybePP (ppPragma "METHOD" . ppIdent) cm+        , int a, text "::", pPrintPrec 0 ty ]+  pPrint (HidingClassDecl _ cx qcls k clsvar) = text "hiding" <+>+    ppClassInstHead "class" cx (ppQIdentWithKind qcls k) (ppIdent clsvar)+  pPrint (IClassDecl _ cx qcls k clsvar ms hs) =+    ppClassInstHead "class" cx (ppQIdentWithKind qcls k) (ppIdent clsvar) <+>+      lbrace $$+      vcat (punctuate semi $ map (indent . pPrint) ms) $$+      rbrace <+> ppHiding hs+  pPrint (IInstanceDecl _ cx qcls inst impls m) =+    ppClassInstHead "instance" cx (ppQIdent qcls) (ppInstanceType inst) <+>+      lbrace $$+      vcat (punctuate semi $ map (indent . ppIMethodImpl) impls) $$+      rbrace <+> maybePP (ppPragma "MODULE" . ppMIdent) m++ppITypeDeclLhs :: String -> QualIdent -> Maybe KindExpr -> [Ident] -> Doc+ppITypeDeclLhs kw tc k tvs =+  text kw <+> ppQIdentWithKind tc k <+> hsep (map ppIdent tvs)++instance Pretty IMethodDecl where+  pPrint (IMethodDecl _ f a qty) =+    ppIdent f <+> maybePP int a <+> text "::" <+> pPrintPrec 0 qty++ppIMethodImpl :: IMethodImpl -> Doc+ppIMethodImpl (f, a) = ppIdent f <+> int a++ppQIdentWithKind :: QualIdent -> Maybe KindExpr -> Doc+ppQIdentWithKind tc (Just k) =+  parens $ ppQIdent tc <+> text "::" <+> pPrintPrec 0 k+ppQIdentWithKind tc Nothing  = ppQIdent tc++ppHiding :: [Ident] -> Doc+ppHiding hs+  | null hs   = empty+  | otherwise = ppPragma "HIDING" $ list $ map ppIdent hs++-- ---------------------------------------------------------------------------+-- Kinds+-- ---------------------------------------------------------------------------++instance Pretty KindExpr where+  pPrintPrec _ Star              = char '*'+  pPrintPrec p (ArrowKind k1 k2) =+    parenIf (p > 0) (fsep (ppArrowKind (ArrowKind k1 k2)))+    where+      ppArrowKind (ArrowKind k1' k2') =+        pPrintPrec 1 k1' <+> rarrow : ppArrowKind k2'+      ppArrowKind k =+        [pPrintPrec 0 k]++-- ---------------------------------------------------------------------------+-- Types+-- ---------------------------------------------------------------------------++instance Pretty QualTypeExpr where+  pPrint (QualTypeExpr _ cx ty) = ppContext cx <+> pPrintPrec 0 ty++instance Pretty TypeExpr where+  pPrintPrec _ (ConstructorType _ tc) = ppQIdent tc+  pPrintPrec p (ApplyType  _ ty1 ty2) = parenIf (p > 1) (ppApplyType ty1 [ty2])+     where+      ppApplyType (ApplyType _ ty1' ty2') tys =+        ppApplyType ty1' (ty2' : tys)+      ppApplyType ty                      tys =+        pPrintPrec 1 ty <+> fsep (map (pPrintPrec 2) tys)+  pPrintPrec _ (VariableType    _ tv) = ppIdent tv+  pPrintPrec _ (TupleType      _ tys) = parenList (map (pPrintPrec 0) tys)+  pPrintPrec _ (ListType        _ ty) = brackets (pPrintPrec 0 ty)+  pPrintPrec p (ArrowType  spi ty1 ty2) = parenIf (p > 0)+    (fsep (ppArrowType (ArrowType spi ty1 ty2)))+    where+      ppArrowType (ArrowType _ ty1' ty2') =+        pPrintPrec 1 ty1' <+> rarrow : ppArrowType ty2'+      ppArrowType ty                      =+        [pPrintPrec 0 ty]+  pPrintPrec _ (ParenType       _ ty) = parens (pPrintPrec 0 ty)+  pPrintPrec p (ForallType   _ vs ty)+    | null vs   = pPrintPrec p ty+    | otherwise = parenIf (p > 0) $ ppQuantifiedVars vs <+> pPrintPrec 0 ty++-- ---------------------------------------------------------------------------+-- Literals+-- ---------------------------------------------------------------------------++instance Pretty Literal where+  pPrint (Char   c) = text (show c)+  pPrint (Int    i) = integer i+  pPrint (Float  f) = double f+  pPrint (String s) = text (show s)++-- ---------------------------------------------------------------------------+-- Patterns+-- ---------------------------------------------------------------------------++instance Pretty (Pattern a) where+  pPrintPrec p (LiteralPattern _ _ l) =+    parenIf (p > 1 && isNegative l) (pPrint l)+    where+      isNegative (Char   _) = False+      isNegative (Int    i) = i < 0+      isNegative (Float  f) = f < 0.0+      isNegative (String _) = False+  pPrintPrec p (NegativePattern        _ _ l) = parenIf (p > 1)+    (ppInfixOp minusId <> pPrint l)+  pPrintPrec _ (VariablePattern        _ _ v) = ppIdent v+  pPrintPrec p (ConstructorPattern  _ _ c ts) = parenIf (p > 1 && not (null ts))+    (ppQIdent c <+> fsep (map (pPrintPrec 2) ts))+  pPrintPrec p (InfixPattern     _ _ t1 c t2) = parenIf (p > 0)+    (sep [pPrintPrec 1 t1 <+> ppQInfixOp c, indent (pPrintPrec 0 t2)])+  pPrintPrec _ (ParenPattern             _ t) = parens (pPrintPrec 0 t)+  pPrintPrec _ (TuplePattern            _ ts) =+    parenList (map (pPrintPrec 0) ts)+  pPrintPrec _ (ListPattern           _ _ ts) =+    bracketList (map (pPrintPrec 0) ts)+  pPrintPrec _ (AsPattern              _ v t) =+    ppIdent v <> char '@' <> pPrintPrec 2 t+  pPrintPrec _ (LazyPattern              _ t) = char '~' <> pPrintPrec 2 t+  pPrintPrec p (FunctionPattern     _ _ f ts) = parenIf (p > 1 && not (null ts))+    (ppQIdent f <+> fsep (map (pPrintPrec 2) ts))+  pPrintPrec p (InfixFuncPattern _ _ t1 f t2) = parenIf (p > 0)+    (sep [pPrintPrec 1 t1 <+> ppQInfixOp f, indent (pPrintPrec 0 t2)])+  pPrintPrec p (RecordPattern       _ _ c fs) = parenIf (p > 1)+    (ppQIdent c <+> record (list (map pPrint fs)))++instance Pretty a => Pretty (Field a) where+  pPrint (Field _ l t) = ppQIdent l <+> equals <+> pPrintPrec 0 t++-- ---------------------------------------------------------------------------+-- Expressions+-- ---------------------------------------------------------------------------++ppCondExpr :: Doc -> CondExpr a -> Doc+ppCondExpr eq (CondExpr _ g e) =+  vbar <+> sep [pPrintPrec 0 g <+> eq, indent (pPrintPrec 0 e)]++instance Pretty (Expression a) where+  pPrintPrec _ (Literal        _ _ l) = pPrint l+  pPrintPrec _ (Variable       _ _ v) = ppQIdent v+  pPrintPrec _ (Constructor    _ _ c) = ppQIdent c+  pPrintPrec _ (Paren            _ e) = parens (pPrintPrec 0 e)+  pPrintPrec p (Typed        _ e ty)  =+    parenIf (p > 0) (pPrintPrec 0 e <+> text "::" <+> pPrintPrec 0 ty)+  pPrintPrec _ (Tuple           _ es) = parenList (map (pPrintPrec 0) es)+  pPrintPrec _ (List          _ _ es) = bracketList (map (pPrintPrec 0) es)+  pPrintPrec _ (ListCompr     _ e qs) =+    brackets (pPrintPrec 0 e <+> vbar <+> list (map pPrint qs))+  pPrintPrec _ (EnumFrom              _ e) =+    brackets (pPrintPrec 0 e <+> text "..")+  pPrintPrec _ (EnumFromThen      _ e1 e2) =+    brackets (pPrintPrec 0 e1 <> comma <+> pPrintPrec 0 e2 <+> text "..")+  pPrintPrec _ (EnumFromTo        _ e1 e2) =+    brackets (pPrintPrec 0 e1 <+> text ".." <+> pPrintPrec 0 e2)+  pPrintPrec _ (EnumFromThenTo _ e1 e2 e3) =+    brackets (pPrintPrec 0 e1 <> comma <+> pPrintPrec 0 e2+      <+> text ".." <+> pPrintPrec 0 e3)+  pPrintPrec p (UnaryMinus          _ e) =+    parenIf (p > 1) (ppInfixOp minusId <> pPrintPrec 1 e)+  pPrintPrec p (Apply           _ e1 e2) =+    parenIf (p > 1) (sep [pPrintPrec 1 e1, indent (pPrintPrec 2 e2)])+  pPrintPrec p (InfixApply   _ e1 op e2) = parenIf (p > 0)+    (sep [pPrintPrec 1 e1 <+> ppQInfixOp (opName op), indent (pPrintPrec 1 e2)])+  pPrintPrec _ (LeftSection      _ e op) =+    parens (pPrintPrec 1 e <+> ppQInfixOp (opName op))+  pPrintPrec _ (RightSection     _ op e) =+    parens (ppQInfixOp (opName op) <+> pPrintPrec 1 e)+  pPrintPrec p (Lambda            _ t e) = parenIf (p > 0) $+    sep [backsl <> fsep (map (pPrintPrec 2) t) <+> rarrow,+         indent (pPrintPrec 0 e)]+  pPrintPrec p (Let            _ _ ds e) = parenIf (p > 0)+    (sep [text "let" <+> ppBlock ds, text "in" <+> pPrintPrec 0 e])+  pPrintPrec p (Do            _ _ sts e) = parenIf (p > 0)+    (text "do" <+> (vcat (map pPrint sts) $$ pPrintPrec 0 e))+  pPrintPrec p (IfThenElse   _ e1 e2 e3) = parenIf (p > 0)+    (text "if" <+>+     sep [pPrintPrec 0 e1,+          text "then" <+> pPrintPrec 0 e2,+          text "else" <+> pPrintPrec 0 e3])+  pPrintPrec p (Case    _ _ ct e alts) = parenIf (p > 0)+           (pPrint ct <+> pPrintPrec 0 e <+> text "of" $$+            indent (vcat (map pPrint alts)))+  pPrintPrec p (Record     _ _ c fs) = parenIf (p > 0)+    (ppQIdent c <+> record (list (map pPrint fs)))+  pPrintPrec _ (RecordUpdate _ e fs) =+    pPrintPrec 0 e <+> record (list (map pPrint fs))++instance Pretty (Statement a) where+  pPrint (StmtExpr   _ e) = pPrintPrec 0 e+  pPrint (StmtBind _ t e) =+    sep [pPrintPrec 0 t <+> larrow, indent (pPrintPrec 0 e)]+  pPrint (StmtDecl  _ _ ds) = text "let" <+> ppBlock ds++instance Pretty CaseType where+  pPrint Rigid = text "case"+  pPrint Flex  = text "fcase"++instance Pretty (Alt a) where+  pPrint (Alt _ t rhs) = ppRule (pPrintPrec 0 t) rarrow rhs++instance Pretty (Var a) where+  pPrint (Var _ ident) = ppIdent ident++instance Pretty (InfixOp a) where+  pPrint (InfixOp     _ op) = ppQInfixOp op+  pPrint (InfixConstr _ op) = ppQInfixOp op++-- ---------------------------------------------------------------------------+-- Names+-- ---------------------------------------------------------------------------++-- |Pretty print an identifier+ppIdent :: Ident -> Doc+ppIdent x = parenIf (isInfixOp x) (text (idName x))++ppQIdent :: QualIdent -> Doc+ppQIdent x = parenIf (isQInfixOp x) (text (qualName x))++ppInfixOp :: Ident -> Doc+ppInfixOp x = bquotesIf (not (isInfixOp x)) (text (idName x))++ppQInfixOp :: QualIdent -> Doc+ppQInfixOp x = bquotesIf (not (isQInfixOp x)) (text (qualName x))++ppMIdent :: ModuleIdent -> Doc+ppMIdent m = text (moduleName m)++-- ---------------------------------------------------------------------------+-- Print printing utilities+-- ---------------------------------------------------------------------------++indent :: Doc -> Doc+indent = nest 2++parenList :: [Doc] -> Doc+parenList = parens . list++record :: Doc -> Doc+record doc | isEmpty doc = braces empty+           | otherwise   = braces $ space <> doc <> space++bracketList :: [Doc] -> Doc+bracketList = brackets . list
− src/Curry/Syntax/Pretty.lhs 
@@ -1,368 +0,0 @@--% $Id: CurryPP.lhs,v 1.50 2004/02/15 22:10:27 wlux Exp $-%-% Copyright (c) 1999-2004, Wolfgang Lux-% See LICENSE for the full license.-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-%-\nwfilename{CurryPP.lhs}-\section{A Pretty Printer for Curry}\label{sec:CurryPP}-This module implements a pretty printer for Curry expressions. It was-derived from the Haskell pretty printer provided in Simon Marlow's-Haskell parser.-\begin{verbatim}--> module Curry.Syntax.Pretty where--> import Text.PrettyPrint.HughesPJ--> import Curry.Base.Ident-> import Curry.Syntax.Type---\end{verbatim}-Pretty print a module-\begin{verbatim}--> ppModule :: Module -> Doc-> ppModule (Module m es ds) = ppModuleHeader m es $$ ppBlock ds--\end{verbatim}-Module header-\begin{verbatim}--> ppModuleHeader :: ModuleIdent -> Maybe ExportSpec -> Doc-> ppModuleHeader m es =->   text "module" <+> ppMIdent m <+> maybePP ppExportSpec es <+> text "where"--> ppExportSpec :: ExportSpec -> Doc-> ppExportSpec (Exporting _ es) = parenList (map ppExport es)--> ppExport :: Export -> Doc-> ppExport (Export x) = ppQIdent x-> ppExport (ExportTypeWith tc cs) = ppQIdent tc <> parenList (map ppIdent cs)-> ppExport (ExportTypeAll tc) = ppQIdent tc <> text "(..)"-> ppExport (ExportModule m) = text "module" <+> ppMIdent m--\end{verbatim}-Declarations-\begin{verbatim}--> ppBlock :: [Decl] -> Doc-> ppBlock = vcat . map ppDecl--> ppDecl :: Decl -> Doc-> ppDecl (ImportDecl _ m q asM is) =->   text "import" <+> ppQualified q <+> ppMIdent m <+> maybePP ppAs asM->                 <+> maybePP ppImportSpec is->   where ppQualified q = if q then text "qualified" else empty->         ppAs m = text "as" <+> ppMIdent m-> ppDecl (InfixDecl _ fix p ops) = ppPrec fix p <+> list (map ppInfixOp ops)-> ppDecl (DataDecl _ tc tvs cs) =->   sep (ppTypeDeclLhs "data" tc tvs :->        map indent (zipWith (<+>) (equals : repeat vbar) (map ppConstr cs)))-> ppDecl (NewtypeDecl _ tc tvs nc) =->   sep [ppTypeDeclLhs "newtype" tc tvs <+> equals,indent (ppNewConstr nc)]-> ppDecl (TypeDecl _ tc tvs ty) =->   sep [ppTypeDeclLhs "type" tc tvs <+> equals,indent (ppTypeExpr 0 ty)]-> ppDecl (TypeSig _ fs ty) =->   list (map ppIdent fs) <+> text "::" <+> ppTypeExpr 0 ty-> ppDecl (EvalAnnot _ fs ev) =->   list (map ppIdent fs) <+> text "eval" <+> ppEval ev->   where ppEval EvalRigid = text "rigid"->         ppEval EvalChoice = text "choice"-> ppDecl (FunctionDecl _ _ eqs) = vcat (map ppEquation eqs)-> ppDecl (ExternalDecl p cc impent f ty) =->   sep [text "external" <+> ppCallConv cc <+> maybePP (text . show) impent,->        indent (ppDecl (TypeSig p [f] ty))]->   where ppCallConv CallConvPrimitive = text "primitive"->         ppCallConv CallConvCCall = text "ccall"-> ppDecl (FlatExternalDecl _ fs) = list (map ppIdent fs) <+> text "external"-> ppDecl (PatternDecl _ t rhs) = ppRule (ppConstrTerm 0 t) equals rhs-> ppDecl (ExtraVariables _ vs) = list (map ppIdent vs) <+> text "free"--> ppImportSpec :: ImportSpec -> Doc-> ppImportSpec (Importing _ is) = parenList (map ppImport is)-> ppImportSpec (Hiding _ is) = text "hiding" <+> parenList (map ppImport is)--> ppImport :: Import -> Doc-> ppImport (Import x) = ppIdent x-> ppImport (ImportTypeWith tc cs) = ppIdent tc <> parenList (map ppIdent cs)-> ppImport (ImportTypeAll tc) = ppIdent tc <> text "(..)"--> ppPrec :: Infix -> Integer -> Doc-> ppPrec fix p = ppAssoc fix <+> ppPrio p->   where ppAssoc InfixL = text "infixl"->         ppAssoc InfixR = text "infixr"->         ppAssoc Infix = text "infix"->         ppPrio p = if p < 0 then empty else integer p--> ppTypeDeclLhs :: String -> Ident -> [Ident] -> Doc-> ppTypeDeclLhs kw tc tvs = text kw <+> ppIdent tc <+> hsep (map ppIdent tvs)--> ppConstr :: ConstrDecl -> Doc-> ppConstr (ConstrDecl _ tvs c tys) =->   sep [ppExistVars tvs,ppIdent c <+> fsep (map (ppTypeExpr 2) tys)]-> ppConstr (ConOpDecl _ tvs ty1 op ty2) =->   sep [ppExistVars tvs,ppTypeExpr 1 ty1,ppInfixOp op <+> ppTypeExpr 1 ty2]--> ppNewConstr :: NewConstrDecl -> Doc-> ppNewConstr (NewConstrDecl _ tvs c ty) =->   sep [ppExistVars tvs,ppIdent c <+> ppTypeExpr 2 ty]--> ppExistVars :: [Ident] -> Doc-> ppExistVars tvs->   | null tvs = empty->   | otherwise = text "forall" <+> hsep (map ppIdent tvs) <+> char '.'--> ppEquation :: Equation -> Doc-> ppEquation (Equation _ lhs rhs) = ppRule (ppLhs lhs) equals rhs--> ppLhs :: Lhs -> Doc-> ppLhs (FunLhs f ts) = ppIdent f <+> fsep (map (ppConstrTerm 2) ts)-> ppLhs (OpLhs t1 f t2) =->   ppConstrTerm 1 t1 <+> ppInfixOp f <+> ppConstrTerm 1 t2-> ppLhs (ApLhs lhs ts) = parens (ppLhs lhs) <+> fsep (map (ppConstrTerm 2) ts)--> ppRule :: Doc -> Doc -> Rhs -> Doc-> ppRule lhs eq (SimpleRhs _ e ds) =->   sep [lhs <+> eq,indent (ppExpr 0 e)] $$ ppLocalDefs ds-> ppRule lhs eq (GuardedRhs es ds) =->   sep [lhs,indent (vcat (map (ppCondExpr eq) es))] $$ ppLocalDefs ds--> ppLocalDefs :: [Decl] -> Doc-> ppLocalDefs ds->   | null ds = empty->   | otherwise = indent (text "where" <+> ppBlock ds)--\end{verbatim}-Interfaces-\begin{verbatim}--> ppInterface :: Interface -> Doc-> ppInterface (Interface m ds) =->   text "interface" <+> ppMIdent m <+> text "where" <+> lbrace->     $$ vcat (punctuate semi (map ppIDecl ds)) $$ rbrace--> ppIDecl :: IDecl -> Doc-> ppIDecl (IImportDecl _ m) = text "import" <+> ppMIdent m-> ppIDecl (IInfixDecl _ fix p op) = ppPrec fix p <+> ppQInfixOp op-> ppIDecl (HidingDataDecl _ tc tvs) =->   text "hiding" <+> ppITypeDeclLhs "data" (qualify tc) tvs-> ppIDecl (IDataDecl _ tc tvs cs) =->   sep (ppITypeDeclLhs "data" tc tvs :->        map indent (zipWith (<+>) (equals : repeat vbar) (map ppIConstr cs)))->   where ppIConstr = maybe (char '_') ppConstr-> ppIDecl (INewtypeDecl _ tc tvs nc) =->   sep [ppITypeDeclLhs "newtype" tc tvs <+> equals,indent (ppNewConstr nc)]-> ppIDecl (ITypeDecl _ tc tvs ty) =->   sep [ppITypeDeclLhs "type" tc tvs <+> equals,indent (ppTypeExpr 0 ty)]-> ppIDecl (IFunctionDecl _ f _ ty) = ppQIdent f <+> text "::" <+> ppTypeExpr 0 ty--> ppITypeDeclLhs :: String -> QualIdent -> [Ident] -> Doc-> ppITypeDeclLhs kw tc tvs = text kw <+> ppQIdent tc <+> hsep (map ppIdent tvs)--\end{verbatim}-Types-\begin{verbatim}--> ppTypeExpr :: Int -> TypeExpr -> Doc-> ppTypeExpr p (ConstructorType tc tys) =->   parenExp (p > 1 && not (null tys))->            (ppQIdent tc <+> fsep (map (ppTypeExpr 2) tys))-> ppTypeExpr _ (VariableType tv) = ppIdent tv-> ppTypeExpr _ (TupleType tys) = parenList (map (ppTypeExpr 0) tys)-> ppTypeExpr _ (ListType ty) = brackets (ppTypeExpr 0 ty)-> ppTypeExpr p (ArrowType ty1 ty2) =->   parenExp (p > 0) (fsep (ppArrowType (ArrowType ty1 ty2)))->   where ppArrowType (ArrowType ty1 ty2) =->           ppTypeExpr 1 ty1 <+> rarrow : ppArrowType ty2->         ppArrowType ty = [ppTypeExpr 0 ty]-> ppTypeExpr p (RecordType fs rty) = ->   braces (list (map ppTypedField fs) ->           <> maybe empty (\ty -> space <> char '|' <+> ppTypeExpr 0 ty) rty)->   where->   ppTypedField (ls,ty) = ->     list (map ppIdent ls) <> text "::" <> ppTypeExpr 0 ty----\end{verbatim}-Literals-\begin{verbatim}--> ppLiteral :: Literal -> Doc-> ppLiteral (Char _ c)   = text (show c)-> ppLiteral (Int _ i)    = integer i-> ppLiteral (Float _ f)  = double f-> ppLiteral (String _ s) = text (show s)--\end{verbatim}-Patterns-\begin{verbatim}--> ppConstrTerm :: Int -> ConstrTerm -> Doc-> ppConstrTerm p (LiteralPattern l) =->   parenExp (p > 1 && isNegative l) (ppLiteral l)->   where isNegative (Char _ _)   = False->         isNegative (Int _ i)    = i < 0->         isNegative (Float _ f)  = f < 0.0->         isNegative (String _ _) = False-> ppConstrTerm p (NegativePattern op l) =->   parenExp (p > 1) (ppInfixOp op <> ppLiteral l)-> ppConstrTerm _ (VariablePattern v) = ppIdent v-> ppConstrTerm p (ConstructorPattern c ts) =->   parenExp (p > 1 && not (null ts))->            (ppQIdent c <+> fsep (map (ppConstrTerm 2) ts))-> ppConstrTerm p (InfixPattern t1 c t2) =->   parenExp (p > 0)->            (sep [ppConstrTerm 1 t1 <+> ppQInfixOp c,->                  indent (ppConstrTerm 0 t2)])-> ppConstrTerm _ (ParenPattern t) = parens (ppConstrTerm 0 t)-> ppConstrTerm _ (TuplePattern _ ts) = parenList (map (ppConstrTerm 0) ts)-> ppConstrTerm _ (ListPattern _ ts) = bracketList (map (ppConstrTerm 0) ts)-> ppConstrTerm _ (AsPattern v t) = ppIdent v <> char '@' <> ppConstrTerm 2 t-> ppConstrTerm _ (LazyPattern _ t) = char '~' <> ppConstrTerm 2 t-> ppConstrTerm p (FunctionPattern f ts) =->   parenExp (p > 1 && not (null ts))->            (ppQIdent f <+> fsep (map (ppConstrTerm 2) ts))-> ppConstrTerm p (InfixFuncPattern t1 f t2) =->   parenExp (p > 0)->            (sep [ppConstrTerm 1 t1 <+> ppQInfixOp f,->                  indent (ppConstrTerm 0 t2)])-> ppConstrTerm p (RecordPattern fs rt) =->   braces (list (map ppFieldPatt fs)->          <> (maybe empty (\t -> space <> char '|' <+> ppConstrTerm 0 t) rt))--> ppFieldPatt :: Field ConstrTerm -> Doc-> ppFieldPatt (Field _ l t) = ppIdent l <> equals <> ppConstrTerm 0 t--\end{verbatim}-Expressions-\begin{verbatim}--> ppCondExpr :: Doc -> CondExpr -> Doc-> ppCondExpr eq (CondExpr _ g e) =->   vbar <+> sep [ppExpr 0 g <+> eq,indent (ppExpr 0 e)]--> ppExpr :: Int -> Expression -> Doc-> ppExpr _ (Literal l) = ppLiteral l-> ppExpr _ (Variable v) = ppQIdent v-> ppExpr _ (Constructor c) = ppQIdent c-> ppExpr _ (Paren e) = parens (ppExpr 0 e)-> ppExpr p (Typed e ty) =->   parenExp (p > 0) (ppExpr 0 e <+> text "::" <+> ppTypeExpr 0 ty)-> ppExpr _ (Tuple _ es) = parenList (map (ppExpr 0) es)-> ppExpr _ (List _ es) = bracketList (map (ppExpr 0) es)-> ppExpr _ (ListCompr _ e qs) =->   brackets (ppExpr 0 e <+> vbar <+> list (map ppStmt qs))-> ppExpr _ (EnumFrom e) = brackets (ppExpr 0 e <+> text "..")-> ppExpr _ (EnumFromThen e1 e2) =->   brackets (ppExpr 0 e1 <> comma <+> ppExpr 0 e2 <+> text "..")-> ppExpr _ (EnumFromTo e1 e2) =->   brackets (ppExpr 0 e1 <+> text ".." <+> ppExpr 0 e2)-> ppExpr _ (EnumFromThenTo e1 e2 e3) =->   brackets (ppExpr 0 e1 <> comma <+> ppExpr 0 e2->               <+> text ".." <+> ppExpr 0 e3)-> ppExpr p (UnaryMinus op e) = parenExp (p > 1) (ppInfixOp op <> ppExpr 1 e)-> ppExpr p (Apply e1 e2) =->   parenExp (p > 1) (sep [ppExpr 1 e1,indent (ppExpr 2 e2)])-> ppExpr p (InfixApply e1 op e2) =->   parenExp (p > 0) (sep [ppExpr 1 e1 <+> ppQInfixOp (opName op),->                          indent (ppExpr 1 e2)])-> ppExpr _ (LeftSection e op) = parens (ppExpr 1 e <+> ppQInfixOp (opName op))-> ppExpr _ (RightSection op e) = parens (ppQInfixOp (opName op) <+> ppExpr 1 e)-> ppExpr p (Lambda _ t e) =->   parenExp (p > 0)->            (sep [backsl <> fsep (map (ppConstrTerm 2) t) <+> rarrow,->                  indent (ppExpr 0 e)])-> ppExpr p (Let ds e) =->   parenExp (p > 0)->            (sep [text "let" <+> ppBlock ds <+> text "in",ppExpr 0 e])-> ppExpr p (Do sts e) =->   parenExp (p > 0) (text "do" <+> (vcat (map ppStmt sts) $$ ppExpr 0 e))-> ppExpr p (IfThenElse _ e1 e2 e3) =->   parenExp (p > 0)->            (text "if" <+>->             sep [ppExpr 0 e1,->                  text "then" <+> ppExpr 0 e2,->                  text "else" <+> ppExpr 0 e3])-> ppExpr p (Case _ e alts) =->   parenExp (p > 0)->            (text "case" <+> ppExpr 0 e <+> text "of" $$->             indent (vcat (map ppAlt alts)))-> ppExpr p (RecordConstr fs) =->   braces (list (map (ppFieldExpr equals) fs))-> ppExpr p (RecordSelection e l) =->   parenExp (p > 0)->            (ppExpr 1 e <+> text "->" <+> ppIdent l)-> ppExpr p (RecordUpdate fs e) =->   braces (list (map (ppFieldExpr (text ":=")) fs)->          <+> char '|' <+> ppExpr 0 e)--> ppStmt :: Statement -> Doc-> ppStmt (StmtExpr _ e) = ppExpr 0 e-> ppStmt (StmtBind _ t e) = sep [ppConstrTerm 0 t <+> larrow,indent (ppExpr 0 e)]-> ppStmt (StmtDecl ds) = text "let" <+> ppBlock ds--> ppAlt :: Alt -> Doc-> ppAlt (Alt _ t rhs) = ppRule (ppConstrTerm 0 t) rarrow rhs--> ppFieldExpr :: Doc -> Field Expression -> Doc-> ppFieldExpr comb (Field _ l e) = ppIdent l <> comb <> ppExpr 0 e--> ppOp :: InfixOp -> Doc-> ppOp (InfixOp op) = ppQInfixOp op-> ppOp (InfixConstr op) = ppQInfixOp op--\end{verbatim}--Names-\begin{verbatim}--> ppIdent :: Ident -> Doc-> ppIdent x = parenExp (isInfixOp x) (text (name x))--> ppQIdent :: QualIdent -> Doc-> ppQIdent x = parenExp (isQInfixOp x) (text (qualName x))--> ppInfixOp :: Ident -> Doc-> ppInfixOp x = backQuoteExp (not (isInfixOp x)) (text (name x))--> ppQInfixOp :: QualIdent -> Doc-> ppQInfixOp x = backQuoteExp (not (isQInfixOp x)) (text (qualName x))--> ppMIdent :: ModuleIdent -> Doc-> ppMIdent m = text (moduleName m)--\end{verbatim}-Print printing utilities-\begin{verbatim}--> indent :: Doc -> Doc-> indent = nest 2--> maybePP :: (a -> Doc) -> Maybe a -> Doc-> maybePP pp = maybe empty pp--> parenExp :: Bool -> Doc -> Doc-> parenExp b doc = if b then parens doc else doc--> backQuoteExp :: Bool -> Doc -> Doc-> backQuoteExp b doc = if b then backQuote <> doc <> backQuote else doc--> list, parenList, bracketList, braceList :: [Doc] -> Doc-> list = fsep . punctuate comma-> parenList = parens . list-> bracketList = brackets . list-> braceList = braces . list--> backQuote,backsl,vbar,rarrow,larrow :: Doc-> backQuote = char '`'-> backsl = char '\\'-> vbar = char '|'-> rarrow = text "->"-> larrow = text "<-"--\end{verbatim}
src/Curry/Syntax/ShowModule.hs view
@@ -1,462 +1,732 @@---- Transform a CurrySyntax module into a string representation without any---- pretty printing.---- Behaves like a derived Show instance even on parts with a specific one.---- ---- @author Sebastian Fischer (sebf@informatik.uni-kiel.de)---- @version December 2008---- bug fixed by bbr+{- |+    Module      :  $Header$+    Copyright   :  (c) 2008        Sebastian Fischer+                       2011 - 2015 Björn Peemöller+                       2016        Finn Teegen+    License     :  BSD-3-clause +    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable -module Curry.Syntax.ShowModule ( showModule ) where+    Transform a CurrySyntax module into a string representation without any+    pretty printing. +    Behaves like a derived Show instance even on parts with a specific one.+-}+module Curry.Syntax.ShowModule (showModule) where+ import Curry.Base.Ident import Curry.Base.Position+import Curry.Base.Span+import Curry.Base.SpanInfo+ import Curry.Syntax.Type -showModule :: Module -> String+-- |Show a Curry module like by an devired 'Show' instance+showModule :: Show a => Module a -> String showModule m = showsModule m "\n" -showsModule :: Module -> ShowS-showsModule (Module mident espec decls)+showsModule :: Show a => Module a -> ShowS+showsModule (Module spi li ps mident espec imps decls)   = showsString "Module "+  . showsLayoutInfo li . space+  . showsSpanInfo spi . space+  . showsList (\p -> showsPragma p . newline) ps . space   . showsModuleIdent mident . newline   . showsMaybe showsExportSpec espec . newline+  . showsList (\i -> showsImportDecl i . newline) imps   . showsList (\d -> showsDecl d . newline) decls -showsPosition :: Position -> ShowS-showsPosition Position{line=row,column=col} = showsPair shows shows (row,col)--- showsPosition (Position file row col)---   = showsString "(Position "---   . shows file . space---   . shows row . space---   . shows col---   . showsString ")"+showsPragma :: ModulePragma -> ShowS+showsPragma (LanguagePragma pos exts)+  = showsString "(LanguagePragma "+  . showsSpanInfo pos . space+  . showsList showsExtension exts+  . showsString ")"+showsPragma (OptionsPragma pos mbTool args)+  = showsString "(OptionsPragma "+  . showsSpanInfo pos . space+  . showsMaybe shows mbTool+  . shows args+  . showsString ")" +showsExtension :: Extension -> ShowS+showsExtension (KnownExtension p e)+  = showsString "(KnownExtension "+  . showsSpanInfo p . space+  . shows e+  . showString ")"+showsExtension (UnknownExtension p s)+  = showsString "(UnknownExtension "+  . showsSpanInfo p . space+  . shows s+  . showString ")"+ showsExportSpec :: ExportSpec -> ShowS showsExportSpec (Exporting pos exports)   = showsString "(Exporting "-  . showsPosition pos . space+  . showsSpanInfo pos . space   . showsList showsExport exports   . showsString ")"  showsExport :: Export -> ShowS-showsExport (Export qident)-  = showsString "(Export " . showsQualIdent qident . showsString ")"-showsExport (ExportTypeWith qident ids)+showsExport (Export spi qident)+  = showsString "(Export "+  . showsSpanInfo spi . space+  . showsQualIdent qident+  . showsString ")"+showsExport (ExportTypeWith spi qident ids)   = showsString "(ExportTypeWith "+  . showsSpanInfo spi . space   . showsQualIdent qident . space   . showsList showsIdent ids   . showsString ")"-showsExport (ExportTypeAll qident)-  = showsString "(ExportTypeAll " . showsQualIdent qident . showsString ")"-showsExport (ExportModule m) -  = showsString "(ExportModule " . showsModuleIdent m . showChar ')'+showsExport (ExportTypeAll spi qident)+  = showsString "(ExportTypeAll "+  . showsSpanInfo spi . space+  . showsQualIdent qident+  . showsString ")"+showsExport (ExportModule spi m)+  = showsString "(ExportModule "+  . showsSpanInfo spi . space+  . showsModuleIdent m+  . showsString ")" +showsImportDecl :: ImportDecl -> ShowS+showsImportDecl (ImportDecl spi mident quali mmident mimpspec)+  = showsString "(ImportDecl "+  . showsSpanInfo spi . space+  . showsModuleIdent mident . space+  . shows quali . space+  . showsMaybe showsModuleIdent mmident . space+  . showsMaybe showsImportSpec mimpspec+  . showsString ")"+ showsImportSpec :: ImportSpec -> ShowS-showsImportSpec (Importing pos imports)+showsImportSpec (Importing spi imports)   = showsString "(Importing "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsList showsImport imports   . showsString ")"-showsImportSpec (Hiding pos imports)+showsImportSpec (Hiding spi imports)   = showsString "(Hiding "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsList showsImport imports   . showsString ")"  showsImport :: Import -> ShowS-showsImport (Import ident)-  = showsString "(Import " . showsIdent ident . showsString ")"-showsImport (ImportTypeWith ident idents)+showsImport (Import spi ident)+  = showsString "(Import "+  . showsSpanInfo spi . space+  . showsIdent ident+  . showsString ")"+showsImport (ImportTypeWith spi ident idents)   = showsString "(ImportTypeWith "+  . showsSpanInfo spi . space   . showsIdent ident . space   . showsList showsIdent idents   . showsString ")"-showsImport (ImportTypeAll ident)-  = showsString "(ImportTypeAll " . showsIdent ident . showsString ")"--showsDecl :: Decl -> ShowS-showsDecl (ImportDecl pos mident quali mmident mimpspec)-  = showsString "(ImportDecl "-  . showsPosition pos . space-  . showsModuleIdent mident . space-  . shows quali . space-  . showsMaybe showsModuleIdent mmident . space-  . showsMaybe showsImportSpec mimpspec+showsImport (ImportTypeAll spi ident)+  = showsString "(ImportTypeAll "+  . showsSpanInfo spi . space+  . showsIdent ident   . showsString ")"-showsDecl (InfixDecl pos infx prec idents)++showsDecl :: Show a => Decl a -> ShowS+showsDecl (InfixDecl spi infx prec idents)   = showsString "(InfixDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . shows infx . space-  . shows prec . space+  . showsMaybe shows prec . space   . showsList showsIdent idents   . showsString ")"-showsDecl (DataDecl pos ident idents consdecls)+showsDecl (DataDecl spi ident idents consdecls classes)   = showsString "(DataDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsIdent ident . space   . showsList showsIdent idents . space-  . showsList showsConsDecl consdecls+  . showsList showsConsDecl consdecls . space+  . showsList showsQualIdent classes   . showsString ")"-showsDecl (NewtypeDecl pos ident idents newconsdecl)+showsDecl (ExternalDataDecl spi ident idents)+  = showsString "(ExternalDataDecl "+  . showsSpanInfo spi . space+  . showsIdent ident . space+  . showsList showsIdent idents+  . showsString ")"+showsDecl (NewtypeDecl spi ident idents newconsdecl classes)   = showsString "(NewtypeDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsIdent ident . space   . showsList showsIdent idents . space-  . showsNewConsDecl newconsdecl+  . showsNewConsDecl newconsdecl . space+  . showsList showsQualIdent classes   . showsString ")"-showsDecl (TypeDecl pos ident idents typ)+showsDecl (TypeDecl spi ident idents typ)   = showsString "(TypeDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsIdent ident . space   . showsList showsIdent idents . space   . showsTypeExpr typ   . showsString ")"-showsDecl (TypeSig pos idents typ)+showsDecl (TypeSig spi idents qtype)   = showsString "(TypeSig "-  . showsPosition pos . space-  . showsList showsIdent idents . space-  . showsTypeExpr typ-  . showsString ")"-showsDecl (EvalAnnot pos idents annot)-  = showsString "(EvalAnnot "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsList showsIdent idents . space-  . shows annot+  . showsQualTypeExpr qtype   . showsString ")"-showsDecl (FunctionDecl pos ident eqs)+showsDecl (FunctionDecl spi a ident eqs)   = showsString "(FunctionDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space+  . showsPrec 11 a . space   . showsIdent ident . space   . showsList showsEquation eqs   . showsString ")"-showsDecl (ExternalDecl pos cconv mstr ident typ)+showsDecl (ExternalDecl spi vars)   = showsString "(ExternalDecl "-  . showsPosition pos . space-  . shows cconv . space-  . shows mstr . space-  . showsIdent ident . space-  . showsTypeExpr typ-  . showsString ")"-showsDecl (FlatExternalDecl pos idents)-  = showsString "(FlatExternalDecl "-  . showsPosition pos . space-  . showsList showsIdent idents+  . showsSpanInfo spi . space+  . showsList showsVar vars   . showsString ")"-showsDecl (PatternDecl pos cons rhs)+showsDecl (PatternDecl spi cons rhs)   = showsString "(PatternDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsConsTerm cons . space   . showsRhs rhs   . showsString ")"-showsDecl (ExtraVariables pos idents)-  = showsString "(ExtraVariables "-  . showsPosition pos . space-  . showsList showsIdent idents+showsDecl (FreeDecl spi vars)+  = showsString "(FreeDecl "+  . showsSpanInfo spi . space+  . showsList showsVar vars   . showsString ")"+showsDecl (DefaultDecl spi types)+  = showsString "(DefaultDecl "+  . showsSpanInfo spi . space+  . showsList showsTypeExpr types+  . showsString ")"+showsDecl (ClassDecl spi li context cls clsvar decls)+  = showsString "(ClassDecl "+  . showsSpanInfo spi . space+  . showsLayoutInfo li . space+  . showsContext context . space+  . showsIdent cls . space+  . showsIdent clsvar . space+  . showsList showsDecl decls+  . showsString ")"+showsDecl (InstanceDecl spi li context qcls inst decls)+  = showsString "(InstanceDecl "+  . showsSpanInfo spi . space+  . showsLayoutInfo li . space+  . showsContext context . space+  . showsQualIdent qcls . space+  . showsInstanceType inst . space+  . showsList showsDecl decls+  . showsString ")" +showsContext :: Context -> ShowS+showsContext = showsList showsConstraint++showsConstraint :: Constraint -> ShowS+showsConstraint (Constraint spi qcls ty)+  = showsString "(Constraint "+  . showsSpanInfo spi . space+  . showsQualIdent qcls . space+  . showsTypeExpr ty+  . showsString ")"++showsInstanceType :: InstanceType -> ShowS+showsInstanceType = showsTypeExpr+ showsConsDecl :: ConstrDecl -> ShowS-showsConsDecl (ConstrDecl pos idents ident types)+showsConsDecl (ConstrDecl spi ident types)   = showsString "(ConstrDecl "-  . showsPosition pos . space-  . showsList showsIdent idents . space+  . showsSpanInfo spi . space   . showsIdent ident . space   . showsList showsTypeExpr types   . showsString ")"+showsConsDecl (ConOpDecl spi ty1 ident ty2)+  = showsString "(ConOpDecl "+  . showsSpanInfo spi . space+  . showsTypeExpr ty1 . space+  . showsIdent ident . space+  . showsTypeExpr ty2+  . showsString ")"+showsConsDecl (RecordDecl spi ident fs)+  = showsString "(RecordDecl "+  . showsSpanInfo spi . space+  . showsIdent ident . space+  . showsList showsFieldDecl fs+  . showsString ")" +showsFieldDecl :: FieldDecl -> ShowS+showsFieldDecl (FieldDecl spi labels ty)+  = showsString "(FieldDecl "+  . showsSpanInfo spi . space+  . showsList showsIdent labels . space+  . showsTypeExpr ty+  . showsString ")"+ showsNewConsDecl :: NewConstrDecl -> ShowS-showsNewConsDecl (NewConstrDecl pos idents ident typ)+showsNewConsDecl (NewConstrDecl spi ident typ)   = showsString "(NewConstrDecl "-  . showsPosition pos . space-  . showsList showsIdent idents . space+  . showsSpanInfo spi . space   . showsIdent ident . space   . showsTypeExpr typ   . showsString ")"+showsNewConsDecl (NewRecordDecl spi ident fld)+  = showsString "(NewRecordDecl "+  . showsSpanInfo spi . space+  . showsIdent ident . space+  . showsPair showsIdent showsTypeExpr fld+  . showsString ")" +showsQualTypeExpr :: QualTypeExpr -> ShowS+showsQualTypeExpr (QualTypeExpr spi context typ)+  = showsString "(QualTypeExpr "+  . showsSpanInfo spi . space+  . showsContext context . space+  . showsTypeExpr typ+  . showsString ")"+ showsTypeExpr :: TypeExpr -> ShowS-showsTypeExpr (ConstructorType qident types)+showsTypeExpr (ConstructorType spi qident)   = showsString "(ConstructorType "+  . showsSpanInfo spi . space   . showsQualIdent qident . space+  . showsString ")"+showsTypeExpr (ApplyType spi type1 type2)+  = showsString "(ApplyType "+  . showsSpanInfo spi . space+  . showsTypeExpr type1 . space+  . showsTypeExpr type2 . space+  . showsString ")"+showsTypeExpr (VariableType spi ident)+  = showsString "(VariableType "+  . showsSpanInfo spi . space+  . showsIdent ident+  . showsString ")"+showsTypeExpr (TupleType spi types)+  = showsString "(TupleType "+  . showsSpanInfo spi . space   . showsList showsTypeExpr types   . showsString ")"-showsTypeExpr (VariableType ident)-  = showsString "(VariableType " . showsIdent ident . showsString ")"-showsTypeExpr (TupleType types)-  = showsString "(TupleType " . showsList showsTypeExpr types . showsString ")"-showsTypeExpr (ListType typ)-  = showsString "(ListType " . showsTypeExpr typ . showsString ")"-showsTypeExpr (ArrowType dom ran)+showsTypeExpr (ListType spi typ)+  = showsString "(ListType "+  . showsSpanInfo spi . space+  . showsTypeExpr typ+  . showsString ")"+showsTypeExpr (ArrowType spi dom ran)   = showsString "(ArrowType "+  . showsSpanInfo spi . space   . showsTypeExpr dom . space   . showsTypeExpr ran   . showsString ")"-showsTypeExpr (RecordType fieldts mtyp)-  = showsString "(RecordType "-  . showsList (showsPair (showsList showsIdent) showsTypeExpr) fieldts . space-  . showsMaybe showsTypeExpr mtyp+showsTypeExpr (ParenType spi ty)+  = showsString "(ParenType "+  . showsSpanInfo spi . space+  . showsTypeExpr ty   . showsString ")"+showsTypeExpr (ForallType spi vars ty)+  = showsString "(ForallType "+  . showsSpanInfo spi . space+  . showsList showsIdent vars+  . showsTypeExpr ty+  . showsString ")" -showsEquation :: Equation -> ShowS-showsEquation (Equation pos lhs rhs)+showsEquation :: Show a => Equation a -> ShowS+showsEquation (Equation spi lhs rhs)   = showsString "(Equation "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsLhs lhs . space   . showsRhs rhs   . showsString ")" -showsLhs :: Lhs -> ShowS-showsLhs (FunLhs ident conss)+showsLhs :: Show a => Lhs a -> ShowS+showsLhs (FunLhs spi ident conss)   = showsString "(FunLhs "+  . showsSpanInfo spi . space   . showsIdent ident . space   . showsList showsConsTerm conss   . showsString ")"-showsLhs (OpLhs cons1 ident cons2)+showsLhs (OpLhs spi cons1 ident cons2)   = showsString "(OpLhs "+  . showsSpanInfo spi . space   . showsConsTerm cons1 . space   . showsIdent ident . space   . showsConsTerm cons2   . showsString ")"-showsLhs (ApLhs lhs conss)+showsLhs (ApLhs spi lhs conss)   = showsString "(ApLhs "+  . showsSpanInfo spi . space   . showsLhs lhs . space   . showsList showsConsTerm conss   . showsString ")" -showsRhs :: Rhs -> ShowS-showsRhs (SimpleRhs pos exp decls)+showsRhs :: Show a => Rhs a -> ShowS+showsRhs (SimpleRhs spi li expr decls)   = showsString "(SimpleRhs "-  . showsPosition pos . space-  . showsExpression exp . space+  . showsSpanInfo spi . space+  . showsLayoutInfo li . space+  . showsExpression expr . space   . showsList showsDecl decls   . showsString ")"-showsRhs (GuardedRhs cexps decls)+showsRhs (GuardedRhs spi li cexps decls)   = showsString "(GuardedRhs "+  . showsSpanInfo spi . space+  . showsLayoutInfo li . space   . showsList showsCondExpr cexps . space   . showsList showsDecl decls   . showsString ")" -showsCondExpr :: CondExpr -> ShowS-showsCondExpr (CondExpr pos exp1 exp2)+showsCondExpr :: Show a => CondExpr a -> ShowS+showsCondExpr (CondExpr spi exp1 exp2)   = showsString "(CondExpr "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsExpression exp1 . space   . showsExpression exp2   . showsString ")"  showsLiteral :: Literal -> ShowS-showsLiteral (Char _ c) = showsString "(Char " . shows c . showsString ")"-showsLiteral (Int ident n)+showsLiteral (Char c)+  = showsString "(Char "+  . shows c+  . showsString ")"+showsLiteral (Int n)   = showsString "(Int "-  . showsIdent ident . space   . shows n   . showsString ")"-showsLiteral (Float _ x) = showsString "(Float " . shows x . showsString ")"-showsLiteral (String _ s) = showsString "(String " . shows s . showsString ")"+showsLiteral (Float x)+  = showsString "(Float "+  . shows x+  . showsString ")"+showsLiteral (String s)+  = showsString "(String "+  . shows s+  . showsString ")" -showsConsTerm :: ConstrTerm -> ShowS-showsConsTerm (LiteralPattern lit)+showsConsTerm :: Show a => Pattern a -> ShowS+showsConsTerm (LiteralPattern spi a lit)   = showsString "(LiteralPattern "+  . showsSpanInfo spi . space+  . showsPrec 11 a . space   . showsLiteral lit   . showsString ")"-showsConsTerm (NegativePattern ident lit)+showsConsTerm (NegativePattern spi a lit)   = showsString "(NegativePattern "-  . showsIdent ident . space+  . showsSpanInfo spi . space+  . showsPrec 11 a . space   . showsLiteral lit   . showsString ")"-showsConsTerm (VariablePattern ident)+showsConsTerm (VariablePattern spi a ident)   = showsString "(VariablePattern "-  . showsIdent ident +  . showsSpanInfo spi . space+  . showsPrec 11 a . space+  . showsIdent ident   . showsString ")"-showsConsTerm (ConstructorPattern qident conss)+showsConsTerm (ConstructorPattern spi a qident conss)   = showsString "(ConstructorPattern "+  . showsSpanInfo spi . space+  . showsPrec 11 a . space   . showsQualIdent qident . space   . showsList showsConsTerm conss   . showsString ")"-showsConsTerm (InfixPattern cons1 qident cons2)+showsConsTerm (InfixPattern spi a cons1 qident cons2)   = showsString "(InfixPattern "+  . showsSpanInfo spi . space+  . showsPrec 11 a . space   . showsConsTerm cons1 . space   . showsQualIdent qident . space   . showsConsTerm cons2   . showsString ")"-showsConsTerm (ParenPattern cons)+showsConsTerm (ParenPattern spi cons)   = showsString "(ParenPattern "+  . showsSpanInfo spi . space   . showsConsTerm cons   . showsString ")"-showsConsTerm (TuplePattern _ conss)+showsConsTerm (TuplePattern spi conss)   = showsString "(TuplePattern "+  . showsSpanInfo spi . space   . showsList showsConsTerm conss   . showsString ")"-showsConsTerm (ListPattern _ conss)+showsConsTerm (ListPattern spi a conss)   = showsString "(ListPattern "+  . showsSpanInfo spi . space+  . showsPrec 11 a . space   . showsList showsConsTerm conss   . showsString ")"-showsConsTerm (AsPattern ident cons)+showsConsTerm (AsPattern spi ident cons)   = showsString "(AsPattern "+  . showsSpanInfo spi . space   . showsIdent ident . space   . showsConsTerm cons   . showsString ")"-showsConsTerm (LazyPattern _ cons)+showsConsTerm (LazyPattern spi cons)   = showsString "(LazyPattern "+  . showsSpanInfo spi . space   . showsConsTerm cons   . showsString ")"-showsConsTerm (FunctionPattern qident conss)+showsConsTerm (FunctionPattern spi a qident conss)   = showsString "(FunctionPattern "+  . showsSpanInfo spi . space+  . showsPrec 11 a . space   . showsQualIdent qident . space   . showsList showsConsTerm conss   . showsString ")"-showsConsTerm (InfixFuncPattern cons1 qident cons2)+showsConsTerm (InfixFuncPattern spi a cons1 qident cons2)   = showsString "(InfixFuncPattern "+  . showsSpanInfo spi . space+  . showsPrec 11 a . space   . showsConsTerm cons1 . space   . showsQualIdent qident . space   . showsConsTerm cons2   . showsString ")"-showsConsTerm (RecordPattern cfields mcons)-  = shows "(RecordPattern "+showsConsTerm (RecordPattern spi a qident cfields)+  = showsString "(RecordPattern "+  . showsSpanInfo spi . space+  . showsPrec 11 a . space+  . showsQualIdent qident . space   . showsList (showsField showsConsTerm) cfields . space-  . showsMaybe showsConsTerm mcons   . showsString ")" -showsExpression :: Expression -> ShowS-showsExpression (Literal lit)-  = showsString "(Literal " . showsLiteral lit . showsString ")"-showsExpression (Variable qident)-  = showsString "(Variable " . showsQualIdent qident . showsString ")"-showsExpression (Constructor qident)-  = showsString "(Constructor " . showsQualIdent qident . showsString ")"-showsExpression (Paren exp)-  = showsString "(Paren " . showsExpression exp . showsString ")"-showsExpression (Typed exp typ)+showsExpression :: Show a => Expression a -> ShowS+showsExpression (Literal spi a lit)+  = showsString "(Literal "+  . showsSpanInfo spi . space+  . showsPrec 11 a . space+  . showsLiteral lit+  . showsString ")"+showsExpression (Variable spi a qident)+  = showsString "(Variable "+  . showsSpanInfo spi . space+  . showsPrec 11 a . space+  . showsQualIdent qident+  . showsString ")"+showsExpression (Constructor spi a qident)+  = showsString "(Constructor "+  . showsSpanInfo spi . space+  . showsPrec 11 a . space+  . showsQualIdent qident+  . showsString ")"+showsExpression (Paren spi expr)+  = showsString "(Paren "+  . showsSpanInfo spi . space+  . showsExpression expr+  . showsString ")"+showsExpression (Typed spi expr qtype)   = showsString "(Typed "-  . showsExpression exp . space-  . showsTypeExpr typ+  . showsSpanInfo spi . space+  . showsExpression expr . space+  . showsQualTypeExpr qtype   . showsString ")"-showsExpression (Tuple _ exps)-  = showsString "(Tuple " . showsList showsExpression exps . showsString ")"-showsExpression (List _ exps)-  = showsString "(List " . showsList showsExpression exps . showsString ")"-showsExpression (ListCompr _ exp stmts)+showsExpression (Tuple spi exps)+  = showsString "(Tuple "+  . showsSpanInfo spi . space+  . showsList showsExpression exps+  . showsString ")"+showsExpression (List spi a exps)+  = showsString "(List "+  . showsSpanInfo spi . space+  . showsPrec 11 a . space+  . showsList showsExpression exps+  . showsString ")"+showsExpression (ListCompr spi expr stmts)   = showsString "(ListCompr "-  . showsExpression exp . space+  . showsSpanInfo spi . space+  . showsExpression expr . space   . showsList showsStatement stmts   . showsString ")"-showsExpression (EnumFrom exp)-  = showsString "(EnumFrom " . showsExpression exp . showsString ")"-showsExpression (EnumFromThen exp1 exp2)+showsExpression (EnumFrom spi expr)+  = showsString "(EnumFrom "+  . showsSpanInfo spi . space+  . showsExpression expr+  . showsString ")"+showsExpression (EnumFromThen spi exp1 exp2)   = showsString "(EnumFromThen "+  . showsSpanInfo spi . space   . showsExpression exp1 . space   . showsExpression exp2   . showsString ")"-showsExpression (EnumFromTo exp1 exp2)+showsExpression (EnumFromTo spi exp1 exp2)   = showsString "(EnumFromTo "+  . showsSpanInfo spi . space   . showsExpression exp1 . space   . showsExpression exp2   . showsString ")"-showsExpression (EnumFromThenTo exp1 exp2 exp3)+showsExpression (EnumFromThenTo spi exp1 exp2 exp3)   = showsString "(EnumFromThenTo "+  . showsSpanInfo spi . space   . showsExpression exp1 . space   . showsExpression exp2 . space   . showsExpression exp3   . showsString ")"-showsExpression (UnaryMinus ident exp)+showsExpression (UnaryMinus spi expr)   = showsString "(UnaryMinus "-  . showsIdent ident . space-  . showsExpression exp+  . showsSpanInfo spi . space+  . showsExpression expr   . showsString ")"-showsExpression (Apply exp1 exp2)+showsExpression (Apply spi exp1 exp2)   = showsString "(Apply "+  . showsSpanInfo spi . space   . showsExpression exp1 . space   . showsExpression exp2   . showsString ")"-showsExpression (InfixApply exp1 op exp2)+showsExpression (InfixApply spi exp1 op exp2)   = showsString "(InfixApply "+  . showsSpanInfo spi . space   . showsExpression exp1 . space   . showsInfixOp op . space   . showsExpression exp2   . showsString ")"-showsExpression (LeftSection exp op)+showsExpression (LeftSection spi expr op)   = showsString "(LeftSection "-  . showsExpression exp . space+  . showsSpanInfo spi . space+  . showsExpression expr . space   . showsInfixOp op   . showsString ")"-showsExpression (RightSection op exp)+showsExpression (RightSection spi op expr)   = showsString "(RightSection "+  . showsSpanInfo spi . space   . showsInfixOp op . space-  . showsExpression exp+  . showsExpression expr   . showsString ")"-showsExpression (Lambda _ conss exp)+showsExpression (Lambda spi conss expr)   = showsString "(Lambda "+  . showsSpanInfo spi . space   . showsList showsConsTerm conss . space-  . showsExpression exp +  . showsExpression expr   . showsString ")"-showsExpression (Let decls exp)+showsExpression (Let spi li decls expr)   = showsString "(Let "+  . showsSpanInfo spi . space+  . showsLayoutInfo li . space   . showsList showsDecl decls . space-  . showsExpression exp +  . showsExpression expr   . showsString ")"-showsExpression (Do stmts exp)+showsExpression (Do spi li stmts expr)   = showsString "(Do "+  . showsSpanInfo spi . space+  . showsLayoutInfo li . space   . showsList showsStatement stmts . space-  . showsExpression exp+  . showsExpression expr   . showsString ")"-showsExpression (IfThenElse _ exp1 exp2 exp3)+showsExpression (IfThenElse spi exp1 exp2 exp3)   = showsString "(IfThenElse "+  . showsSpanInfo spi . space   . showsExpression exp1 . space   . showsExpression exp2 . space   . showsExpression exp3   . showsString ")"-showsExpression (Case _ exp alts)+showsExpression (Case spi li ct expr alts)   = showsString "(Case "-  . showsExpression exp . space+  . showsSpanInfo spi . space+  . showsLayoutInfo li . space+  . showsCaseType ct . space+  . showsExpression expr . space   . showsList showsAlt alts   . showsString ")"-showsExpression (RecordConstr efields)-  = showsString "(RecordConstr "+showsExpression (RecordUpdate spi expr efields)+  = showsString "(RecordUpdate "+  . showsSpanInfo spi . space+  . showsExpression expr . space   . showsList (showsField showsExpression) efields   . showsString ")"-showsExpression (RecordSelection exp ident)-  = showsString "(RecordSelection "-  . showsExpression exp . space-  . showsIdent ident-  . showsString ")"-showsExpression (RecordUpdate efields exp)-  = showsString "(RecordUpdate "-  . showsList (showsField showsExpression) efields . space-  . showsExpression exp+showsExpression (Record spi a qident efields)+  = showsString "(Record "+  . showsSpanInfo spi . space+  . showsPrec 11 a . space+  . showsQualIdent qident . space+  . showsList (showsField showsExpression) efields   . showsString ")" -showsInfixOp :: InfixOp -> ShowS-showsInfixOp (InfixOp qident)-  = showsString "(InfixOp " . showsQualIdent qident . showsString ")"-showsInfixOp (InfixConstr qident)-  = showsString "(InfixConstr " . showsQualIdent qident . showsString ")"+showsInfixOp :: Show a => InfixOp a -> ShowS+showsInfixOp (InfixOp a qident)+  = showsString "(InfixOp "+  . showsPrec 11 a . space+  . showsQualIdent qident+  . showsString ")"+showsInfixOp (InfixConstr a qident)+  = showsString "(InfixConstr "+  . showsPrec 11 a . space+  . showsQualIdent qident+  . showsString ")" -showsStatement :: Statement -> ShowS-showsStatement (StmtExpr _ exp)-  = showsString "(StmtExpr " . showsExpression exp . showsString ")"-showsStatement (StmtDecl decls)-  = showsString "(StmtDecl " . showsList showsDecl decls . showsString ")"-showsStatement (StmtBind _ cons exp)+showsStatement :: Show a => Statement a -> ShowS+showsStatement (StmtExpr spi expr)+  = showsString "(StmtExpr "+  . showsSpanInfo spi . space+  . showsExpression expr+  . showsString ")"+showsStatement (StmtDecl spi li decls)+  = showsString "(StmtDecl "+  . showsSpanInfo spi . space+  . showsLayoutInfo li . space+  . showsList showsDecl decls+  . showsString ")"+showsStatement (StmtBind spi cons expr)   = showsString "(StmtBind "+  . showsSpanInfo spi . space   . showsConsTerm cons . space-  . showsExpression exp+  . showsExpression expr   . showsString ")" -showsAlt :: Alt -> ShowS-showsAlt (Alt pos cons rhs)+showsCaseType :: CaseType -> ShowS+showsCaseType Rigid = showsString "Rigid"+showsCaseType Flex  = showsString "Flex"++showsAlt :: Show a => Alt a -> ShowS+showsAlt (Alt spi cons rhs)   = showsString "(Alt "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsConsTerm cons . space   . showsRhs rhs   . showsString ")"  showsField :: (a -> ShowS) -> Field a -> ShowS-showsField sa (Field pos ident a)+showsField sa (Field spi ident a)   = showsString "(Field "-  . showsPosition pos . space-  . showsIdent ident . space+  . showsSpanInfo spi . space+  . showsQualIdent ident . space   . sa a   . showsString ")" +showsVar :: Show a => Var a -> ShowS+showsVar (Var a ident)+  = showsString "(Var "+  . showsPrec 11 a . space+  . showsIdent ident+  . showsString ")"++showsPosition :: Position -> ShowS+showsPosition NoPos = showsString "NoPos"+showsPosition Position { line = l, column = c }+   = showsString "(Position "+   . shows l . space+   . shows c+   . showsString ")"++showsSpanInfo :: SpanInfo -> ShowS+showsSpanInfo NoSpanInfo = showsString "NoSpanInfo"+showsSpanInfo SpanInfo { srcSpan = sp, srcInfoPoints = ss }+  = showsString "(SpanInfo "+  . showsSpan sp . space+  . showsList showsSpan ss+  . showsString ")"++showsLayoutInfo :: LayoutInfo -> ShowS+showsLayoutInfo WhitespaceLayout = showsString "WhitespaceLayout"+showsLayoutInfo (ExplicitLayout ss)+  = showsString "(ExplicitLayout "+  . showsList showsSpan ss+  . showsString ")"++showsSpan :: Span -> ShowS+showsSpan NoSpan = showsString "NoSpan"+showsSpan Span { start = s, end = e }+  = showsString "(Span "+  . showsPosition s . space+  . showsPosition e+  . showsString ")"+ showsString :: String -> ShowS showsString = (++) @@ -467,12 +737,11 @@ newline = showsString "\n"  showsMaybe :: (a -> ShowS) -> Maybe a -> ShowS-showsMaybe shs-  = maybe (showsString "Nothing")-          (\x -> showsString "(Just " . shs x . showsString ")")+showsMaybe shs = maybe (showsString "Nothing")+                       (\x -> showsString "(Just " . shs x . showsString ")")  showsList :: (a -> ShowS) -> [a] -> ShowS-showsList _ [] = showsString "[]"+showsList _   [] = showsString "[]" showsList shs (x:xs)   = showsString "["   . foldl (\sys y -> sys . showsString "," . shs y) (shs x) xs@@ -482,18 +751,27 @@ showsPair sa sb (a,b)   = showsString "(" . sa a . showsString "," . sb b . showsString ")" - showsIdent :: Ident -> ShowS-showsIdent (Ident _ name n)-  = showsString "(Ident " . shows name . space . shows n . showsString ")"+showsIdent (Ident spi x n)+  = showsString "(Ident " . showsSpanInfo spi . space+  . shows x . space . shows n . showsString ")"  showsQualIdent :: QualIdent -> ShowS-showsQualIdent (QualIdent mident ident)-    = showsString "(QualIdent "-      . showsMaybe showsModuleIdent mident -      . space-      . showsIdent ident-      . showsString ")"+showsQualIdent (QualIdent spi mident ident)+  = showsString "(QualIdent "+  . showsSpanInfo spi . space+  . showsMaybe showsModuleIdent mident+  . space+  . showsIdent ident+  . showsString ")"  showsModuleIdent :: ModuleIdent -> ShowS-showsModuleIdent = shows . moduleName+showsModuleIdent (ModuleIdent spi ss)+  = showsString "(ModuleIdent "+  . showsSpanInfo spi . space+  . showsList (showsQuotes showsString) ss+  . showsString ")"++showsQuotes :: (a -> ShowS) -> a -> ShowS+showsQuotes sa a+  = showsString "\"" . sa a . showsString "\""
+ src/Curry/Syntax/Type.hs view
@@ -0,0 +1,1540 @@+{- |+    Module      :  $Header$+    Description :  Abstract syntax for Curry+    Copyright   :  (c) 1999 - 2004 Wolfgang Lux+                       2005        Martin Engelke+                       2011 - 2015 Björn Peemöller+                       2014        Jan Rasmus Tikovsky+                       2016        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module provides the necessary data structures to maintain the+    parsed representation of a Curry program.+-}++module Curry.Syntax.Type+  ( -- * Module header+    Module (..)+    -- ** Module pragmas+  , ModulePragma (..), Extension (..), KnownExtension (..), Tool (..)+    -- ** Export specification+  , ExportSpec (..), Export (..)+    -- ** Import declarations+  , ImportDecl (..), ImportSpec (..), Import (..), Qualified+    -- * Interface+  , Interface (..), IImportDecl (..), Arity, IDecl (..), KindExpr (..)+  , IMethodDecl (..), IMethodImpl+    -- * Declarations+  , Decl (..), Precedence, Infix (..), ConstrDecl (..), NewConstrDecl (..)+  , FieldDecl (..)+  , TypeExpr (..), QualTypeExpr (..)+  , Equation (..), Lhs (..), Rhs (..), CondExpr (..)+  , Literal (..), Pattern (..), Expression (..), InfixOp (..)+  , Statement (..), CaseType (..), Alt (..), Field (..), Var (..)+    -- * Type classes+  , Context, Constraint (..), InstanceType+    -- * Goals+  , Goal (..)+  ) where++import Data.Binary+import Control.Monad++import Curry.Base.Ident+import Curry.Base.Position+import Curry.Base.SpanInfo+import Curry.Base.Span+import Curry.Base.Pretty      (Pretty(..))++import Curry.Syntax.Extension++import Text.PrettyPrint++-- ---------------------------------------------------------------------------+-- Modules+-- ---------------------------------------------------------------------------++-- |Curry module+data Module a = Module SpanInfo LayoutInfo [ModulePragma] ModuleIdent+                       (Maybe ExportSpec) [ImportDecl] [Decl a]+    deriving (Eq, Read, Show)++-- |Module pragma+data ModulePragma+  = LanguagePragma SpanInfo [Extension]         -- ^ language pragma+  | OptionsPragma  SpanInfo (Maybe Tool) String -- ^ options pragma+    deriving (Eq, Read, Show)++-- |Export specification+data ExportSpec = Exporting SpanInfo [Export]+    deriving (Eq, Read, Show)++-- |Single exported entity+data Export+  = Export         SpanInfo QualIdent         -- f/T+  | ExportTypeWith SpanInfo QualIdent [Ident] -- T (C1,...,Cn)+  | ExportTypeAll  SpanInfo QualIdent         -- T (..)+  | ExportModule   SpanInfo ModuleIdent       -- module M+    deriving (Eq, Read, Show)++-- |Import declaration+data ImportDecl = ImportDecl SpanInfo ModuleIdent Qualified+                             (Maybe ModuleIdent) (Maybe ImportSpec)+    deriving (Eq, Read, Show)++-- |Flag to signal qualified import+type Qualified = Bool++-- |Import specification+data ImportSpec+  = Importing SpanInfo [Import]+  | Hiding    SpanInfo [Import]+    deriving (Eq, Read, Show)++-- |Single imported entity+data Import+  = Import         SpanInfo Ident            -- f/T+  | ImportTypeWith SpanInfo Ident [Ident]    -- T (C1,...,Cn)+  | ImportTypeAll  SpanInfo Ident            -- T (..)+    deriving (Eq, Read, Show)++-- ---------------------------------------------------------------------------+-- Module interfaces+-- ---------------------------------------------------------------------------++-- | Module interface+--+-- Interface declarations are restricted to type declarations and signatures.+-- Note that an interface function declaration additionaly contains the+-- function arity (= number of parameters) in order to generate+-- correct FlatCurry function applications.+data Interface = Interface ModuleIdent [IImportDecl] [IDecl]+    deriving (Eq, Read, Show)++-- |Interface import declaration+data IImportDecl = IImportDecl Position ModuleIdent+    deriving (Eq, Read, Show)++-- |Arity of a function+type Arity = Int++-- |Interface declaration+data IDecl+  = IInfixDecl      Position Infix Precedence QualIdent+  | HidingDataDecl  Position QualIdent (Maybe KindExpr) [Ident]+  | IDataDecl       Position QualIdent (Maybe KindExpr) [Ident] [ConstrDecl]  [Ident]+  | INewtypeDecl    Position QualIdent (Maybe KindExpr) [Ident] NewConstrDecl [Ident]+  | ITypeDecl       Position QualIdent (Maybe KindExpr) [Ident] TypeExpr+  | IFunctionDecl   Position QualIdent (Maybe Ident) Arity QualTypeExpr+  | HidingClassDecl Position Context QualIdent (Maybe KindExpr) Ident+  | IClassDecl      Position Context QualIdent (Maybe KindExpr) Ident [IMethodDecl] [Ident]+  | IInstanceDecl   Position Context QualIdent InstanceType [IMethodImpl] (Maybe ModuleIdent)+    deriving (Eq, Read, Show)++-- |Class methods+data IMethodDecl = IMethodDecl Position Ident (Maybe Arity) QualTypeExpr+  deriving (Eq, Read, Show)++-- |Class method implementations+type IMethodImpl = (Ident, Arity)++-- |Kind expressions+data KindExpr+  = Star+  | ArrowKind KindExpr KindExpr+    deriving (Eq, Read, Show)++-- ---------------------------------------------------------------------------+-- Declarations (local or top-level)+-- ---------------------------------------------------------------------------++-- |Declaration in a module+data Decl a+  = InfixDecl        SpanInfo Infix (Maybe Precedence) [Ident]                   -- infixl 5 (op), `fun`+  | DataDecl         SpanInfo Ident [Ident] [ConstrDecl] [QualIdent]             -- data C a b = C1 a | C2 b deriving (D, ...)+  | ExternalDataDecl SpanInfo Ident [Ident]                                      -- external data C a b+  | NewtypeDecl      SpanInfo Ident [Ident] NewConstrDecl [QualIdent]            -- newtype C a b = C a b deriving (D, ...)+  | TypeDecl         SpanInfo Ident [Ident] TypeExpr                             -- type C a b = D a b+  | TypeSig          SpanInfo [Ident] QualTypeExpr                               -- f, g :: Bool+  | FunctionDecl     SpanInfo a Ident [Equation a]                               -- f True = 1 ; f False = 0+  | ExternalDecl     SpanInfo [Var a]                                            -- f, g external+  | PatternDecl      SpanInfo (Pattern a) (Rhs a)                                -- Just x = ...+  | FreeDecl         SpanInfo [Var a]                                            -- x, y free+  | DefaultDecl      SpanInfo [TypeExpr]                                         -- default (Int, Float)+  | ClassDecl        SpanInfo LayoutInfo Context Ident Ident [Decl a]            -- class C a => D a where {TypeSig|InfixDecl|FunctionDecl}+  | InstanceDecl     SpanInfo LayoutInfo Context QualIdent InstanceType [Decl a] -- instance C a => M.D (N.T a b c) where {FunctionDecl}+    deriving (Eq, Read, Show)++-- ---------------------------------------------------------------------------+-- Infix declaration+-- ---------------------------------------------------------------------------++-- |Operator precedence+type Precedence = Integer++-- |Fixity of operators+data Infix+  = InfixL -- ^ left-associative+  | InfixR -- ^ right-associative+  | Infix  -- ^ no associativity+    deriving (Eq, Read, Show)++-- |Constructor declaration for algebraic data types+data ConstrDecl+  = ConstrDecl SpanInfo Ident [TypeExpr]+  | ConOpDecl  SpanInfo TypeExpr Ident TypeExpr+  | RecordDecl SpanInfo Ident [FieldDecl]+    deriving (Eq, Read, Show)++-- |Constructor declaration for renaming types (newtypes)+data NewConstrDecl+  = NewConstrDecl SpanInfo Ident TypeExpr+  | NewRecordDecl SpanInfo Ident (Ident, TypeExpr)+   deriving (Eq, Read, Show)++-- |Declaration for labelled fields+data FieldDecl = FieldDecl SpanInfo [Ident] TypeExpr+  deriving (Eq, Read, Show)++-- |Type expressions+data TypeExpr+  = ConstructorType SpanInfo QualIdent+  | ApplyType       SpanInfo TypeExpr TypeExpr+  | VariableType    SpanInfo Ident+  | TupleType       SpanInfo [TypeExpr]+  | ListType        SpanInfo TypeExpr+  | ArrowType       SpanInfo TypeExpr TypeExpr+  | ParenType       SpanInfo TypeExpr+  | ForallType      SpanInfo [Ident] TypeExpr+    deriving (Eq, Read, Show)++-- |Qualified type expressions+data QualTypeExpr = QualTypeExpr SpanInfo Context TypeExpr+    deriving (Eq, Read, Show)++-- ---------------------------------------------------------------------------+-- Type classes+-- ---------------------------------------------------------------------------++type Context = [Constraint]++data Constraint = Constraint SpanInfo QualIdent TypeExpr+    deriving (Eq, Read, Show)++type InstanceType = TypeExpr++-- ---------------------------------------------------------------------------+-- Functions+-- ---------------------------------------------------------------------------++-- |Function defining equation+data Equation a = Equation SpanInfo (Lhs a) (Rhs a)+    deriving (Eq, Read, Show)++-- |Left-hand-side of an 'Equation' (function identifier and patterns)+data Lhs a+  = FunLhs SpanInfo Ident [Pattern a]             -- f x y+  | OpLhs  SpanInfo (Pattern a) Ident (Pattern a) -- x $ y+  | ApLhs  SpanInfo (Lhs a) [Pattern a]           -- ($) x y+    deriving (Eq, Read, Show)++-- |Right-hand-side of an 'Equation'+data Rhs a+  = SimpleRhs  SpanInfo LayoutInfo (Expression a) [Decl a] -- @expr where decls@+  | GuardedRhs SpanInfo LayoutInfo [CondExpr a]   [Decl a] -- @| cond = expr where decls@+    deriving (Eq, Read, Show)++-- |Conditional expression (expression conditioned by a guard)+data CondExpr a = CondExpr SpanInfo (Expression a) (Expression a)+    deriving (Eq, Read, Show)++-- |Literal+data Literal+  = Char   Char+  | Int    Integer+  | Float  Double+  | String String+    deriving (Eq, Read, Show)++-- |Constructor term (used for patterns)+data Pattern a+  = LiteralPattern     SpanInfo a Literal+  | NegativePattern    SpanInfo a Literal+  | VariablePattern    SpanInfo a Ident+  | ConstructorPattern SpanInfo a QualIdent [Pattern a]+  | InfixPattern       SpanInfo a (Pattern a) QualIdent (Pattern a)+  | ParenPattern       SpanInfo (Pattern a)+  | RecordPattern      SpanInfo a QualIdent [Field (Pattern a)] -- C { l1 = p1, ..., ln = pn }+  | TuplePattern       SpanInfo [Pattern a]+  | ListPattern        SpanInfo a [Pattern a]+  | AsPattern          SpanInfo Ident (Pattern a)+  | LazyPattern        SpanInfo (Pattern a)+  | FunctionPattern    SpanInfo a QualIdent [Pattern a]+  | InfixFuncPattern   SpanInfo a (Pattern a) QualIdent (Pattern a)+    deriving (Eq, Read, Show)++-- |Expression+data Expression a+  = Literal           SpanInfo a Literal+  | Variable          SpanInfo a QualIdent+  | Constructor       SpanInfo a QualIdent+  | Paren             SpanInfo (Expression a)+  | Typed             SpanInfo (Expression a) QualTypeExpr+  | Record            SpanInfo a QualIdent [Field (Expression a)]    -- C {l1 = e1,..., ln = en}+  | RecordUpdate      SpanInfo (Expression a) [Field (Expression a)] -- e {l1 = e1,..., ln = en}+  | Tuple             SpanInfo [Expression a]+  | List              SpanInfo a [Expression a]+  | ListCompr         SpanInfo (Expression a) [Statement a]   -- the ref corresponds to the main list+  | EnumFrom          SpanInfo (Expression a)+  | EnumFromThen      SpanInfo (Expression a) (Expression a)+  | EnumFromTo        SpanInfo (Expression a) (Expression a)+  | EnumFromThenTo    SpanInfo (Expression a) (Expression a) (Expression a)+  | UnaryMinus        SpanInfo (Expression a)+  | Apply             SpanInfo (Expression a) (Expression a)+  | InfixApply        SpanInfo (Expression a) (InfixOp a) (Expression a)+  | LeftSection       SpanInfo (Expression a) (InfixOp a)+  | RightSection      SpanInfo (InfixOp a) (Expression a)+  | Lambda            SpanInfo [Pattern a] (Expression a)+  | Let               SpanInfo LayoutInfo [Decl a] (Expression a)+  | Do                SpanInfo LayoutInfo [Statement a] (Expression a)+  | IfThenElse        SpanInfo (Expression a) (Expression a) (Expression a)+  | Case              SpanInfo LayoutInfo CaseType (Expression a) [Alt a]+    deriving (Eq, Read, Show)++-- |Infix operation+data InfixOp a+  = InfixOp     a QualIdent+  | InfixConstr a QualIdent+    deriving (Eq, Read, Show)++-- |Statement (used for do-sequence and list comprehensions)+data Statement a+  = StmtExpr SpanInfo (Expression a)+  | StmtDecl SpanInfo LayoutInfo [Decl a]+  | StmtBind SpanInfo (Pattern a) (Expression a)+    deriving (Eq, Read, Show)++-- |Type of case expressions+data CaseType+  = Rigid+  | Flex+    deriving (Eq, Read, Show)++-- |Single case alternative+data Alt a = Alt SpanInfo (Pattern a) (Rhs a)+    deriving (Eq, Read, Show)++-- |Record field+data Field a = Field SpanInfo QualIdent a+    deriving (Eq, Read, Show)++-- |Annotated identifier+data Var a = Var a Ident+    deriving (Eq, Read, Show)++-- ---------------------------------------------------------------------------+-- Goals+-- ---------------------------------------------------------------------------++-- |Goal in REPL (expression to evaluate)+data Goal a = Goal SpanInfo LayoutInfo (Expression a) [Decl a]+    deriving (Eq, Read, Show)++-- ---------------------------------------------------------------------------+-- instances+-- ---------------------------------------------------------------------------++instance Functor Module where+  fmap f (Module sp li ps m es is ds) = Module sp li ps m es is (map (fmap f) ds)++instance Functor Decl where+  fmap _ (InfixDecl sp fix prec ops) = InfixDecl sp fix prec ops+  fmap _ (DataDecl sp tc tvs cs clss) = DataDecl sp tc tvs cs clss+  fmap _ (ExternalDataDecl sp tc tvs) = ExternalDataDecl sp tc tvs+  fmap _ (NewtypeDecl sp tc tvs nc clss) = NewtypeDecl sp tc tvs nc clss+  fmap _ (TypeDecl sp tc tvs ty) = TypeDecl sp tc tvs ty+  fmap _ (TypeSig sp fs qty) = TypeSig sp fs qty+  fmap f (FunctionDecl sp a f' eqs) = FunctionDecl sp (f a) f' (map (fmap f) eqs)+  fmap f (ExternalDecl sp vs) = ExternalDecl sp (map (fmap f) vs)+  fmap f (PatternDecl sp t rhs) = PatternDecl sp (fmap f t) (fmap f rhs)+  fmap f (FreeDecl sp vs) = FreeDecl sp (map (fmap f) vs)+  fmap _ (DefaultDecl sp tys) = DefaultDecl sp tys+  fmap f (ClassDecl sp li cx cls clsvar ds) =+    ClassDecl sp li cx cls clsvar (map (fmap f) ds)+  fmap f (InstanceDecl sp li cx qcls inst ds) =+    InstanceDecl sp li cx qcls inst (map (fmap f) ds)++instance Functor Equation where+  fmap f (Equation p lhs rhs) = Equation p (fmap f lhs) (fmap f rhs)++instance Functor Lhs where+  fmap f (FunLhs p f' ts) = FunLhs p f' (map (fmap f) ts)+  fmap f (OpLhs p t1 op t2) = OpLhs p (fmap f t1) op (fmap f t2)+  fmap f (ApLhs p lhs ts) = ApLhs p (fmap f lhs) (map (fmap f) ts)++instance Functor Rhs where+  fmap f (SimpleRhs p li e ds) = SimpleRhs p li (fmap f e) (map (fmap f) ds)+  fmap f (GuardedRhs p li cs ds) = GuardedRhs p li (map (fmap f) cs) (map (fmap f) ds)++instance Functor CondExpr where+  fmap f (CondExpr p g e) = CondExpr p (fmap f g) (fmap f e)++instance Functor Pattern where+  fmap f (LiteralPattern p a l) = LiteralPattern p (f a) l+  fmap f (NegativePattern p a l) = NegativePattern p (f a) l+  fmap f (VariablePattern p a v) = VariablePattern p (f a) v+  fmap f (ConstructorPattern p a c ts) =+    ConstructorPattern p (f a) c (map (fmap f) ts)+  fmap f (InfixPattern p a t1 op t2) =+    InfixPattern p (f a) (fmap f t1) op (fmap f t2)+  fmap f (ParenPattern p t) = ParenPattern p (fmap f t)+  fmap f (RecordPattern p a c fs) =+    RecordPattern p (f a) c (map (fmap (fmap f)) fs)+  fmap f (TuplePattern p ts) = TuplePattern p (map (fmap f) ts)+  fmap f (ListPattern p a ts) = ListPattern p (f a) (map (fmap f) ts)+  fmap f (AsPattern p v t) = AsPattern p v (fmap f t)+  fmap f (LazyPattern p t) = LazyPattern p (fmap f t)+  fmap f (FunctionPattern p a f' ts) =+    FunctionPattern p (f a) f' (map (fmap f) ts)+  fmap f (InfixFuncPattern p a t1 op t2) =+    InfixFuncPattern p (f a) (fmap f t1) op (fmap f t2)++instance Functor Expression where+  fmap f (Literal p a l) = Literal p (f a) l+  fmap f (Variable p a v) = Variable p (f a) v+  fmap f (Constructor p a c) = Constructor p (f a) c+  fmap f (Paren p e) = Paren p (fmap f e)+  fmap f (Typed p e qty) = Typed p (fmap f e) qty+  fmap f (Record p a c fs) = Record p (f a) c (map (fmap (fmap f)) fs)+  fmap f (RecordUpdate p e fs) = RecordUpdate p (fmap f e) (map (fmap (fmap f)) fs)+  fmap f (Tuple p es) = Tuple p (map (fmap f) es)+  fmap f (List p a es) = List p (f a) (map (fmap f) es)+  fmap f (ListCompr p e stms) = ListCompr p (fmap f e) (map (fmap f) stms)+  fmap f (EnumFrom p e) = EnumFrom p (fmap f e)+  fmap f (EnumFromThen p e1 e2) = EnumFromThen p (fmap f e1) (fmap f e2)+  fmap f (EnumFromTo p e1 e2) = EnumFromTo p (fmap f e1) (fmap f e2)+  fmap f (EnumFromThenTo p e1 e2 e3) =+    EnumFromThenTo p (fmap f e1) (fmap f e2) (fmap f e3)+  fmap f (UnaryMinus p e) = UnaryMinus p (fmap f e)+  fmap f (Apply p e1 e2) = Apply p (fmap f e1) (fmap f e2)+  fmap f (InfixApply p e1 op e2) =+    InfixApply p (fmap f e1) (fmap f op) (fmap f e2)+  fmap f (LeftSection p e op) = LeftSection p (fmap f e) (fmap f op)+  fmap f (RightSection p op e) = RightSection p (fmap f op) (fmap f e)+  fmap f (Lambda p ts e) = Lambda p (map (fmap f) ts) (fmap f e)+  fmap f (Let p li ds e) = Let p li (map (fmap f) ds) (fmap f e)+  fmap f (Do p li stms e) = Do p li (map (fmap f) stms) (fmap f e)+  fmap f (IfThenElse p e1 e2 e3) =+    IfThenElse p (fmap f e1) (fmap f e2) (fmap f e3)+  fmap f (Case p li ct e as) = Case p li ct (fmap f e) (map (fmap f) as)++instance Functor InfixOp where+  fmap f (InfixOp a op) = InfixOp (f a) op+  fmap f (InfixConstr a op) = InfixConstr (f a) op++instance Functor Statement where+  fmap f (StmtExpr p e) = StmtExpr p (fmap f e)+  fmap f (StmtDecl p li ds) = StmtDecl p li (map (fmap f) ds)+  fmap f (StmtBind p t e) = StmtBind p (fmap f t) (fmap f e)++instance Functor Alt where+  fmap f (Alt p t rhs) = Alt p (fmap f t) (fmap f rhs)++instance Functor Field where+  fmap f (Field p l x) = Field p l (f x)++instance Functor Var where+  fmap f (Var a v) = Var (f a) v++instance Functor Goal where+  fmap f (Goal p li e ds) = Goal p li (fmap f e) (map (fmap f) ds)++instance Pretty Infix where+  pPrint InfixL = text "infixl"+  pPrint InfixR = text "infixr"+  pPrint Infix  = text "infix"++instance HasSpanInfo (Module a) where+  getSpanInfo (Module sp _ _ _ _ _ _) = sp++  setSpanInfo sp (Module _ li ps m es is ds) = Module sp li ps m es is ds++  updateEndPos m@(Module _ _ _ _ _ _ (d:ds)) =+    setEndPosition (getSrcSpanEnd (last (d:ds))) m+  updateEndPos m@(Module _ _ _ _ _ (i:is) _) =+    setEndPosition (getSrcSpanEnd (last (i:is))) m+  updateEndPos m@(Module (SpanInfo _ (s:ss)) _ _ _ _ _ _) =+    setEndPosition (end (last (s:ss))) m+  updateEndPos m@(Module _ _ (p:ps) _ _ _ _) =+    setEndPosition (getSrcSpanEnd (last (p:ps))) m+  updateEndPos m = m++  getLayoutInfo (Module _ li _ _ _ _ _) = li++instance HasSpanInfo (Decl a) where+  getSpanInfo (InfixDecl        sp _ _ _)   = sp+  getSpanInfo (DataDecl         sp _ _ _ _) = sp+  getSpanInfo (ExternalDataDecl sp _ _)     = sp+  getSpanInfo (NewtypeDecl      sp _ _ _ _) = sp+  getSpanInfo (TypeDecl         sp _ _ _)   = sp+  getSpanInfo (TypeSig          sp _ _)     = sp+  getSpanInfo (FunctionDecl     sp _ _ _)   = sp+  getSpanInfo (ExternalDecl     sp _)       = sp+  getSpanInfo (PatternDecl      sp _ _)     = sp+  getSpanInfo (FreeDecl         sp _)       = sp+  getSpanInfo (DefaultDecl      sp _)       = sp+  getSpanInfo (ClassDecl        sp _ _ _ _ _) = sp+  getSpanInfo (InstanceDecl     sp _ _ _ _ _) = sp++  setSpanInfo sp (InfixDecl _ fix prec ops) = InfixDecl sp fix prec ops+  setSpanInfo sp (DataDecl _ tc tvs cs clss) = DataDecl sp tc tvs cs clss+  setSpanInfo sp (ExternalDataDecl _ tc tvs) = ExternalDataDecl sp tc tvs+  setSpanInfo sp (NewtypeDecl _ tc tvs nc clss) = NewtypeDecl sp tc tvs nc clss+  setSpanInfo sp (TypeDecl _ tc tvs ty) = TypeDecl sp tc tvs ty+  setSpanInfo sp (TypeSig _ fs qty) = TypeSig sp fs qty+  setSpanInfo sp (FunctionDecl _ a f' eqs) = FunctionDecl sp a f' eqs+  setSpanInfo sp (ExternalDecl _ vs) = ExternalDecl sp vs+  setSpanInfo sp (PatternDecl _ t rhs) = PatternDecl sp t rhs+  setSpanInfo sp (FreeDecl _ vs) = FreeDecl sp vs+  setSpanInfo sp (DefaultDecl _ tys) = DefaultDecl sp tys+  setSpanInfo sp (ClassDecl _ li cx cls clsvar ds) = ClassDecl sp li cx cls clsvar ds+  setSpanInfo sp (InstanceDecl _ li cx qcls inst ds) = InstanceDecl sp li cx qcls inst ds++  updateEndPos d@(InfixDecl _ _ _ ops) =+    let i' = last ops+    in setEndPosition (incr (getPosition i') (identLength i' - 1)) d+  updateEndPos d@(DataDecl _ _ _ _ (c:cs)) =+    let i' = last (c:cs)+    in setEndPosition (incr (getPosition i') (qIdentLength i' - 1)) d+  updateEndPos d@(DataDecl _ _ _ (c:cs) _) =+    setEndPosition (getSrcSpanEnd (last (c:cs))) d+  updateEndPos d@(DataDecl _ _ (i:is) _ _) =+    let i' = last (i:is)+    in setEndPosition (incr (getPosition i') (identLength i' - 1)) d+  updateEndPos d@(DataDecl _ i _ _ _) =+    setEndPosition (incr (getPosition i) (identLength i - 1)) d+  updateEndPos d@(ExternalDataDecl _ _ (i:is)) =+    let i' = last (i:is)+    in setEndPosition (incr (getPosition i') (identLength i' - 1)) d+  updateEndPos d@(ExternalDataDecl _ i _) =+    setEndPosition (incr (getPosition i) (identLength i - 1)) d+  updateEndPos d@(NewtypeDecl _ _ _ _ (c:cs)) =+    let i' = last (c:cs)+    in setEndPosition (incr (getPosition i') (qIdentLength i' - 1)) d+  updateEndPos d@(NewtypeDecl _ _ _ c _) =+    setEndPosition (getSrcSpanEnd c) d+  updateEndPos d@(TypeDecl _ _ _ ty) =+    setEndPosition (getSrcSpanEnd ty) d+  updateEndPos d@(TypeSig _ _ qty) =+    setEndPosition (getSrcSpanEnd qty) d+  updateEndPos d@(FunctionDecl _ _ _ eqs) =+    setEndPosition (getSrcSpanEnd (last eqs)) d+  updateEndPos d@(ExternalDecl (SpanInfo _ ss) _) =+    setEndPosition (end (last ss)) d+  updateEndPos d@(ExternalDecl _ _) = d+  updateEndPos d@(PatternDecl _ _ rhs) =+    setEndPosition (getSrcSpanEnd rhs) d+  updateEndPos d@(FreeDecl (SpanInfo _ ss) _) =+    setEndPosition (end (last ss)) d+  updateEndPos d@(FreeDecl _ _) = d+  updateEndPos d@(DefaultDecl (SpanInfo _ ss) _) =+    setEndPosition (end (last ss)) d+  updateEndPos d@(DefaultDecl _ _) = d+  updateEndPos d@(ClassDecl _ _ _ _ _ (d':ds)) =+    setEndPosition (getSrcSpanEnd (last (d':ds))) d+  updateEndPos d@(ClassDecl (SpanInfo _ ss) _ _ _ _ _) =+    setEndPosition (end (last ss)) d+  updateEndPos d@(ClassDecl _ _ _ _ _ _) = d+  updateEndPos d@(InstanceDecl _ _ _ _ _ (d':ds)) =+    setEndPosition (getSrcSpanEnd (last (d':ds))) d+  updateEndPos d@(InstanceDecl (SpanInfo _ ss) _ _ _ _ _) =+    setEndPosition (end (last ss)) d+  updateEndPos d@(InstanceDecl _ _ _ _ _ _) = d++  getLayoutInfo (ClassDecl _ li _ _ _ _) = li+  getLayoutInfo (InstanceDecl _ li _ _ _ _) = li+  getLayoutInfo _ = WhitespaceLayout++instance HasSpanInfo (Equation a) where+  getSpanInfo (Equation spi _ _) = spi+  setSpanInfo spi (Equation _ lhs rhs) = Equation spi lhs rhs+  updateEndPos e@(Equation _ _ rhs) =+    setEndPosition (getSrcSpanEnd rhs) e++instance HasSpanInfo ModulePragma where+  getSpanInfo (LanguagePragma sp _  ) = sp+  getSpanInfo (OptionsPragma  sp _ _) = sp++  setSpanInfo sp (LanguagePragma _ ex ) = LanguagePragma sp ex+  setSpanInfo sp (OptionsPragma  _ t a) = OptionsPragma sp t a++  updateEndPos p@(LanguagePragma (SpanInfo _ ss) _) =+    setEndPosition (end (last ss)) p+  updateEndPos p@(LanguagePragma _ _) = p+  updateEndPos p@(OptionsPragma (SpanInfo _ ss) _ _) =+    setEndPosition (end (last ss)) p+  updateEndPos p@(OptionsPragma _ _ _) = p++instance HasSpanInfo ExportSpec where+  getSpanInfo (Exporting sp _) = sp+  setSpanInfo sp (Exporting _ ex) = Exporting sp ex++  updateEndPos e@(Exporting (SpanInfo _ ss) _) =+    setEndPosition (end (last ss)) e+  updateEndPos e@(Exporting _ _) = e++instance HasSpanInfo Export where+  getSpanInfo (Export sp _)           = sp+  getSpanInfo (ExportTypeWith sp _ _) = sp+  getSpanInfo (ExportTypeAll sp _)    = sp+  getSpanInfo (ExportModule sp _)     = sp++  setSpanInfo sp (Export _ qid)            = Export sp qid+  setSpanInfo sp (ExportTypeWith _ qid cs) = ExportTypeWith sp qid cs+  setSpanInfo sp (ExportTypeAll _ qid)     = ExportTypeAll sp qid+  setSpanInfo sp (ExportModule _ mid)      = ExportModule sp mid++  updateEndPos e@(Export _ idt) =+    setEndPosition (incr (getPosition idt) (qIdentLength idt - 1)) e+  updateEndPos e@(ExportTypeWith (SpanInfo _ ss) _ _) =+    setEndPosition (end (last ss)) e+  updateEndPos e@(ExportTypeWith _ _ _) = e+  updateEndPos e@(ExportTypeAll (SpanInfo _ ss) _) =+    setEndPosition (end (last ss)) e+  updateEndPos e@(ExportTypeAll _ _) = e+  updateEndPos e@(ExportModule _ mid) =+    setEndPosition (incr (getPosition mid) (mIdentLength mid - 1)) e++instance HasSpanInfo ImportDecl where+  getSpanInfo (ImportDecl sp _ _ _ _) = sp+  setSpanInfo sp (ImportDecl _ mid q as spec) = ImportDecl sp mid q as spec++  updateEndPos i@(ImportDecl _ _ _ _ (Just spec)) =+    setEndPosition (getSrcSpanEnd spec) i+  updateEndPos i@(ImportDecl _ _ _ (Just mid) _) =+    setEndPosition (incr (getPosition mid) (mIdentLength mid - 1)) i+  updateEndPos i@(ImportDecl _ mid _ _ _) =+    setEndPosition (incr (getPosition mid) (mIdentLength mid - 1)) i++instance HasSpanInfo ImportSpec where+  getSpanInfo (Importing sp _) = sp+  getSpanInfo (Hiding    sp _) = sp++  setSpanInfo sp (Importing _ im) = Importing sp im+  setSpanInfo sp (Hiding    _ im) = Hiding sp im++  updateEndPos i@(Importing (SpanInfo _ ss) _) =+    setEndPosition (end (last ss)) i+  updateEndPos i@(Importing _ _) = i+  updateEndPos i@(Hiding (SpanInfo _ ss) _) =+    setEndPosition (end (last ss)) i+  updateEndPos i@(Hiding _ _) = i++instance HasSpanInfo Import where+  getSpanInfo (Import sp _)           = sp+  getSpanInfo (ImportTypeWith sp _ _) = sp+  getSpanInfo (ImportTypeAll sp _)    = sp++  setSpanInfo sp (Import _ qid)            = Import sp qid+  setSpanInfo sp (ImportTypeWith _ qid cs) = ImportTypeWith sp qid cs+  setSpanInfo sp (ImportTypeAll _ qid)     = ImportTypeAll sp qid++  updateEndPos i@(Import _ idt) =+    setEndPosition (incr (getPosition idt) (identLength idt - 1)) i+  updateEndPos i@(ImportTypeWith (SpanInfo _ ss) _ _) =+    setEndPosition (end (last ss)) i+  updateEndPos i@(ImportTypeWith _ _ _) = i+  updateEndPos i@(ImportTypeAll (SpanInfo _ ss) _) =+    setEndPosition (end (last ss)) i+  updateEndPos i@(ImportTypeAll _ _) = i++instance HasSpanInfo ConstrDecl where+  getSpanInfo (ConstrDecl sp _ _)   = sp+  getSpanInfo (ConOpDecl  sp _ _ _) = sp+  getSpanInfo (RecordDecl sp _ _)   = sp++  setSpanInfo sp (ConstrDecl _ idt ty) = ConstrDecl sp idt ty+  setSpanInfo sp (ConOpDecl  _ ty1 idt ty2) = ConOpDecl sp ty1 idt ty2+  setSpanInfo sp (RecordDecl _ idt fd) = RecordDecl sp idt fd++  updateEndPos c@(ConstrDecl _ _ (t:ts)) =+    setEndPosition (getSrcSpanEnd (last (t:ts))) c+  updateEndPos c@(ConstrDecl _ idt _) =+    setEndPosition (incr (getPosition idt) (identLength idt - 1)) c+  updateEndPos c@(ConOpDecl _ _ _ ty) =+    setEndPosition (getSrcSpanEnd ty) c+  updateEndPos c@(RecordDecl (SpanInfo _ ss) _ _) =+    setEndPosition (end (last ss)) c+  updateEndPos c@(RecordDecl _ _ _) = c++instance HasSpanInfo NewConstrDecl where+  getSpanInfo (NewConstrDecl sp _ _)   = sp+  getSpanInfo (NewRecordDecl sp _ _)   = sp++  setSpanInfo sp (NewConstrDecl _ idt ty)  = NewConstrDecl sp idt ty+  setSpanInfo sp (NewRecordDecl _ idt fty) = NewRecordDecl sp idt fty++  updateEndPos c@(NewConstrDecl _ _ ty) =+    setEndPosition (getSrcSpanEnd ty) c+  updateEndPos c@(NewRecordDecl (SpanInfo _ ss) _ _) =+    setEndPosition (end (last ss)) c+  updateEndPos c@(NewRecordDecl _ _ _) = c++instance HasSpanInfo FieldDecl where+    getSpanInfo (FieldDecl sp _ _) = sp+    setSpanInfo sp (FieldDecl _ idt ty) = FieldDecl sp idt ty+    updateEndPos d@(FieldDecl _ _ ty) =+      setEndPosition (getSrcSpanEnd ty) d++instance HasSpanInfo TypeExpr where+  getSpanInfo (ConstructorType sp _) = sp+  getSpanInfo (ApplyType sp _ _)     = sp+  getSpanInfo (VariableType sp _)    = sp+  getSpanInfo (TupleType sp _)       = sp+  getSpanInfo (ListType sp _)        = sp+  getSpanInfo (ArrowType sp _ _)     = sp+  getSpanInfo (ParenType sp _)       = sp+  getSpanInfo (ForallType sp _ _)    = sp++  setSpanInfo sp (ConstructorType _ qid) = ConstructorType sp qid+  setSpanInfo sp (ApplyType _ ty1 ty2)   = ApplyType sp ty1 ty2+  setSpanInfo sp (VariableType _ idt)    = VariableType sp idt+  setSpanInfo sp (TupleType _ tys)       = TupleType sp tys+  setSpanInfo sp (ListType _ ty)         = ListType sp ty+  setSpanInfo sp (ArrowType _ ty1 ty2)   = ArrowType sp ty1 ty2+  setSpanInfo sp (ParenType _ ty)        = ParenType sp ty+  setSpanInfo sp (ForallType _ idt ty)   = ForallType sp idt ty++  updateEndPos t@(ConstructorType _ qid) =+    setEndPosition (incr (getPosition qid) (qIdentLength qid - 1)) t+  updateEndPos t@(ApplyType _ _ t2) =+    setEndPosition (getSrcSpanEnd t2) t+  updateEndPos t@(VariableType _ idt) =+    setEndPosition (incr (getPosition idt) (identLength idt - 1)) t+  updateEndPos t@(ListType (SpanInfo _ (s:ss)) _) =+    setEndPosition (end (last (s:ss))) t+  updateEndPos t@(ListType _ _) = t+  updateEndPos t@(TupleType _ tys) =+    setEndPosition (getSrcSpanEnd (last tys)) t+  updateEndPos t@(ArrowType _ _ t2) =+    setEndPosition (getSrcSpanEnd t2) t+  updateEndPos t@(ParenType (SpanInfo _ (s:ss)) _) =+    setEndPosition (end (last (s:ss))) t+  updateEndPos t@(ParenType _ _) = t+  updateEndPos t@(ForallType _ _ _) = t -- not a parseable type++instance HasSpanInfo QualTypeExpr where+  getSpanInfo (QualTypeExpr sp _ _) = sp+  setSpanInfo sp (QualTypeExpr _ cx ty) = QualTypeExpr sp cx ty+  updateEndPos t@(QualTypeExpr _ _ ty) =+    setEndPosition (getSrcSpanEnd ty) t++instance HasSpanInfo Constraint where+  getSpanInfo (Constraint sp _ _) = sp+  setSpanInfo sp (Constraint _ qid ty) = Constraint sp qid ty+  updateEndPos c@(Constraint (SpanInfo _ (s:ss)) _ _) =+    setEndPosition (end (last (s:ss))) c+  updateEndPos c@(Constraint _ _ ty) =+    setEndPosition (getSrcSpanEnd ty) c++instance HasSpanInfo (Lhs a) where+  getSpanInfo (FunLhs sp _ _)   = sp+  getSpanInfo (OpLhs  sp _ _ _) = sp+  getSpanInfo (ApLhs  sp _ _)   = sp++  setSpanInfo sp (FunLhs _ idt ps)    = FunLhs sp idt ps+  setSpanInfo sp (OpLhs  _ p1 idt p2) = OpLhs sp p1 idt p2+  setSpanInfo sp (ApLhs  _ lhs ps)    = ApLhs sp lhs ps++  updateEndPos l@(FunLhs _ _ (p:ps)) =+    setEndPosition (getSrcSpanEnd (last (p:ps))) l+  updateEndPos l@(FunLhs _ idt _) =+    setEndPosition (incr (getPosition idt) (identLength idt - 1)) l+  updateEndPos l@(OpLhs _ _ _ p) =+    setEndPosition (getSrcSpanEnd p) l+  updateEndPos l@(ApLhs _ _ (p:ps)) =+    setEndPosition (getSrcSpanEnd (last (p:ps))) l+  updateEndPos l@(ApLhs (SpanInfo _ [_,s]) _ _) =+    setEndPosition (end s) l+  updateEndPos l@(ApLhs _ _ _) = l+++instance HasSpanInfo (Rhs a) where+  getSpanInfo (SimpleRhs sp _ _ _)  = sp+  getSpanInfo (GuardedRhs sp _ _ _) = sp++  setSpanInfo sp (SimpleRhs _ li ex ds)  = SimpleRhs sp li ex ds+  setSpanInfo sp (GuardedRhs _ li cs ds) = GuardedRhs sp li cs ds++  updateEndPos r@(SimpleRhs (SpanInfo _ [_,_]) _ _ (d:ds)) =+    setEndPosition (getSrcSpanEnd (last (d:ds))) r+  updateEndPos r@(SimpleRhs (SpanInfo _ [_,s]) _ _ _) =+    setEndPosition (end s) r+  updateEndPos r@(SimpleRhs _ _ e _) =+    setEndPosition (getSrcSpanEnd e) r+  updateEndPos r@(GuardedRhs (SpanInfo _ [_,_]) _ _ (d:ds)) =+    setEndPosition (getSrcSpanEnd (last (d:ds))) r+  updateEndPos r@(GuardedRhs (SpanInfo _ [_,s]) _ _ _) =+    setEndPosition (end s) r+  updateEndPos r@(GuardedRhs _ _ cs _) =+    setEndPosition (getSrcSpanEnd (last cs)) r++  getLayoutInfo (SimpleRhs _ li _ _) = li+  getLayoutInfo (GuardedRhs _ li _ _) = li++instance HasSpanInfo (CondExpr a) where+  getSpanInfo (CondExpr sp _ _) = sp+  setSpanInfo sp (CondExpr _ e1 e2) = CondExpr sp e1 e2+  updateEndPos ce@(CondExpr _ _ e) =+    setEndPosition (getSrcSpanEnd e) ce++instance HasSpanInfo (Pattern a) where+  getSpanInfo (LiteralPattern  sp _ _)      = sp+  getSpanInfo (NegativePattern sp _ _)      = sp+  getSpanInfo (VariablePattern sp _ _)      = sp+  getSpanInfo (ConstructorPattern sp _ _ _) = sp+  getSpanInfo (InfixPattern sp _ _ _ _)     = sp+  getSpanInfo (ParenPattern sp _)           = sp+  getSpanInfo (RecordPattern sp _ _ _)      = sp+  getSpanInfo (TuplePattern sp _)           = sp+  getSpanInfo (ListPattern sp _ _)          = sp+  getSpanInfo (AsPattern sp _ _)            = sp+  getSpanInfo (LazyPattern sp _)            = sp+  getSpanInfo (FunctionPattern sp _ _ _)    = sp+  getSpanInfo (InfixFuncPattern sp _ _ _ _) = sp++  setSpanInfo sp (LiteralPattern _ a l) = LiteralPattern sp a l+  setSpanInfo sp (NegativePattern _ a l) = NegativePattern sp a l+  setSpanInfo sp (VariablePattern _ a v) = VariablePattern sp a v+  setSpanInfo sp (ConstructorPattern _ a c ts) = ConstructorPattern sp a c ts+  setSpanInfo sp (InfixPattern _ a t1 op t2) = InfixPattern sp a t1 op t2+  setSpanInfo sp (ParenPattern _ t) = ParenPattern sp t+  setSpanInfo sp (RecordPattern _ a c fs) = RecordPattern sp a c fs+  setSpanInfo sp (TuplePattern _ ts) = TuplePattern sp ts+  setSpanInfo sp (ListPattern _ a ts) = ListPattern sp a ts+  setSpanInfo sp (AsPattern _ v t) = AsPattern sp v t+  setSpanInfo sp (LazyPattern _ t) = LazyPattern sp t+  setSpanInfo sp (FunctionPattern _ a f' ts) = FunctionPattern sp a f' ts+  setSpanInfo sp (InfixFuncPattern _ a t1 op t2) = InfixFuncPattern sp a t1 op t2++  updateEndPos p@(LiteralPattern  _ _ _) = p+  updateEndPos p@(NegativePattern _ _ _) = p+  updateEndPos p@(VariablePattern _ _ v) =+    setEndPosition (incr (getPosition v) (identLength v - 1)) p+  updateEndPos p@(ConstructorPattern _ _ _ (t:ts)) =+    setEndPosition (getSrcSpanEnd (last (t:ts))) p+  updateEndPos p@(ConstructorPattern _ _ c _) =+    setEndPosition (incr (getPosition c) (qIdentLength c - 1)) p+  updateEndPos p@(InfixPattern _ _ _ _ t2) =+    setEndPosition (getSrcSpanEnd t2) p+  updateEndPos p@(ParenPattern (SpanInfo _ (s:ss)) _) =+    setEndPosition (end (last (s:ss))) p+  updateEndPos p@(ParenPattern _ _) = p+  updateEndPos p@(RecordPattern (SpanInfo _ (s:ss)) _ _ _) =+    setEndPosition (end (last (s:ss))) p+  updateEndPos p@(RecordPattern _ _ _ _) = p+  updateEndPos p@(TuplePattern (SpanInfo _ (s:ss)) _) =+    setEndPosition (end (last (s:ss))) p+  updateEndPos p@(TuplePattern _ _) = p+  updateEndPos p@(ListPattern (SpanInfo _ (s:ss)) _ _) =+    setEndPosition (end (last (s:ss))) p+  updateEndPos p@(ListPattern _ _ _) = p+  updateEndPos p@(AsPattern _ _ t) =+    setEndPosition (getSrcSpanEnd t) p+  updateEndPos p@(LazyPattern _ t) =+    setEndPosition (getSrcSpanEnd t) p+  updateEndPos p@(FunctionPattern _ _ _ _) = p+  updateEndPos p@(InfixFuncPattern _ _ _ _ _) = p++instance HasSpanInfo (Expression a) where+  getSpanInfo (Literal sp _ _) = sp+  getSpanInfo (Variable sp _ _) = sp+  getSpanInfo (Constructor sp _ _) = sp+  getSpanInfo (Paren sp _) = sp+  getSpanInfo (Typed sp _ _) = sp+  getSpanInfo (Record sp _ _ _) = sp+  getSpanInfo (RecordUpdate sp _ _) = sp+  getSpanInfo (Tuple sp _) = sp+  getSpanInfo (List sp _ _) = sp+  getSpanInfo (ListCompr sp _ _) = sp+  getSpanInfo (EnumFrom sp _) = sp+  getSpanInfo (EnumFromThen sp _ _) = sp+  getSpanInfo (EnumFromTo sp _ _) = sp+  getSpanInfo (EnumFromThenTo sp _ _ _) = sp+  getSpanInfo (UnaryMinus sp _) = sp+  getSpanInfo (Apply sp _ _) = sp+  getSpanInfo (InfixApply sp _ _ _) = sp+  getSpanInfo (LeftSection sp _ _) = sp+  getSpanInfo (RightSection sp _ _) = sp+  getSpanInfo (Lambda sp _ _) = sp+  getSpanInfo (Let sp _ _ _) = sp+  getSpanInfo (Do sp _ _ _) = sp+  getSpanInfo (IfThenElse sp _ _ _) = sp+  getSpanInfo (Case sp _ _ _ _) = sp++  setSpanInfo sp (Literal _ a l) = Literal sp a l+  setSpanInfo sp (Variable _ a v) = Variable sp a v+  setSpanInfo sp (Constructor _ a c) = Constructor sp a c+  setSpanInfo sp (Paren _ e) = Paren sp e+  setSpanInfo sp (Typed _ e qty) = Typed sp e qty+  setSpanInfo sp (Record _ a c fs) = Record sp a c fs+  setSpanInfo sp (RecordUpdate _ e fs) = RecordUpdate sp e fs+  setSpanInfo sp (Tuple _ es) = Tuple sp es+  setSpanInfo sp (List _ a es) = List sp a es+  setSpanInfo sp (ListCompr _ e stms) = ListCompr sp e stms+  setSpanInfo sp (EnumFrom _ e) = EnumFrom sp e+  setSpanInfo sp (EnumFromThen _ e1 e2) = EnumFromThen sp e1 e2+  setSpanInfo sp (EnumFromTo _ e1 e2) = EnumFromTo sp e1 e2+  setSpanInfo sp (EnumFromThenTo _ e1 e2 e3) = EnumFromThenTo sp e1 e2 e3+  setSpanInfo sp (UnaryMinus _ e) = UnaryMinus sp e+  setSpanInfo sp (Apply _ e1 e2) = Apply sp e1 e2+  setSpanInfo sp (InfixApply _ e1 op e2) = InfixApply sp e1 op e2+  setSpanInfo sp (LeftSection _ e op) = LeftSection sp e op+  setSpanInfo sp (RightSection _ op e) = RightSection sp op e+  setSpanInfo sp (Lambda _ ts e) = Lambda sp ts e+  setSpanInfo sp (Let _ li ds e) = Let sp li ds e+  setSpanInfo sp (Do _ li stms e) = Do sp li stms e+  setSpanInfo sp (IfThenElse _ e1 e2 e3) = IfThenElse sp e1 e2 e3+  setSpanInfo sp (Case _ li ct e as) = Case sp li ct e as++  updateEndPos e@(Literal _ _ _) = e+  updateEndPos e@(Variable _ _ v) =+    setEndPosition (incr (getPosition v) (qIdentLength v - 1)) e+  updateEndPos e@(Constructor _ _ c) =+    setEndPosition (incr (getPosition c) (qIdentLength c - 1)) e+  updateEndPos e@(Paren (SpanInfo _ [_,s]) _) =+    setEndPosition (end s) e+  updateEndPos e@(Paren _ _) = e+  updateEndPos e@(Typed _ _ qty) =+    setEndPosition (getSrcSpanEnd qty) e+  updateEndPos e@(Record (SpanInfo _ (s:ss)) _ _ _) =+    setEndPosition (end (last (s:ss))) e+  updateEndPos e@(Record _ _ _ _) = e+  updateEndPos e@(RecordUpdate (SpanInfo _ (s:ss)) _ _) =+    setEndPosition (end (last (s:ss))) e+  updateEndPos e@(RecordUpdate _ _ _) = e+  updateEndPos e@(Tuple (SpanInfo _ [_,s]) _) =+    setEndPosition (end s) e+  updateEndPos e@(Tuple _ _) = e+  updateEndPos e@(List (SpanInfo _ (s:ss)) _ _) =+    setEndPosition (end (last (s:ss))) e+  updateEndPos e@(List _ _ _) = e+  updateEndPos e@(ListCompr (SpanInfo _ (s:ss)) _ _) =+    setEndPosition (end (last (s:ss))) e+  updateEndPos e@(ListCompr _ _ _) = e+  updateEndPos e@(EnumFrom (SpanInfo _ [_,_,s]) _) =+    setEndPosition (end s) e+  updateEndPos e@(EnumFrom _ _) = e+  updateEndPos e@(EnumFromTo (SpanInfo _ [_,_,s]) _ _) =+    setEndPosition (end s) e+  updateEndPos e@(EnumFromTo _ _ _) = e+  updateEndPos e@(EnumFromThen (SpanInfo _ [_,_,_,s]) _ _) =+    setEndPosition (end s) e+  updateEndPos e@(EnumFromThen _ _ _) = e+  updateEndPos e@(EnumFromThenTo (SpanInfo _ [_,_,_,s]) _ _ _) =+    setEndPosition (end s) e+  updateEndPos e@(EnumFromThenTo _ _ _ _) = e+  updateEndPos e@(UnaryMinus _ e') =+    setEndPosition (getSrcSpanEnd e') e+  updateEndPos e@(Apply _ _ e') =+    setEndPosition (getSrcSpanEnd e') e+  updateEndPos e@(InfixApply _ _ _ e') =+    setEndPosition (getSrcSpanEnd e') e+  updateEndPos e@(LeftSection (SpanInfo _ [_,s]) _ _) =+    setEndPosition (end s) e+  updateEndPos e@(LeftSection _ _ _) = e+  updateEndPos e@(RightSection (SpanInfo _ [_,s]) _ _) =+    setEndPosition (end s) e+  updateEndPos e@(RightSection _ _ _) = e+  updateEndPos e@(Lambda _ _ e') =+    setEndPosition (getSrcSpanEnd e') e+  updateEndPos e@(Let _ _ _ e') =+    setEndPosition (getSrcSpanEnd e') e+  updateEndPos e@(Do _ _ _ e') =+    setEndPosition (getSrcSpanEnd e') e+  updateEndPos e@(IfThenElse _ _ _ e') =+    setEndPosition (getSrcSpanEnd e') e+  updateEndPos e@(Case _ _ _ _ (a:as)) =+    setEndPosition (getSrcSpanEnd (last (a:as))) e+  updateEndPos e@(Case (SpanInfo _ (s:ss)) _ _ _ _) =+    setEndPosition (end (last (s:ss))) e+  updateEndPos e@(Case _ _ _ _ _) = e++  getLayoutInfo (Let _ li _ _) = li+  getLayoutInfo (Do _ li _ _) = li+  getLayoutInfo (Case _ li _ _ _) = li+  getLayoutInfo _ = WhitespaceLayout++instance HasSpanInfo (Statement a) where+  getSpanInfo (StmtExpr sp _)   = sp+  getSpanInfo (StmtDecl sp _ _) = sp+  getSpanInfo (StmtBind sp _ _) = sp++  setSpanInfo sp (StmtExpr _    ex) = StmtExpr sp ex+  setSpanInfo sp (StmtDecl _ li ds) = StmtDecl sp li ds+  setSpanInfo sp (StmtBind _ p  ex) = StmtBind sp p ex++  updateEndPos s@(StmtExpr _ e) =+    setEndPosition (getSrcSpanEnd e) s+  updateEndPos s@(StmtBind _ _ e) =+    setEndPosition (getSrcSpanEnd e) s+  updateEndPos s@(StmtDecl _ _ (d:ds)) =+    setEndPosition (getSrcSpanEnd (last (d:ds))) s+  updateEndPos s@(StmtDecl (SpanInfo _ [s']) _ _) = -- empty let+    setEndPosition (end s') s+  updateEndPos s@(StmtDecl _ _ _) = s++  getLayoutInfo (StmtDecl _ li _) = li+  getLayoutInfo _ = WhitespaceLayout++instance HasSpanInfo (Alt a) where+  getSpanInfo (Alt sp _ _) = sp+  setSpanInfo sp (Alt _ p rhs) = Alt sp p rhs+  updateEndPos a@(Alt _ _ rhs) =+    setEndPosition (getSrcSpanEnd rhs) a++instance HasSpanInfo (Field a) where+  getSpanInfo (Field sp _ _) = sp+  setSpanInfo sp (Field _ qid a) = Field sp qid a+  updateEndPos f@(Field (SpanInfo _ ss) _ _) =+    setEndPosition (end (last ss)) f+  updateEndPos f@ (Field _ _ _) = f++instance HasSpanInfo (Goal a) where+  getSpanInfo (Goal sp _ _ _) = sp+  setSpanInfo sp (Goal _ li e ds) = Goal sp li e ds++  updateEndPos g@(Goal (SpanInfo _ [_]) _ _ (d:ds)) =+    setEndPosition (getSrcSpanEnd (last (d:ds))) g+  updateEndPos g@(Goal (SpanInfo _ [s]) _ _ _) =+    setEndPosition (end s) g+  updateEndPos g@(Goal _ _ _ _) = g++  getLayoutInfo (Goal _ li _ _) = li++instance HasPosition (Module a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (Decl a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (Equation a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition ModulePragma where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition ExportSpec where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition ImportDecl where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition ImportSpec where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition Export where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition Import where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition ConstrDecl where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition TypeExpr where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition QualTypeExpr where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition NewConstrDecl where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition Constraint where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition FieldDecl where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (Lhs a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (Rhs a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (CondExpr a) where+  getPosition = getStartPosition++instance HasPosition (Pattern a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (Expression a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (Alt a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (Goal a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (Field a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (Statement a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (InfixOp a) where+  getPosition (InfixOp     _ q) = getPosition q+  getPosition (InfixConstr _ q) = getPosition q++  setPosition p (InfixOp     a q) = InfixOp     a (setPosition p q)+  setPosition p (InfixConstr a q) = InfixConstr a (setPosition p q)++instance Binary a => Binary (Module a) where+  put (Module spi li ps mid ex im ds) = put spi >> put li >> put ps >>+                                        put mid >> put ex >> put im >> put ds+  get = Module <$> get <*> get <*> get <*> get <*> get <*> get <*> get++instance Binary ModulePragma where+  put (LanguagePragma spi ex  ) = putWord8 0 >> put spi >> put ex+  put (OptionsPragma  spi t  s) = putWord8 1 >> put spi >> put t >> put s++  get = do+    x <- getWord8+    case x of+      0 -> liftM2 LanguagePragma get get+      1 -> liftM3 OptionsPragma get get get+      _ -> fail "Invalid encoding for ModulePragma"++instance Binary ExportSpec where+  put (Exporting spi es) = put spi >> put es+  get = liftM2 Exporting get get++instance Binary Export where+  put (Export         spi qid   ) = putWord8 0 >> put spi >> put qid+  put (ExportTypeWith spi qid is) = putWord8 1 >> put spi >> put qid >> put is+  put (ExportTypeAll  spi qid   ) = putWord8 2 >> put spi >> put qid+  put (ExportModule   spi mid   ) = putWord8 3 >> put spi >> put mid++  get = do+    x <- getWord8+    case x of+      0 -> liftM2 Export get get+      1 -> liftM3 ExportTypeWith get get get+      2 -> liftM2 ExportTypeAll get get+      3 -> liftM2 ExportModule get get+      _ -> fail "Invalid encoding for Export"++instance Binary ImportDecl where+  put (ImportDecl spi mid q al im) = put spi >> put mid >> put q >>+                                     put al >> put im+  get = ImportDecl <$> get <*> get <*> get <*> get <*> get++instance Binary ImportSpec where+  put (Importing spi im) = putWord8 0 >> put spi >> put im+  put (Hiding    spi im) = putWord8 1 >> put spi >> put im++  get = do+    x <- getWord8+    case x of+      0 -> liftM2 Importing get get+      1 -> liftM2 Hiding get get+      _ -> fail "Invalid encoding for ImportSpec"++instance Binary Import where+  put (Import         spi idt   ) = putWord8 0 >> put spi >> put idt+  put (ImportTypeWith spi idt is) = putWord8 1 >> put spi >> put idt >> put is+  put (ImportTypeAll  spi idt   ) = putWord8 2 >> put spi >> put idt++  get = do+    x <- getWord8+    case x of+      0 -> liftM2 Import get get+      1 -> liftM3 ImportTypeWith get get get+      2 -> liftM2 ImportTypeAll get get+      _ -> fail "Invalid encoding for Import"++instance Binary a => Binary (Decl a) where+  put (InfixDecl spi i pr is) =+    putWord8 0 >> put spi >> put i >> put pr >> put is+  put (DataDecl spi idt vs cns cls) =+    putWord8 1 >> put spi >> put idt >> put vs >> put cns >> put cls+  put (ExternalDataDecl spi idt vs) =+    putWord8 2 >> put spi >> put idt >> put vs+  put (NewtypeDecl spi idt vs cn cls) =+    putWord8 3 >> put spi >> put idt >> put vs  >> put cn >> put cls >> put cls+  put (TypeDecl spi idt vs ty) =+    putWord8 4 >> put spi >> put idt >> put vs  >> put ty+  put (TypeSig spi fs ty) =+    putWord8 5 >> put spi >> put fs >> put ty+  put (FunctionDecl spi a f eqs) =+    putWord8 6 >> put spi >> put a >> put f >> put eqs+  put (ExternalDecl spi vs) =+    putWord8 7 >> put spi >> put vs+  put (PatternDecl spi p rhs) =+    putWord8 8 >> put spi >> put p >> put rhs+  put (FreeDecl spi vs) =+    putWord8 9 >> put spi >> put vs+  put (DefaultDecl spi tys) =+    putWord8 10 >> put spi >> put tys+  put (ClassDecl spi li cx cls v ds) =+    putWord8 11 >> put spi >> put li >> put cx >> put cls >> put v >> put ds+  put (InstanceDecl spi li cx cls ty ds) =+    putWord8 12 >> put spi >> put li >> put cx >> put cls >> put ty >> put ds++  get = do+    x <- getWord8+    case x of+      0  -> InfixDecl <$> get <*> get <*> get <*> get+      1  -> DataDecl <$> get <*> get <*> get <*> get <*> get+      2  -> ExternalDataDecl <$> get <*> get <*> get+      3  -> NewtypeDecl <$> get <*> get <*> get <*> get <*> get+      4  -> TypeDecl <$> get <*> get <*> get <*> get+      5  -> TypeSig <$> get <*> get <*> get+      6  -> FunctionDecl <$> get <*> get <*> get <*> get+      7  -> ExternalDecl <$> get <*> get+      8  -> PatternDecl <$> get <*> get <*> get+      9  -> FreeDecl <$> get <*> get+      10 -> DefaultDecl <$> get <*> get+      11 -> ClassDecl <$> get <*> get <*> get <*> get <*> get <*> get+      12 -> InstanceDecl <$> get <*> get <*> get <*> get <*> get <*> get+      _  -> fail "Invalid encoding for Decl"++instance Binary Infix where+  put InfixL = putWord8 0+  put InfixR = putWord8 1+  put Infix  = putWord8 2++  get = do+    x <- getWord8+    case x of+      0 -> return InfixL+      1 -> return InfixR+      2 -> return Infix+      _ -> fail "Invalid encoding for Infix"++instance Binary ConstrDecl where+  put (ConstrDecl spi idt tys) =+    putWord8 0 >> put spi >> put idt >> put tys+  put (ConOpDecl spi ty1 idt ty2) =+    putWord8 1 >> put spi >> put ty1 >> put idt >> put ty2+  put (RecordDecl spi idt fs) =+    putWord8 2 >> put spi >> put idt >> put fs++  get = do+    x <- getWord8+    case x of+      0 -> liftM3 ConstrDecl get get get+      1 -> ConOpDecl <$> get <*> get <*> get <*> get+      2 -> liftM3 RecordDecl get get get+      _ -> fail "Invalid encoding for ConstrDecl"++instance Binary NewConstrDecl where+  put (NewConstrDecl spi c ty) =+    putWord8 0 >> put spi >> put c >> put ty+  put (NewRecordDecl spi c fs) =+    putWord8 1 >> put spi >> put c >> put fs++  get = do+    x <- getWord8+    case x of+      0 -> liftM3 NewConstrDecl get get get+      1 -> liftM3 NewRecordDecl get get get+      _ -> fail "Invalid encoding for NewConstrDecl"++instance Binary FieldDecl where+  put (FieldDecl spi is ty) = put spi >> put is >> put ty+  get = liftM3 FieldDecl get get get++instance Binary QualTypeExpr where+  put (QualTypeExpr spi ctx te) = put spi >> put ctx >> put te+  get = liftM3 QualTypeExpr get get get++instance Binary TypeExpr where+  put (ConstructorType spi qid) =+    putWord8 0 >> put spi >> put qid+  put (ApplyType spi ty1 ty2) =+    putWord8 1 >> put spi >> put ty1 >> put ty2+  put (VariableType spi idt) =+    putWord8 2 >> put spi >> put idt+  put (TupleType spi tys) =+    putWord8 3 >> put spi >> put tys+  put (ListType spi ty) =+    putWord8 4 >> put spi >> put ty+  put (ArrowType spi ty1 ty2) =+    putWord8 5 >> put spi >> put ty1 >> put ty2+  put (ParenType spi ty) =+    putWord8 6 >> put spi >> put ty+  put (ForallType spi is ty) =+    putWord8 7 >> put spi >> put is >> put ty++  get = do+    x <- getWord8+    case x of+      0 -> liftM2 ConstructorType get get+      1 -> liftM3 ApplyType get get get+      2 -> liftM2 VariableType get get+      3 -> liftM2 TupleType get get+      4 -> liftM2 ListType get get+      5 -> liftM3 ArrowType get get get+      6 -> liftM2 ParenType get get+      7 -> liftM3 ForallType get get get+      _ -> fail "Invalid encoding for TypeExpr"++instance Binary Constraint where+  put (Constraint spi cls ty) = put spi >> put cls >> put ty+  get = liftM3 Constraint get get get++instance Binary a => Binary (Equation a) where+  put (Equation spi lhs rhs) = put spi >> put lhs >> put rhs+  get = liftM3 Equation get get get++instance Binary a => Binary (Lhs a) where+  put (FunLhs spi f ps) =+    putWord8 0 >> put spi >> put f >> put ps+  put (OpLhs spi p1 op p2) =+    putWord8 1 >> put spi >> put p1 >> put op >> put p2+  put (ApLhs spi lhs ps) =+    putWord8 2 >> put spi >> put lhs >> put ps++  get = do+    x <- getWord8+    case x of+      0 -> liftM3 FunLhs get get get+      1 -> OpLhs <$> get <*> get <*> get <*> get+      2 -> liftM3 ApLhs get get get+      _ -> fail "Invalid encoding for Lhs"++instance Binary a => Binary (Rhs a) where+  put (SimpleRhs spi li e ds) =+    putWord8 0 >> put spi >> put li >> put e >> put ds+  put (GuardedRhs spi li gs ds) =+    putWord8 1 >> put spi >> put li >> put gs >> put ds++  get = do+    x <- getWord8+    case x of+      0 -> SimpleRhs <$> get <*> get <*> get <*> get+      1 -> GuardedRhs <$> get <*> get <*> get <*> get+      _ -> fail "Invalid encoding for Rhs"++instance Binary a => Binary (CondExpr a) where+  put (CondExpr spi g e) = put spi >> put g >> put e+  get = liftM3 CondExpr get get get++instance Binary Literal where+  put (Char   c) = putWord8 0 >> put c+  put (Int    i) = putWord8 1 >> put i+  put (Float  f) = putWord8 2 >> put (show f)+  put (String s) = putWord8 3 >> put s++  get = do+    x <- getWord8+    case x of+      0 -> fmap Char get+      1 -> fmap Int get+      2 -> fmap (Float . read) get+      3 -> fmap String get+      _ -> fail "Invalid encoding for Literal"++instance Binary a => Binary (Pattern a) where+  put (LiteralPattern  spi a l) =+    putWord8 0 >> put spi >> put a >> put l+  put (NegativePattern spi a l) =+    putWord8 1 >> put spi >> put a >> put l+  put (VariablePattern spi a idt) =+    putWord8 2 >> put spi >> put a >> put idt+  put (ConstructorPattern spi a qid ps) =+    putWord8 3 >> put spi >> put a >> put qid >> put ps+  put (InfixPattern spi a p1 qid p2) =+    putWord8 4 >> put spi >> put a >> put p1 >> put qid >> put p2+  put (ParenPattern spi p) =+    putWord8 5 >> put spi >> put p+  put (RecordPattern spi a qid fs) =+    putWord8 6 >> put spi >> put a >> put qid >> put fs+  put (TuplePattern spi ps) =+    putWord8 7 >> put spi >> put ps+  put (ListPattern spi a ps) =+    putWord8 8 >> put spi >> put a >> put ps+  put (AsPattern spi idt p) =+    putWord8 9 >> put spi >> put idt >> put p+  put (LazyPattern spi p) =+    putWord8 10 >> put spi >> put p+  put (FunctionPattern spi a qid ps) =+    putWord8 11 >> put spi >> put a >> put qid >> put ps+  put (InfixFuncPattern spi a p1 qid p2) =+    putWord8 12 >> put spi >> put a >> put p1 >> put qid >> put p2++  get = do+    x <- getWord8+    case x of+      0  -> liftM3 LiteralPattern get get get+      1  -> liftM3 NegativePattern get get get+      2  -> liftM3 VariablePattern get get get+      3  -> ConstructorPattern <$> get <*> get <*> get <*> get+      4  -> InfixPattern <$> get <*> get <*> get <*> get <*> get+      5  -> liftM2 ParenPattern get get+      6  -> RecordPattern <$> get <*> get <*> get <*> get+      7  -> liftM2 TuplePattern get get+      8  -> liftM3 ListPattern get get get+      9  -> liftM3 AsPattern get get get+      10 -> liftM2 LazyPattern get get+      11 -> FunctionPattern <$> get <*> get <*> get <*> get+      12 -> InfixFuncPattern <$> get <*> get <*> get <*> get <*> get+      _  -> fail "Invalid encoding for Pattern"++instance Binary a => Binary (Expression a) where+  put (Literal spi a l) =+    putWord8 0 >> put spi >> put a >> put l+  put (Variable spi a qid) =+    putWord8 1 >> put spi >> put a >> put qid+  put (Constructor spi a qid) =+    putWord8 2 >> put spi >> put a >> put qid+  put (Paren spi e) =+    putWord8 3 >> put spi >> put e+  put (Typed spi e ty) =+    putWord8 4 >> put spi >> put e >> put ty+  put (Record spi a qid fs) =+    putWord8 5 >> put spi >> put a >> put qid >> put fs+  put (RecordUpdate spi e fs) =+    putWord8 6 >> put spi >> put e >> put fs+  put (Tuple spi es) =+    putWord8 7 >> put spi >> put es+  put (List spi a es) =+    putWord8 8 >> put spi >> put a >> put es+  put (ListCompr spi e stms) =+    putWord8 9 >> put spi >> put e >> put stms+  put (EnumFrom spi e1) =+    putWord8 10 >> put spi >> put e1+  put (EnumFromThen spi e1 e2) =+    putWord8 11 >> put spi >> put e1 >> put e2+  put (EnumFromTo spi e1 e2) =+    putWord8 12 >> put spi >> put e1 >> put e2+  put (EnumFromThenTo spi e1 e2 e3) =+    putWord8 13 >> put spi >> put e1 >> put e2 >> put e3+  put (UnaryMinus spi e) =+    putWord8 14 >> put spi >> put e+  put (Apply spi e1 e2) =+    putWord8 15 >> put spi >> put e1 >> put e2+  put (InfixApply spi e1 op e2) =+    putWord8 16 >> put spi >> put e1 >> put op >> put e2+  put (LeftSection spi e op) =+    putWord8 17 >> put spi >> put e >> put op+  put (RightSection spi op e) =+    putWord8 18 >> put spi >> put op >> put e+  put (Lambda spi ps e) =+    putWord8 19 >> put spi >> put ps >> put e+  put (Let spi li ds e) =+    putWord8 20 >> put spi >> put li >> put ds >> put e+  put (Do spi li stms e) =+    putWord8 21 >> put spi >> put li >> put stms >> put e+  put (IfThenElse spi e1 e2 e3) =+    putWord8 22 >> put spi >> put e1 >> put e2 >> put e3+  put (Case spi li cty e as) =+    putWord8 23 >> put spi >> put li >> put cty >> put e >> put as++  get = do+    x <- getWord8+    case x of+      0  -> liftM3 Literal get get get+      1  -> liftM3 Variable get get get+      2  -> liftM3 Constructor get get get+      3  -> liftM2 Paren get get+      4  -> liftM3 Typed get get get+      5  -> Record <$> get <*> get <*> get <*> get+      6  -> RecordUpdate <$> get <*> get <*> get+      7  -> liftM2 Tuple get get+      8  -> liftM3 List get get get+      9  -> liftM3 ListCompr get get get+      10 -> liftM2 EnumFrom get get+      11 -> liftM3 EnumFromThen get get get+      12 -> liftM3 EnumFromTo get get get+      13 -> EnumFromThenTo <$> get <*> get <*> get <*> get+      14 -> liftM2 UnaryMinus get get+      15 -> liftM3 Apply get get get+      16 -> InfixApply <$> get <*> get <*> get <*> get+      17 -> liftM3 LeftSection get get get+      18 -> liftM3 RightSection get get get+      19 -> liftM3 Lambda get get get+      20 -> Let <$> get <*> get <*> get <*> get+      21 -> Do <$> get <*> get <*> get <*> get+      22 -> IfThenElse <$> get <*> get <*> get <*> get+      23 -> Case <$> get <*> get <*> get <*> get <*> get+      _  -> fail "Invalid encoding for Expression"++instance Binary a => Binary (InfixOp a) where+  put (InfixOp     a qid) = putWord8 0 >> put a >> put qid+  put (InfixConstr a qid) = putWord8 1 >> put a >> put qid++  get = do+    x <- getWord8+    case x of+      0 -> liftM2 InfixOp get get+      1 -> liftM2 InfixConstr get get+      _ -> fail "Invalid encoding for InfixOp"++instance Binary a => Binary (Statement a) where+  put (StmtExpr spi     e) = putWord8 0 >> put spi >> put e+  put (StmtDecl spi li ds) = putWord8 1 >> put spi >> put li >> put ds+  put (StmtBind spi p   e) = putWord8 2 >> put spi >> put p >> put e++  get = do+    x <- getWord8+    case x of+      0 -> liftM2 StmtExpr get get+      1 -> liftM3 StmtDecl get get get+      2 -> liftM3 StmtBind get get get+      _ -> fail "Invalid encoding for Statement"++instance Binary CaseType where+  put Rigid = putWord8 0+  put Flex  = putWord8 1++  get = do+    x <- getWord8+    case x of+      0 -> return Rigid+      1 -> return Flex+      _ -> fail "Invalid encoding for CaseType"++instance Binary a => Binary (Alt a) where+  put (Alt spi p rhs) = put spi >> put p >> put rhs+  get = liftM3 Alt get get get++instance Binary a => Binary (Field a) where+  put (Field spi qid a) = put spi >> put qid >> put a+  get = liftM3 Field get get get++instance Binary a => Binary (Var a) where+  put (Var a idt) = put a >> put idt+  get = liftM2 Var get get++{- HLINT ignore "Use record patterns"-}
− src/Curry/Syntax/Type.lhs 
@@ -1,315 +0,0 @@-> {-# LANGUAGE DeriveDataTypeable #-}--% $Id: CurrySyntax.lhs,v 1.43 2004/02/15 22:10:31 wlux Exp $-%-% Copyright (c) 1999-2004, Wolfgang Lux-% See LICENSE for the full license.-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-%-\nwfilename{CurrySyntax.lhs}-\section{The Parse Tree}-This module provides the necessary data structures to maintain the-parsed representation of a Curry program.--\em{Note:} this modified version uses haskell type \texttt{Integer}-instead of \texttt{Int} for representing integer values. This allows-an unlimited range of integer constants in Curry programs.-\begin{verbatim}--> module Curry.Syntax.Type where--> import Curry.Base.Ident-> import Curry.Base.Position-> import Data.Generics-> import Control.Monad.State--\end{verbatim}-\paragraph{Modules}-\begin{verbatim}--> data Module = Module ModuleIdent (Maybe ExportSpec) [Decl] ->  deriving (Eq,Show,Read,Typeable,Data)--> data ExportSpec = Exporting Position [Export] deriving (Eq,Show,Read,Typeable,Data)-> data Export =->     Export         QualIdent                  -- f/T->   | ExportTypeWith QualIdent [Ident]          -- T(C1,...,Cn)->   | ExportTypeAll  QualIdent                  -- T(..)->   | ExportModule   ModuleIdent->   deriving (Eq,Show,Read,Typeable,Data)--\end{verbatim}-\paragraph{Module declarations}-\begin{verbatim}--> data ImportSpec =->     Importing Position [Import]->   | Hiding Position [Import]->   deriving (Eq,Show,Read,Typeable,Data)-> data Import =->     Import         Ident            -- f/T->   | ImportTypeWith Ident [Ident]    -- T(C1,...,Cn)->   | ImportTypeAll  Ident            -- T(..)->   deriving (Eq,Show,Read,Typeable,Data)--> data Decl =->     ImportDecl Position ModuleIdent Qualified (Maybe ModuleIdent)->                (Maybe ImportSpec)->   | InfixDecl Position Infix Integer [Ident]->   | DataDecl Position Ident [Ident] [ConstrDecl]->   | NewtypeDecl Position Ident [Ident] NewConstrDecl->   | TypeDecl Position Ident [Ident] TypeExpr->   | TypeSig Position [Ident] TypeExpr->   | EvalAnnot Position [Ident] EvalAnnotation->   | FunctionDecl Position Ident [Equation]->   | ExternalDecl Position CallConv (Maybe String) Ident TypeExpr->   | FlatExternalDecl Position [Ident]->   | PatternDecl Position ConstrTerm Rhs->   | ExtraVariables Position [Ident]->   deriving (Eq,Show,Read,Typeable,Data)--> data ConstrDecl =->     ConstrDecl Position [Ident] Ident [TypeExpr]->   | ConOpDecl Position [Ident] TypeExpr Ident TypeExpr->   deriving (Eq,Show,Read,Typeable,Data)-> data NewConstrDecl =->   NewConstrDecl Position [Ident] Ident TypeExpr->   deriving (Eq,Show,Read,Typeable,Data)--> type Qualified = Bool-> data Infix = InfixL | InfixR | Infix deriving (Eq,Show,Read,Typeable,Data)-> data EvalAnnotation = EvalRigid | EvalChoice deriving (Eq,Show,Read,Typeable,Data)-> data CallConv = CallConvPrimitive | CallConvCCall deriving (Eq,Show,Read,Typeable,Data)--\end{verbatim}-\paragraph{Module interfaces}-Interface declarations are restricted to type declarations and signatures. -Note that an interface function declaration additionaly contains the -function arity (= number of parameters) in order to generate-correct FlatCurry function applications.-\begin{verbatim}--> data Interface = Interface ModuleIdent [IDecl] deriving (Eq,Show,Read,Typeable,Data)--> data IDecl =->     IImportDecl Position ModuleIdent->   | IInfixDecl Position Infix Integer QualIdent->   | HidingDataDecl Position Ident [Ident] ->   | IDataDecl Position QualIdent [Ident] [Maybe ConstrDecl]->   | INewtypeDecl Position QualIdent [Ident] NewConstrDecl->   | ITypeDecl Position QualIdent [Ident] TypeExpr->   | IFunctionDecl Position QualIdent Int TypeExpr->   deriving (Eq,Show,Read,Typeable,Data)--\end{verbatim}-\paragraph{Types}-\begin{verbatim}--> data TypeExpr =->     ConstructorType QualIdent [TypeExpr]->   | VariableType Ident->   | TupleType [TypeExpr]->   | ListType TypeExpr->   | ArrowType TypeExpr TypeExpr->   | RecordType [([Ident],TypeExpr)] (Maybe TypeExpr) ->     -- {l1 :: t1,...,ln :: tn | r}->   deriving (Eq,Show,Read,Typeable,Data)--\end{verbatim}-\paragraph{Functions}-\begin{verbatim}--> data Equation = Equation Position Lhs Rhs deriving (Eq,Show,Read,Typeable,Data)-> data Lhs =->     FunLhs Ident [ConstrTerm]->   | OpLhs ConstrTerm Ident ConstrTerm->   | ApLhs Lhs [ConstrTerm]->   deriving (Eq,Show,Read,Typeable,Data)-> data Rhs =->     SimpleRhs Position Expression [Decl]->   | GuardedRhs [CondExpr] [Decl]->   deriving (Eq,Show,Read,Typeable,Data)-> data CondExpr = CondExpr Position Expression Expression deriving (Eq,Show,Read,Typeable,Data)--> flatLhs :: Lhs -> (Ident,[ConstrTerm])-> flatLhs lhs = flat lhs []->   where flat (FunLhs f ts) ts' = (f,ts ++ ts')->         flat (OpLhs t1 op t2) ts = (op,t1:t2:ts)->         flat (ApLhs lhs ts) ts' = flat lhs (ts ++ ts')--\end{verbatim}-\paragraph{Literals} The \texttt{Ident} argument of an \texttt{Int}-literal is used for supporting ad-hoc polymorphism on integer-numbers. An integer literal can be used either as an integer number or-as a floating-point number depending on its context. The compiler uses-the identifier of the \texttt{Int} literal for maintaining its type.-\begin{verbatim}--> data Literal =->     Char SrcRef Char                         -- should be Int to handle Unicode->   | Int Ident Integer->   | Float SrcRef Double->   | String SrcRef String                     -- should be [Int] to handle Unicode->   deriving (Eq,Show,Read,Typeable,Data)--> mk' :: ([SrcRef] -> a) -> a-> mk' = ($[])--> mk :: (SrcRef -> a) -> a-> mk = ($noRef)--> mkInt :: Integer -> Literal-> mkInt i = mk (\r -> Int (addPositionIdent (AST  r) anonId) i) --\end{verbatim}-\paragraph{Patterns}-\begin{verbatim}--> data ConstrTerm =->     LiteralPattern Literal->   | NegativePattern Ident Literal->   | VariablePattern Ident->   | ConstructorPattern QualIdent [ConstrTerm]->   | InfixPattern ConstrTerm QualIdent ConstrTerm->   | ParenPattern ConstrTerm->   | TuplePattern SrcRef [ConstrTerm]->   | ListPattern [SrcRef] [ConstrTerm]->   | AsPattern Ident ConstrTerm->   | LazyPattern SrcRef ConstrTerm->   | FunctionPattern QualIdent [ConstrTerm]->   | InfixFuncPattern ConstrTerm QualIdent ConstrTerm->   | RecordPattern [Field ConstrTerm] (Maybe ConstrTerm)  ->         -- {l1 = p1, ..., ln = pn}  oder {l1 = p1, ..., ln = pn | p}->   deriving (Eq,Show,Read,Typeable,Data)--\end{verbatim}-\paragraph{Expressions}-\begin{verbatim}--> data Expression =->     Literal Literal->   | Variable QualIdent->   | Constructor QualIdent->   | Paren Expression->   | Typed Expression TypeExpr->   | Tuple SrcRef [Expression]->   | List [SrcRef] [Expression]->   | ListCompr SrcRef Expression [Statement] -- the ref corresponds to the main list  ->   | EnumFrom Expression->   | EnumFromThen Expression Expression->   | EnumFromTo Expression Expression->   | EnumFromThenTo Expression Expression Expression->   | UnaryMinus Ident Expression->   | Apply Expression Expression->   | InfixApply Expression InfixOp Expression->   | LeftSection Expression InfixOp->   | RightSection InfixOp Expression->   | Lambda SrcRef [ConstrTerm] Expression->   | Let [Decl] Expression->   | Do [Statement] Expression->   | IfThenElse SrcRef Expression Expression Expression->   | Case SrcRef Expression [Alt]->   | RecordConstr [Field Expression]            -- {l1 = e1,...,ln = en}->   | RecordSelection Expression Ident           -- e -> l->   | RecordUpdate [Field Expression] Expression -- {l1 := e1,...,ln := en | e}->   deriving (Eq,Show,Read,Typeable,Data)--> data InfixOp = InfixOp QualIdent | InfixConstr QualIdent deriving (Eq,Show,Read,Typeable,Data)--> data Statement =->     StmtExpr SrcRef Expression->   | StmtDecl [Decl]->   | StmtBind SrcRef ConstrTerm Expression->   deriving (Eq,Show,Read,Typeable,Data)--> data Alt = Alt Position ConstrTerm Rhs deriving (Eq,Show,Read,Typeable,Data)--> data Field a = Field Position Ident a deriving (Eq, Show,Read,Typeable,Data)--> fieldLabel :: Field a -> Ident-> fieldLabel (Field _ l _) = l--> fieldTerm :: Field a -> a-> fieldTerm (Field _ _ t) = t--> field2Tuple :: Field a -> (Ident,a)-> field2Tuple (Field _ l t) = (l,t)--> opName :: InfixOp -> QualIdent-> opName (InfixOp op) = op-> opName (InfixConstr c) = c--\end{verbatim}--> instance SrcRefOf ConstrTerm where->   srcRefOf (LiteralPattern l) = srcRefOf l->   srcRefOf (NegativePattern i _) = srcRefOf i->   srcRefOf (VariablePattern i) = srcRefOf i->   srcRefOf (ConstructorPattern i _) = srcRefOf i->   srcRefOf (InfixPattern _ i _) = srcRefOf i->   srcRefOf (ParenPattern c) = srcRefOf c->   srcRefOf (TuplePattern s _) = s->   srcRefOf (ListPattern s _) = error "list pattern has several source refs"->   srcRefOf (AsPattern i _) = srcRefOf i->   srcRefOf (LazyPattern s _) = s->   srcRefOf (FunctionPattern i _) = srcRefOf i->   srcRefOf (InfixFuncPattern _ i _) = srcRefOf i--> instance SrcRefOf Literal where->   srcRefOf (Char s _)   = s->   srcRefOf (Int i _)    = srcRefOf i->   srcRefOf (Float s _)  = s->   srcRefOf (String s _) = s-------------------------------- add source references------------------------------> type M a = a -> State Int a-> -> addSrcRefs :: Module -> Module-> addSrcRefs x = evalState (addRef x) 0->   where ->     addRef :: Data a' => M a' ->     addRef = down `extM` addRefPos   ->                   `extM` addRefSrc   ->                   `extM` addRefIdent->                   `extM` addRefListPat->                   `extM` addRefListExp->       where->         down :: Data a' => M a'->         down = gmapM addRef-> ->         addRefPos :: M [SrcRef]->         addRefPos _ = liftM (:[]) next-> ->         addRefSrc :: M SrcRef->         addRefSrc _ = next-> ->         addRefIdent :: M Ident->         addRefIdent ident = liftM (flip addRefId ident) next->->         addRefListPat :: M ConstrTerm->         addRefListPat (ListPattern _ ts) = do->           liftM (uncurry ListPattern) (addRefList ts)->         addRefListPat ct = gmapM addRef ct->   ->         addRefListExp :: M Expression->         addRefListExp (List _ ts) = do->           liftM (uncurry List) (addRefList ts)->         addRefListExp ct = gmapM addRef ct->   ->         addRefList :: Data a' => [a'] -> State Int ([SrcRef],[a'])->         addRefList ts = do->           i <- next->           let add t = do t' <- addRef t;j <- next; return (j,t')->           ists <- sequence (map add ts)->           let (is,ts') = unzip ists->           return (i:is,ts')->         ->         next :: State Int SrcRef->         next = do->           i <- get->           put $! i+1->           return (SrcRef [i])
− src/Curry/Syntax/Unlit.hs 
@@ -1,61 +0,0 @@-{--  Since version 0.7 of the language report, Curry accepts literate-  source programs. In a literate source all program lines must begin-  with a greater sign in the first column. All other lines are assumed-  to be documentation. In order to avoid some common errors with-  literate programs, Curry requires at least one program line to be-  present in the file. In addition, every block of program code must be-  preceded by a blank line and followed by a blank line.--  This module has been rewritten by Holger Siegel in 2009.--  (c) Holger Siegel, 2009.--}---module Curry.Syntax.Unlit(unlit) where--import Control.Monad(when, zipWithM)-import Data.Char--import Curry.Base.Position-import Curry.Base.MessageMonad---data Line = Program !Int String-          | Blank | Comment--classify :: Int -> String -> Line-classify l ('>':cs)  = Program l cs-classify _ cs-  | all isSpace cs = Blank-  | otherwise      = Comment--{--  Process a literate program into error messages (if any) and the-  corresponding non-literate program.--}--unlit :: FilePath -> String -> MsgMonad String-unlit fn lcy = do ls <- progLines fn (zipWith classify [1..] $ lines lcy)-                  when (all null ls) $-                       failWith (fn ++ ": no code in literate script")-                  return (unlines ls)--{--  Check that each program line is not adjacent to a comment line and-  there is at least one program line.--}-progLines :: FilePath -> [Line] -> MsgMonad [String]-progLines fn cs -   = zipWithM adjacent (Blank : cs) cs-  where-    adjacent :: Line -> Line -> MsgMonad String-    adjacent (Program p _) Comment     = message fn p "followed"-    adjacent Comment     (Program p _) = message fn p "preceded"-    adjacent _ (Program _ s)           = return s-    adjacent _ _                       = return ""--message :: String -> Int -> String -> MsgMonad a-message file p w = failWithAt (Position file p 1 noRef) msg-    where msg = "When reading literate source: Program line is " ++ w ++ " by comment line."
src/Curry/Syntax/Utils.hs view
@@ -1,257 +1,325 @@-module Curry.Syntax.Utils(Expr, fv, qfv,-                          QuantExpr, bv,+{- |+    Module      :  $Header$+    Description :  Utility functions for Curry's abstract syntax+    Copyright   :  (c) 1999 - 2004 Wolfgang Lux+                       2005        Martin Engelke+                       2011 - 2014 Björn Peemöller+                       2015        Jan Tikovsky+                       2016        Finn Teegen+    License     :  BSD-3-clause -                          isEvalAnnot, isTypeSig,-                          infixOp,-                          isTypeDecl, isValueDecl,-                          isInfixDecl,-                          isRecordDecl, isImportDecl) where+    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable -import qualified Data.Set as Set+    This module provides some utility functions for working with the+    abstract syntax tree of Curry.+-} +module Curry.Syntax.Utils+  ( hasLanguageExtension, knownExtensions+  , isTopDecl, isBlockDecl+  , isTypeSig, infixOp, isTypeDecl, isValueDecl, isInfixDecl+  , isDefaultDecl, isClassDecl, isTypeOrClassDecl, isInstanceDecl+  , isFunctionDecl, isExternalDecl, patchModuleId+  , isVariablePattern+  , isVariableType, isSimpleType+  , typeConstr, typeVariables, varIdent+  , flatLhs, eqnArity, fieldLabel, fieldTerm, field2Tuple, opName+  , funDecl, mkEquation, simpleRhs, patDecl, varDecl, constrPattern, caseAlt+  , mkLet, mkVar, mkCase, mkLambda+  , apply, unapply+  , constrId, nconstrId+  , nconstrType+  , recordLabels, nrecordLabels+  , methods, impls, imethod, imethodArity+  , shortenModuleAST+  ) where -import Curry.Base.Ident +import Control.Monad.State++import Curry.Base.Ident+import Curry.Base.SpanInfo+import Curry.Files.Filenames (takeBaseName)+import Curry.Syntax.Extension import Curry.Syntax.Type -{--  Free and bound variables-  -  The compiler needs to compute the sets of free and bound variables for-  various different entities. We will devote three type classes to that-  purpose. The \texttt{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 \emph{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 \emph{M.x} always denotes an entity defined at the-  top-level.-  -  The \texttt{Decl} instance of \texttt{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.--}+-- |Check whether a 'Module' has a specific 'KnownExtension' enabled by a pragma+hasLanguageExtension :: Module a -> KnownExtension -> Bool+hasLanguageExtension mdl ext = ext `elem` knownExtensions mdl -class Expr e where-  fv :: e -> [Ident]-class QualExpr e where-  qfv :: ModuleIdent -> e -> [Ident]-class QuantExpr e where-  bv :: e -> [Ident]+-- |Extract all known extensions from a 'Module'+knownExtensions :: Module a -> [KnownExtension]+knownExtensions (Module _ _ ps _ _ _ _) =+  [ e | LanguagePragma _ exts <- ps, KnownExtension _ e <- exts] -instance Expr e => Expr [e] where-  fv = concat . map fv-instance QualExpr e => QualExpr [e] where-  qfv m = concat . map (qfv m)-instance QuantExpr e => QuantExpr [e] where-  bv = concat . map bv+-- |Replace the generic module name @main@ with the module name derived+-- from the 'FilePath' of the module.+patchModuleId :: FilePath -> Module a -> Module a+patchModuleId fn m@(Module spi li ps mid es is ds)+  | mid == mainMIdent = Module spi li ps (mkMIdent [takeBaseName fn]) es is ds+  | otherwise         = m -instance QualExpr Decl where-  qfv m (FunctionDecl _ _ eqs) = qfv m eqs-  qfv m (PatternDecl _ _ rhs) = qfv m rhs-  qfv _ _ = []+-- |Is the declaration a top declaration?+isTopDecl :: Decl a -> Bool+isTopDecl = not . isBlockDecl -instance QuantExpr Decl where-  bv (TypeSig _ vs _) = vs-  bv (EvalAnnot _ fs _) = fs-  bv (FunctionDecl _ f _) = [f]-  bv (ExternalDecl _ _ _ f _) = [f]-  bv (FlatExternalDecl _ fs) = fs-  bv (PatternDecl _ t _) = bv t-  bv (ExtraVariables _ vs) = vs-  bv _ = []+-- |Is the declaration a block declaration?+isBlockDecl :: Decl a -> Bool+isBlockDecl = liftM3 ((.) (||) . (||)) isInfixDecl isTypeSig isValueDecl -instance QualExpr Equation where-  qfv m (Equation _ lhs rhs) = filterBv lhs (qfv m lhs ++ qfv m rhs)+-- |Is the declaration an infix declaration?+isInfixDecl :: Decl a -> Bool+isInfixDecl (InfixDecl _ _ _ _) = True+isInfixDecl _                   = False -instance QuantExpr Lhs where-  bv = bv . snd . flatLhs+-- |Is the declaration a type declaration?+isTypeDecl :: Decl a -> Bool+isTypeDecl (DataDecl     _ _ _ _ _) = True+isTypeDecl (ExternalDataDecl _ _ _) = True+isTypeDecl (NewtypeDecl  _ _ _ _ _) = True+isTypeDecl (TypeDecl       _ _ _ _) = True+isTypeDecl _                        = False -instance QualExpr Lhs where-  qfv m lhs = qfv m (snd (flatLhs lhs))+-- |Is the declaration a default declaration?+isDefaultDecl :: Decl a -> Bool+isDefaultDecl (DefaultDecl _ _) = True+isDefaultDecl _                 = False -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)+-- |Is the declaration a class declaration?+isClassDecl :: Decl a -> Bool+isClassDecl (ClassDecl _ _ _ _ _ _) = True+isClassDecl _                       = False -instance QualExpr CondExpr where-  qfv m (CondExpr _ g e) = qfv m g ++ qfv m e+-- |Is the declaration a type or a class declaration?+isTypeOrClassDecl :: Decl a -> Bool+isTypeOrClassDecl = liftM2 (||) isTypeDecl isClassDecl -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 (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-  qfv m (RecordConstr fs) = qfv m fs-  qfv m (RecordSelection e _) = qfv m e-  qfv m (RecordUpdate fs e) = qfv m e ++ qfv m fs+-- |Is the declaration an instance declaration?+isInstanceDecl :: Decl a -> Bool+isInstanceDecl (InstanceDecl _ _ _ _ _ _) = True+isInstanceDecl _                          = False -qfvStmt :: ModuleIdent -> Statement -> [Ident] -> [Ident]-qfvStmt m st fvs = qfv m st ++ filterBv st fvs+-- |Is the declaration a type signature?+isTypeSig :: Decl a -> Bool+isTypeSig (TypeSig           _ _ _) = True+isTypeSig _                         = False -instance QualExpr Statement where-  qfv m (StmtExpr _ e) = qfv m e-  qfv m (StmtDecl ds) = filterBv ds (qfv m ds)-  qfv m (StmtBind _ t e) = qfv m e+-- |Is the declaration a value declaration?+isValueDecl :: Decl a -> Bool+isValueDecl (FunctionDecl    _ _ _ _) = True+isValueDecl (ExternalDecl        _ _) = True+isValueDecl (PatternDecl       _ _ _) = True+isValueDecl (FreeDecl            _ _) = True+isValueDecl _                         = False -instance QualExpr Alt where-  qfv m (Alt _ t rhs) = filterBv t (qfv m rhs)+-- |Is the declaration a function declaration?+isFunctionDecl :: Decl a -> Bool+isFunctionDecl (FunctionDecl _ _ _ _) = True+isFunctionDecl _                      = False -instance QuantExpr a => QuantExpr (Field a) where-  bv (Field _ _ t) = bv t+-- |Is the declaration an external declaration?+isExternalDecl :: Decl a -> Bool+isExternalDecl (ExternalDecl _ _) = True+isExternalDecl _                  = False -instance QualExpr a => QualExpr (Field a) where-  qfv m (Field _ _ t) = qfv m t+-- |Is the pattern semantically equivalent to a variable pattern?+isVariablePattern :: Pattern a -> Bool+isVariablePattern (VariablePattern _ _ _) = True+isVariablePattern (ParenPattern    _   t) = isVariablePattern t+isVariablePattern (AsPattern       _ _ t) = isVariablePattern t+isVariablePattern (LazyPattern     _   _) = True+isVariablePattern _                       = False -instance QuantExpr Statement where-  bv (StmtExpr _ e) = []-  bv (StmtBind _ t e) = bv t-  bv (StmtDecl ds) = bv ds+-- |Is a type expression a type variable?+isVariableType :: TypeExpr -> Bool+isVariableType (VariableType _ _) = True+isVariableType _                  = False -instance QualExpr InfixOp where-  qfv m (InfixOp op) = qfv m (Variable op)-  qfv _ (InfixConstr _) = []+-- |Is a type expression simple, i.e., is it of the form T u_1 ... u_n,+-- where T is a type constructor and u_1 ... u_n are type variables?+isSimpleType :: TypeExpr -> Bool+isSimpleType (ConstructorType _ _) = True+isSimpleType (ApplyType _ ty1 ty2) = isSimpleType ty1 && isVariableType ty2+isSimpleType (VariableType   _  _) = False+isSimpleType (TupleType    _  tys) = all isVariableType tys+isSimpleType (ListType      _  ty) = isVariableType ty+isSimpleType (ArrowType _ ty1 ty2) = isVariableType ty1 && isVariableType ty2+isSimpleType (ParenType     _  ty) = isSimpleType ty+isSimpleType (ForallType    _ _ _) = False -instance QuantExpr ConstrTerm where-  bv (LiteralPattern _) = []-  bv (NegativePattern _ _) = []-  bv (VariablePattern v) = [v]-  bv (ConstructorPattern c ts) = bv ts-  bv (InfixPattern t1 op t2) = bv t1 ++ bv t2-  bv (ParenPattern t) = bv t-  bv (TuplePattern _ ts) = bv ts-  bv (ListPattern _ ts) = bv ts-  bv (AsPattern v t) = v : bv t-  bv (LazyPattern _ t) = bv t-  bv (FunctionPattern f ts) = bvFuncPatt (FunctionPattern f ts)-  bv (InfixFuncPattern t1 op t2) = bvFuncPatt (InfixFuncPattern t1 op t2)-  bv (RecordPattern fs r) = (maybe [] bv r) ++ bv fs+-- |Return the qualified type constructor of a type expression.+typeConstr :: TypeExpr -> QualIdent+typeConstr (ConstructorType   _ tc) = tc+typeConstr (ApplyType       _ ty _) = typeConstr ty+typeConstr (TupleType        _ tys) = qTupleId (length tys)+typeConstr (ListType           _ _) = qListId+typeConstr (ArrowType        _ _ _) = qArrowId+typeConstr (ParenType         _ ty) = typeConstr ty+typeConstr (VariableType       _ _) =+  error "Curry.Syntax.Utils.typeConstr: variable type"+typeConstr (ForallType       _ _ _) =+  error "Curry.Syntax.Utils.typeConstr: forall type" -instance QualExpr ConstrTerm 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 (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]-  qfv m (RecordPattern fs r) = (maybe [] (qfv m) r) ++ qfv m fs+-- |Return the list of variables occuring in a type expression.+typeVariables :: TypeExpr -> [Ident]+typeVariables (ConstructorType       _ _) = []+typeVariables (ApplyType       _ ty1 ty2) = typeVariables ty1 ++ typeVariables ty2+typeVariables (VariableType         _ tv) = [tv]+typeVariables (TupleType           _ tys) = concatMap typeVariables tys+typeVariables (ListType             _ ty) = typeVariables ty+typeVariables (ArrowType       _ ty1 ty2) = typeVariables ty1 ++ typeVariables ty2+typeVariables (ParenType            _ ty) = typeVariables ty+typeVariables (ForallType        _ vs ty) = vs ++ typeVariables ty -instance Expr TypeExpr where-  fv (ConstructorType _ tys) = fv tys-  fv (VariableType tv)-    | tv == anonId = []-    | otherwise = [tv]-  fv (TupleType tys) = fv tys-  fv (ListType ty) = fv ty-  fv (ArrowType ty1 ty2) = fv ty1 ++ fv ty2-  fv (RecordType fs rty) = (maybe [] fv rty) ++ fv (map snd fs)+-- |Return the identifier of a variable.+varIdent :: Var a -> Ident+varIdent (Var _ v) = v -filterBv :: QuantExpr e => e -> [Ident] -> [Ident]-filterBv e = filter (`Set.notMember` Set.fromList (bv e))+-- |Convert an infix operator into an expression+infixOp :: InfixOp a -> Expression a+infixOp (InfixOp     a op) = Variable NoSpanInfo a op+infixOp (InfixConstr a op) = Constructor NoSpanInfo a op -{--  Since multiple variable occurrences are allowed in function patterns,-  it is necessary to compute the list of bound variables in a different way:-  Each variable occuring in the function pattern will be unique in the result-  list.- -}+-- |flatten the left-hand-side to the identifier and all constructor terms+flatLhs :: Lhs a -> (Ident, [Pattern a])+flatLhs lhs = flat lhs []+  where flat (FunLhs    _ f ts) ts' = (f, ts ++ ts')+        flat (OpLhs _ t1 op t2) ts' = (op, t1 : t2 : ts')+        flat (ApLhs  _ lhs' ts) ts' = flat lhs' (ts ++ ts') -bvFuncPatt :: ConstrTerm -> [Ident]-bvFuncPatt = bvfp []- where- bvfp bvs (LiteralPattern _) = bvs- bvfp bvs (NegativePattern _ _) = bvs- bvfp bvs (VariablePattern v)-    | elem v bvs = bvs-    | otherwise  = v:bvs- bvfp bvs (ConstructorPattern c ts) = foldl bvfp bvs ts- bvfp bvs (InfixPattern t1 op t2) = foldl bvfp bvs [t1,t2]- bvfp bvs (ParenPattern t) = bvfp bvs t- bvfp bvs (TuplePattern _ ts) = foldl bvfp bvs ts- bvfp bvs (ListPattern _ ts) = foldl bvfp bvs ts- bvfp bvs (AsPattern v t)-    | elem v bvs = bvfp bvs t-    | otherwise  = bvfp (v:bvs) t- bvfp bvs (LazyPattern _ t) = bvfp bvs t- bvfp bvs (FunctionPattern f ts) = foldl bvfp bvs ts- bvfp bvs (InfixFuncPattern t1 op t2) = foldl bvfp bvs [t1, t2]- bvfp bvs (RecordPattern fs r)-    = foldl bvfp (maybe bvs (bvfp bvs) r) (map fieldTerm fs)+-- |Return the arity of an equation.+eqnArity :: Equation a -> Int+eqnArity (Equation _ lhs _) = length $ snd $ flatLhs lhs +-- |Select the label of a field+fieldLabel :: Field a -> QualIdent+fieldLabel (Field _ l _) = l +-- |Select the term of a field+fieldTerm :: Field a -> a+fieldTerm (Field _ _ t) = t -{--  Here is a list of predicates identifying various kinds of-  declarations.--}+-- |Select the label and term of a field+field2Tuple :: Field a -> (QualIdent, a)+field2Tuple (Field _ l t) = (l, t) -isImportDecl, isInfixDecl, isTypeDecl :: Decl -> Bool-isTypeSig, isEvalAnnot, isValueDecl :: Decl -> Bool+-- |Get the operator name of an infix operator+opName :: InfixOp a -> QualIdent+opName (InfixOp     _ op) = op+opName (InfixConstr _ c ) = c -isImportDecl (ImportDecl _ _ _ _ _) = True-isImportDecl _ = False+-- | Get the identifier of a constructor declaration+constrId :: ConstrDecl -> Ident+constrId (ConstrDecl  _ c  _) = c+constrId (ConOpDecl _ _ op _) = op+constrId (RecordDecl  _ c  _) = c -isInfixDecl (InfixDecl _ _ _ _) = True-isInfixDecl _ = False+-- | Get the identifier of a newtype constructor declaration+nconstrId :: NewConstrDecl -> Ident+nconstrId (NewConstrDecl _ c _) = c+nconstrId (NewRecordDecl _ c _) = c -isTypeDecl (DataDecl _ _ _ _) = True-isTypeDecl (NewtypeDecl _ _ _ _) = True-isTypeDecl (TypeDecl _ _ _ _) = True-isTypeDecl _ = False+-- | Get the type of a newtype constructor declaration+nconstrType :: NewConstrDecl -> TypeExpr+nconstrType (NewConstrDecl      _ _ ty) = ty+nconstrType (NewRecordDecl _ _ (_, ty)) = ty -isTypeSig (TypeSig _ _ _) = True-isTypeSig (ExternalDecl _ _ _ _ _) = True-isTypeSig _ = False+-- | Get record label identifiers of a constructor declaration+recordLabels :: ConstrDecl -> [Ident]+recordLabels (ConstrDecl   _ _ _) = []+recordLabels (ConOpDecl _ _ _  _) = []+recordLabels (RecordDecl  _ _ fs) = [l | FieldDecl _ ls _ <- fs, l <- ls] -isEvalAnnot (EvalAnnot _ _ _) = True-isEvalAnnot _ = False+-- | Get record label identifier of a newtype constructor declaration+nrecordLabels :: NewConstrDecl -> [Ident]+nrecordLabels (NewConstrDecl _ _ _     ) = []+nrecordLabels (NewRecordDecl _ _ (l, _)) = [l] -isValueDecl (FunctionDecl _ _ _) = True-isValueDecl (ExternalDecl _ _ _ _ _) = True-isValueDecl (FlatExternalDecl _ _) = True-isValueDecl (PatternDecl _ _ _) = True-isValueDecl (ExtraVariables _ _) = True-isValueDecl _ = False+-- | Get the declared method identifiers of a type class method declaration+methods :: Decl a -> [Ident]+methods (TypeSig _ fs _) = fs+methods _                = [] -isRecordDecl (TypeDecl _ _ _ (RecordType _ _)) = True-isRecordDecl _ = False+-- | Get the method identifiers of a type class method implementations+impls :: Decl a -> [Ident]+impls (FunctionDecl _ _ f _) = [f]+impls _                      = [] +-- | Get the declared method identifier of an interface method declaration+imethod :: IMethodDecl -> Ident+imethod (IMethodDecl _ f _ _) = f -{--  The function \texttt{infixOp} converts an infix operator into an-  expression.--}+-- | Get the arity of an interface method declaration+imethodArity :: IMethodDecl -> Maybe Int+imethodArity (IMethodDecl _ _ a _) = a -infixOp :: InfixOp -> Expression-infixOp (InfixOp op) = Variable op-infixOp (InfixConstr op) = Constructor op+--------------------------------------------------------+-- constructing elements of the abstract syntax tree+--------------------------------------------------------++funDecl :: SpanInfo -> a -> Ident -> [Pattern a] -> Expression a -> Decl a+funDecl spi a f ts e = FunctionDecl spi a f [mkEquation spi f ts e]++mkEquation :: SpanInfo -> Ident -> [Pattern a] -> Expression a -> Equation a+mkEquation spi f ts e = Equation spi (FunLhs NoSpanInfo f ts) (simpleRhs NoSpanInfo e)++simpleRhs :: SpanInfo -> Expression a -> Rhs a+simpleRhs spi e = SimpleRhs spi WhitespaceLayout e []++patDecl :: SpanInfo -> Pattern a -> Expression a -> Decl a+patDecl spi t e = PatternDecl spi t (SimpleRhs spi WhitespaceLayout e [])++varDecl :: SpanInfo -> a -> Ident -> Expression a -> Decl a+varDecl p ty = patDecl p . VariablePattern NoSpanInfo ty++constrPattern :: a -> QualIdent -> [(a, Ident)] -> Pattern a+constrPattern ty c = ConstructorPattern NoSpanInfo ty c+                   . map (uncurry (VariablePattern NoSpanInfo))++caseAlt :: SpanInfo -> Pattern a -> Expression a -> Alt a+caseAlt spi t e = Alt spi t (SimpleRhs spi WhitespaceLayout e [])++mkLet :: [Decl a] -> Expression a -> Expression a+mkLet ds e = if null ds then e else Let NoSpanInfo WhitespaceLayout ds e++mkVar :: a -> Ident -> Expression a+mkVar ty = Variable NoSpanInfo ty . qualify++mkCase :: CaseType -> Expression a -> [Alt a] -> Expression a+mkCase = Case NoSpanInfo WhitespaceLayout++mkLambda :: [Pattern a] -> Expression a -> Expression a+mkLambda = Lambda NoSpanInfo++apply :: Expression a -> [Expression a] -> Expression a+apply = foldl (Apply NoSpanInfo)++unapply :: Expression a -> [Expression a] -> (Expression a, [Expression a])+unapply (Apply _ e1 e2) es = unapply e1 (e2 : es)+unapply e               es = (e, es)+++--------------------------------------------------------+-- Shorten Module+-- Module Pragmas and Equations will be removed+--------------------------------------------------------++shortenModuleAST :: Module () -> Module ()+shortenModuleAST = shortenAST++class ShortenAST a where+  shortenAST :: a -> a++instance ShortenAST (Module a) where+  shortenAST (Module spi li _ mid ex im ds) =+    Module spi li [] mid ex im (map shortenAST ds)++instance ShortenAST (Decl a) where+  shortenAST (FunctionDecl spi a idt _) =+    FunctionDecl spi a idt []+  shortenAST (ClassDecl spi li cx cls tyv ds) =+    ClassDecl spi li cx cls tyv (map shortenAST ds)+  shortenAST (InstanceDecl spi li cx cls tyv ds) =+    InstanceDecl spi li cx cls tyv (map shortenAST ds)+  shortenAST d = d
src/CurryBuilder.hs view
@@ -1,202 +1,240 @@---------------------------------------------------------------------------------------------------------------------------------------------------------------------- CurryBuilder - Generates Curry representations for a Curry source file---                including all imported modules.------ September 2005,--- Martin Engelke (men@informatik.uni-kiel.de)--- March 2007, extensions by Sebastian Fischer (sebf@informatik.uni-kiel.de)----module CurryBuilder (buildCurry, smake) where+{- |+    Module      :  $Header$+    Description :  Build tool for compiling multiple Curry modules+    Copyright   :  (c) 2005        Martin Engelke+                       2007        Sebastian Fischer+                       2011 - 2015 Björn Peemöller+                       2018        Kai-Oliver Prott+    License     :  BSD-3-clause -import System.Exit-import System.Time-import Control.Monad-import qualified Data.Map as Map-import Data.Maybe-import Data.List -import System.IO+    Maintainer  :  fte@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable -import Curry.Base.Ident+    This module contains functions to generate Curry representations for a+    Curry source file including all imported modules.+-}+module CurryBuilder (buildCurry, findCurry) where -import Modules (compileModule)-import CurryCompilerOpts -import CurryDeps+import Control.Monad   (foldM, liftM)+import Data.Char       (isSpace)+import Data.Maybe      (catMaybes, fromMaybe, mapMaybe)+import System.FilePath ((</>), normalise)++import Curry.Base.Ident+import Curry.Base.Monad+import Curry.Base.SpanInfo (SpanInfo)+import Curry.Base.Pretty import Curry.Files.Filenames import Curry.Files.PathUtils+import Curry.Syntax ( ModulePragma (..), Extension (KnownExtension)+                    , KnownExtension (CPP), Tool (CYMAKE, FRONTEND) ) +import Base.Messages -flatName' :: Options -> FilePath -> FilePath-flatName' o-    | extendedFlat o = extFlatName-    | otherwise      = flatName+import CompilerOpts ( Options (..), CppOpts (..), DebugOpts (..)+                    , TargetType (..), defaultDebugOpts, updateOpts )+import CurryDeps    (Source (..), flatDeps)+import Modules      (compileModule) --------------------------------------------------------------------------------+-- |Compile the Curry module in the given source file including all imported+-- modules w.r.t. the given 'Options'.+buildCurry :: Options -> String -> CYIO ()+buildCurry opts s = do+  fn   <- findCurry opts s+  deps <- flatDeps  opts fn+  makeCurry opts' deps+  where+  opts' | null $ optTargetTypes opts = opts { optTargetTypes = [FlatCurry] }+        | otherwise                  = opts --- Compiles the Curry program 'file' including all imported modules, depending--- on the options 'options'. The compilation was successful, if the returned--- list is empty, otherwise it contains error messages.-buildCurry :: Options -> FilePath -> IO ()-buildCurry options file-   = do let paths = importPaths options-	file'          <- getCurryPath paths file-	(cfile, errs1) <- return (maybe ("", [missingModule file])-			                (\f -> (f,[]))-				        file')-	unless (null errs1) (abortWith errs1)-	(deps, errs2) <- genDeps paths cfile-	unless (null errs2) (abortWith errs2)-	makeCurry options deps cfile+-- |Search for a compilation target identified by the given 'String'.+findCurry :: Options -> String -> CYIO FilePath+findCurry opts s = do+  mbTarget <- findFile `orIfNotFound` findModule+  case mbTarget of+    Nothing -> failMessages [complaint]+    Just fn -> ok fn+  where+  canBeFile    = isCurryFilePath s+  canBeModule  = isValidModuleName s+  moduleFile   = moduleNameToFile $ fromModuleName s+  paths        = "." : optImportPaths opts+  findFile     = if canBeFile+                    then liftIO $ lookupCurryFile paths s+                    else return Nothing+  findModule   = if canBeModule+                    then liftIO $ lookupCurryFile paths moduleFile+                    else return Nothing+  complaint+    | canBeFile && canBeModule = errMissing "target" s+    | canBeFile                = errMissing "file"   s+    | canBeModule              = errMissing "module" s+    | otherwise                = errUnrecognized  s+  first `orIfNotFound` second = do+    mbFile <- first+    case mbFile of+      Nothing -> second+      justFn  -> return justFn +-- |Compiles the given source modules, which must be in topological order.+makeCurry :: Options -> [(ModuleIdent, Source)] ->  CYIO ()+makeCurry opts srcs = mapM_ process' (zip [1 ..] srcs)+  where+  total    = length srcs+  tgtDir m = addOutDirModule (optUseOutDir opts) (optOutDir opts) m --------------------------------------------------------------------------------+  process' :: (Int, (ModuleIdent, Source)) -> CYIO ()+  process' (n, (m, Source fn ps is)) = do+    opts' <- processPragmas opts ps+    process (adjustOptions (n == total) opts') (n, total) m fn deps+    where+    deps = fn : mapMaybe curryInterface is -makeCurry :: Options -> [(ModuleIdent,Source)] -> FilePath -> IO ()-makeCurry options deps file-   = mapM compile (map snd deps) >> return ()- where- compile (Source file' mods)-    | dropExtension file == dropExtension file'-      = do -           flatIntfExists <- doesModuleExist (flatIntName file')-	   if flatIntfExists && not (force options) && null (dump options)-	    then smake (targetNames file')-                       (file':(catMaybes (map flatInterface mods)))-		       (generateFile file')-		       (skipFile file')-	    else generateFile file'-    | otherwise-      = do -           flatIntfExists <- doesModuleExist (flatIntName file')-	   if flatIntfExists-            then  smake [flatName' options file'] --[flatName file', flatIntName file']-	                (file':(catMaybes (map flatInterface mods)))-			(compileFile file')-			(skipFile file')-	    else compileFile file'- compile _ = return ()+    curryInterface i = case lookup i srcs of+      Just (Source    fn' _ _) -> Just $ tgtDir i $ interfName fn'+      Just (Interface fn'    ) -> Just $ tgtDir i $ interfName fn'+      _                        -> Nothing - compileFile file-    = do unless (noVerb options) (putStrLn ("compiling " ++ file ++ " ..."))-	 compileModule (compOpts True) file-	 return ()+  process' _ = return () - skipFile file-    = do unless (noVerb options)-		(putStrLn ("skipping " ++ file ++ " ..."))+adjustOptions :: Bool -> Options -> Options+adjustOptions final opts+  | final      = opts { optForce         = optForce opts || isDump }+  | otherwise  = opts { optForce         = False+                      , optDebugOpts     = defaultDebugOpts+                      }+  where+  isDump = not $ null $ dbDumpLevels $ optDebugOpts opts - generateFile file-    = do unless (noVerb options) -		(putStrLn ("generating "  -			   ++ (head (targetNames file))               -			   ++ " ..."))-	 compileModule (compOpts False) file-	 return () - targetNames fn         -        | flat options            = [flatName' options fn] -- , flatIntName fn]-		| flatXml options         = [xmlName fn]-		| abstract options        = [acyName fn]-		| untypedAbstract options = [uacyName fn]-		| parseOnly options       = [maybe (sourceRepName fn) id (output options)]-		| otherwise               = [flatName' options fn] -- , flatIntName fn]-- flatInterface mod -    = case (lookup mod deps) of-        Just (Source file _)  -> Just (flatIntName (dropExtension file))-	Just (Interface file) -> Just (flatIntName (dropExtension file))-	_                     -> Nothing-- compOpts isImport-    | isImport -      = options -	   { flat = True,-	     flatXml = False,-	     abstract = False,-	     untypedAbstract = False,-	     parseOnly = False,-	     dump = []-	   }-    | otherwise = options------------------------------------------------------------------------------------- Computes a dependency list for the Curry file 'file' (such a list--- usualy starts with the prelude and ends with 'file'). The result --- is a tuple containing an association list (type [(ModuleIdent,Source)]; --- see module "CurryDeps") and a list of error messages.-genDeps :: [FilePath] -> FilePath-	   -> IO ([(ModuleIdent,Source)], [String])-genDeps paths file-   = fmap flattenDeps (deps paths [] Map.empty file)+processPragmas :: Options -> [ModulePragma] -> CYIO Options+processPragmas opts0 ps = do+  let opts1 = foldl processLanguagePragma opts0+                [ e | LanguagePragma _ es <- ps, KnownExtension _ e <- es ]+  foldM processOptionPragma opts1 $+    [ (p, s) | OptionsPragma p (Just FRONTEND) s <- ps ] +++      [ (p, s) | OptionsPragma p (Just CYMAKE) s <- ps ]+  where+  processLanguagePragma opts CPP+    = opts { optCppOpts = (optCppOpts opts) { cppRun = True } }+  processLanguagePragma opts _+    = opts+  processOptionPragma opts (p, s)+    | not (null unknownFlags)+    = failMessages [errUnknownOptions p unknownFlags]+    | optMode         opts /= optMode         opts'+    = failMessages [errIllegalOption p "Cannot change mode"]+    | optLibraryPaths opts /= optLibraryPaths opts'+    = failMessages [errIllegalOption p "Cannot change library path"]+    | optImportPaths  opts /= optImportPaths  opts'+    = failMessages [errIllegalOption p "Cannot change import path"]+    | optTargetTypes  opts /= optTargetTypes  opts'+    = failMessages [errIllegalOption p "Cannot change target type"]+    | otherwise+    = return opts'+    where+    (opts', files, errs) = updateOpts opts (quotedWords s)+    unknownFlags = files ++ errs +quotedWords :: String -> [String]+quotedWords str = case dropWhile isSpace str of+  []        -> []+  s@('\'' : cs) -> case break (== '\'') cs of+    (_     , []      ) -> def s+    (quoted, (_:rest)) -> quoted : quotedWords rest+  s@('"'  : cs) -> case break (== '"') cs of+    (_     , []      ) -> def s+    (quoted, (_:rest)) -> quoted : quotedWords rest+  s         -> def s+  where+  def s = let (w, rest) = break isSpace s in  w : quotedWords rest ----------------------------------------------------------------------------------- A simple make function+-- |Compile a single source module.+process :: Options -> (Int, Int)+        -> ModuleIdent -> FilePath -> [FilePath] -> CYIO ()+process opts idx m fn deps+  | optForce opts = compile+  | otherwise     = smake (tgtDir (interfName fn) : destFiles) deps compile skip+  where+  skip    = status opts $ compMessage idx "Skipping" m (fn, head destFiles)+  compile = do+    status opts $ compMessage idx "Compiling" m (fn, head destFiles)+    compileModule opts m fn --- smake <destination files>---       <dependencies> ---       <io action, if dependencies are newer than destination files>---       <io action, if destination files are newer than dependencies>-smake :: [FilePath] -> [FilePath] -> IO a -> IO a -> IO a-smake dests deps cmd alt-   = do destTimes <- getDestTimes dests-	depTimes  <- getDepTimes deps-	make destTimes depTimes- where- make destTimes depTimes-    | (length destTimes) < (length dests) -      = catch cmd (\err -> abortWith [show err]) -    | null depTimes -      = abortWith ["unknown dependencies"]-    | outOfDate destTimes depTimes-      = catch cmd (\err -> abortWith [show err])-    | otherwise-      = alt+  tgtDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) m ----getDestTimes :: [FilePath] -> IO [ClockTime]-getDestTimes [] = return []-getDestTimes (file:files)-   = catch (do time  <- getModuleModTime file-	       times <- getDestTimes files-	       return (time:times))-           (const (getDestTimes files))+  destFiles = [ gen fn | (t, gen) <- nameGens, t `elem` optTargetTypes opts]+  nameGens  =+    [ (Tokens              , tgtDir . tokensName       )+    , (Comments            , tgtDir . commentsName)+    , (Parsed              , tgtDir . sourceRepName    )+    , (FlatCurry           , tgtDir . flatName         )+    , (TypedFlatCurry      , tgtDir . typedFlatName    )+    , (AnnotatedFlatCurry  , tgtDir . annotatedFlatName)+    , (AbstractCurry       , tgtDir . acyName          )+    , (UntypedAbstractCurry, tgtDir . uacyName         )+    , (AST                 , tgtDir . astName          )+    , (ShortAST            , tgtDir . shortASTName     )+    , (Html                , const (fromMaybe "." (optHtmlDir opts) </> htmlName m))+    ] ----getDepTimes :: [String] -> IO [ClockTime]-getDepTimes [] = return []-getDepTimes (file:files)-   = catch (do time  <- getModuleModTime file-	       times <- getDepTimes files-	       return (time:times))-           (\err -> abortWith [show err])+-- |Create a status message like+-- @[m of n] Compiling Module          ( M.curry, .curry/M.fcy )@+compMessage :: (Int, Int) -> String -> ModuleIdent+            -> (FilePath, FilePath) -> String+compMessage (curNum, maxNum) what m (src, dst)+  =  '[' : lpad (length sMaxNum) (show curNum) ++ " of " ++ sMaxNum  ++ "]"+  ++ ' ' : rpad 9 what ++ ' ' : rpad 16 (moduleName m)+  ++ " ( " ++ normalise src ++ ", " ++ normalise dst ++ " )"+  where+  sMaxNum  = show maxNum+  lpad n s = replicate (n - length s) ' ' ++ s+  rpad n s = s ++ replicate (n - length s) ' ' ----outOfDate :: [ClockTime] -> [ClockTime] -> Bool-outOfDate tgtimes dptimes = or (map (\t -> or (map ((<) t) dptimes)) tgtimes)+-- |A simple make function+smake :: [FilePath] -- ^ destination files+      -> [FilePath] -- ^ dependency files+      -> CYIO a     -- ^ action to perform if depedency files are newer+      -> CYIO a     -- ^ action to perform if destination files are newer+      -> CYIO a+smake dests deps actOutdated actUpToDate = do+  destTimes <- catMaybes `liftM` mapM (liftIO . getModuleModTime) dests+  depTimes  <- mapM (cancelMissing getModuleModTime) deps+  make destTimes depTimes+  where+  make destTimes depTimes+    | length destTimes < length dests = actOutdated+    | outOfDate destTimes depTimes    = actOutdated+    | otherwise                       = actUpToDate ----------------------------------------------------------------------------------- Error handling+  outOfDate tgtimes dptimes = or [ tg < dp | tg <- tgtimes, dp <- dptimes] --- Prints an error message on 'stderr'-putErrLn :: String -> IO ()-putErrLn = hPutStrLn stderr+cancelMissing :: (FilePath -> IO (Maybe a)) -> FilePath -> CYIO a+cancelMissing act f = liftIO (act f) >>= \res -> case res of+  Nothing  -> failMessages [errModificationTime f]+  Just val -> ok val --- Prints a list of error messages on 'stderr'-putErrsLn :: [String] -> IO ()-putErrsLn = mapM_ putErrLn+errUnknownOptions :: SpanInfo -> [String] -> Message+errUnknownOptions spi errs = spanInfoMessage spi $+  text "Unknown flag(s) in {-# OPTIONS_FRONTEND #-} pragma:"+  <+> sep (punctuate comma $ map text errs) --- Prints a list of error messages on 'stderr' and aborts the program-abortWith :: [String] -> IO a-abortWith errs = putErrsLn errs >> exitWith (ExitFailure 1)+errIllegalOption :: SpanInfo -> String -> Message+errIllegalOption spi err = spanInfoMessage spi $+  text "Illegal option in {-# OPTIONS_FRONTEND #-} pragma:" <+> text err +errMissing :: String -> String -> Message+errMissing what which = message $ sep $ map text+  [ "Missing", what, quote which ] --- Error messages+errUnrecognized :: String -> Message+errUnrecognized f = message $ sep $ map text+  [ "Unrecognized input", quote f ] -missingModule :: FilePath -> String-missingModule file = "Error: missing module \"" ++ file ++ "\""+errModificationTime :: FilePath -> Message+errModificationTime f = message $ sep $ map text+  [ "Could not inspect modification time of file", quote f ] ----------------------------------------------------------------------------------------------------------------------------------------------------------------+quote :: String -> String+quote s = "\"" ++ s ++ "\""
− src/CurryCompilerOpts.hs 
@@ -1,166 +0,0 @@--- -------------------------------------------------------------------------------- |--- CurryCompilerOpts - Defines data structures containing options for---                     compiling Curry programs (see module "CurryCompiler")------ September 2005,--- Martin Engelke (men@informatik.uni-kiel.de)--- March 2007, extensions by Sebastian Fischer (sebf@informatik.uni-kiel.de)------ -------------------------------------------------------------------------------module CurryCompilerOpts where--import System.Console.GetOpt----- | Data type for recording compiler options-data Options-  = Options-  { force :: Bool             -- ^ force compilation-  , html :: Bool              -- ^ generate Html code-  , importPaths :: [FilePath] -- ^ directories for searching imports-  , output :: Maybe FilePath  -- ^ name of output file-  , noInterface :: Bool       -- ^ do not create an interface file-  , noVerb :: Bool            -- ^ verbosity on/off-  , noWarn :: Bool            -- ^ warnings on/off-  , noOverlapWarn :: Bool     -- ^ "overlap" warnings on/off-  , flat :: Bool              -- ^ generate FlatCurry code-  , extendedFlat :: Bool      -- ^ generate FlatCurry code with extensions-  , flatXml :: Bool           -- ^ generate flat XML code-  , abstract :: Bool          -- ^ generate typed AbstracCurry code-  , untypedAbstract :: Bool   -- ^ generate untyped AbstractCurry code-  , parseOnly :: Bool         -- ^ generate source representation-  , withExtensions :: Bool    -- ^ enable extended functionalities-  , dump :: [Dump]            -- ^ dumps-  , writeToSubdir :: Bool     -- ^ should the output be written to the subdir?-  } deriving Show----- | Default compiler options-defaultOpts = Options-  { force           = False-  , html            = False-  , importPaths     = []-  , output          = Nothing-  , noInterface     = False-  , noVerb          = False-  , noWarn          = False-  , noOverlapWarn   = False-  , extendedFlat    = False-  , flat            = False-  , flatXml         = False-  , abstract        = False-  , untypedAbstract = False-  , parseOnly       = False-  , withExtensions  = False-  , dump            = []-  , writeToSubdir   = True-  }----- | Data type for representing all available options (needed to read and parse---   the options from the command line; see module 'GetOpt')-data Option-  = Help | Force | Html-  | ImportPath FilePath | Output FilePath-  | NoInterface | NoVerb | NoWarn | NoOverlapWarn-  | FlatXML | Flat | ExtFlat | Abstract | UntypedAbstract | ParseOnly-  | WithExtensions-  | Dump [Dump]-  | WriteToSubdir-  deriving Eq----- | All available compiler options-options =-  [ Option "f"  ["force"] (NoArg Force)-              "force compilation of dependent files"-  , Option ""   ["html"] (NoArg Html)-              "generate html code"-  , Option "i"  ["import-dir"] (ReqArg ImportPath "DIR")-              "search for imports in DIR"-  , Option "o"  ["output"] (ReqArg Output "FILE")-              "write code to FILE"-  , Option ""   ["no-intf"] (NoArg NoInterface)-              "do not create an interface file"-  , Option ""   ["no-verb"] (NoArg NoVerb)-          "do not print compiler messages"-  , Option ""   ["no-warn"] (NoArg NoWarn)-          "do not print warnings"-  , Option ""   ["no-overlap-warn"] (NoArg NoOverlapWarn)-          "do not print warnings for overlapping rules"-  , Option ""   ["flat"] (NoArg Flat)-              "generate FlatCurry code"-  , Option ""   ["extended-flat"] (NoArg ExtFlat)-              "generate FlatCurry code with source references"-  , Option ""   ["xml"] (NoArg FlatXML)-              "generate flat xml code"-  , Option ""   ["acy"] (NoArg Abstract)-              "generate (type infered) AbstractCurry code"-  , Option ""   ["uacy"] (NoArg UntypedAbstract)-              "generate untyped AbstractCurry code"-  , Option ""   ["parse-only"] (NoArg ParseOnly)-              "generate source representation"-  , Option "e"  ["extended"] (NoArg WithExtensions)-              "enable extended Curry functionalities"-  , Option ""   ["dump-all"] (NoArg (Dump [minBound..maxBound]))-              "dump everything"-  , Option ""   ["dump-renamed"] (NoArg (Dump [DumpRenamed]))-              "dump source code after renaming"-  , Option ""   ["dump-types"] (NoArg (Dump [DumpTypes]))-              "dump types after type-checking"-  , Option ""   ["dump-desugared"] (NoArg (Dump [DumpDesugared]))-              "dump source code after desugaring"-  , Option ""   ["dump-simplified"] (NoArg (Dump [DumpSimplified]))-              "dump source code after simplification"-  , Option ""   ["dump-lifted"] (NoArg (Dump [DumpLifted]))-              "dump source code after lambda-lifting"-  , Option ""   ["dump-il"] (NoArg (Dump [DumpIL]))-              "dump intermediate language before lifting"-  , Option ""   ["dump-case"] (NoArg (Dump [DumpCase]))-              "dump intermediate language after case simplification"-  , Option "?h" ["help"] (NoArg Help)-              "display this help and exit"-  , Option ""   ["no-hidden-subdir"] (NoArg WriteToSubdir)-              "write all output to hidden .curry subdirectory"-  ]----- | Marks an 'Option' as selected in the 'Options' record-selectOption :: Option -> Options -> Options-selectOption Force opts           = opts { force = True }-selectOption (ImportPath dir) opts-   = opts { importPaths = dir:(importPaths opts) }-selectOption (Output file) opts   = opts { output = Just file }-selectOption NoInterface opts     = opts { noInterface = True }-selectOption NoVerb opts          = opts { noVerb = True }-selectOption NoWarn opts          = opts { noWarn = True }-selectOption NoOverlapWarn opts   = opts { noOverlapWarn = True }-selectOption Flat opts            = opts { flat = True }-selectOption ExtFlat opts         = opts { extendedFlat = True }-selectOption Html opts            = opts { html = True }-selectOption FlatXML opts         = opts { flatXml = True }-selectOption Abstract opts        = opts { abstract = True }-selectOption UntypedAbstract opts = opts { untypedAbstract = True }-selectOption ParseOnly opts       = opts { parseOnly = True }-selectOption WithExtensions opts  = opts { withExtensions = True }-selectOption (Dump ds) opts       = opts { dump = ds ++ dump opts }-selectOption WriteToSubdir opts   = opts { writeToSubdir = False }----- | Data type for representing code dumps---   TODO: dump FlatCurry code, dump AbstractCurry code, dump after 'case'---   expansion-data Dump-  = DumpRenamed      -- ^ dump source after renaming-  | DumpTypes        -- ^ dump types after typechecking-  | DumpDesugared    -- ^ dump source after desugaring-  | DumpSimplified   -- ^ dump source after simplification-  | DumpLifted       -- ^ dump source after lambda-lifting-  | DumpIL           -- ^ dump IL code after translation-  | DumpCase         -- ^ dump IL code after case elimination-    deriving (Eq,Bounded,Enum,Show)-----------------------------------------------------------------------------------------------------------------------------------------------------------------
+ src/CurryDeps.hs view
@@ -0,0 +1,191 @@+{- |+    Module      :  $Header$+    Description :  Computation of module dependencies+    Copyright   :  (c) 2002 - 2004 Wolfgang Lux+                       2005        Martin Engelke+                       2007        Sebastian Fischer+                       2011 - 2013 Björn Peemöller+                       2016 - 2017 Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module implements the functions to compute the dependency+    information between Curry modules. This is used to create Makefile+    dependencies and to update programs composed of multiple modules.+-}+{-# LANGUAGE CPP #-}+module CurryDeps+  ( Source (..), flatDeps, deps, flattenDeps, sourceDeps, moduleDeps ) where++#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif++import           Control.Monad   (foldM)+import           Data.List       (isSuffixOf, nub)+import qualified Data.Map as Map (Map, empty, insert, lookup, toList)++import Curry.Base.Ident+import Curry.Base.Monad+import Curry.Base.Pretty+import Curry.Files.Filenames+import Curry.Files.PathUtils+import Curry.Syntax+  ( Module (..), ModulePragma (..), ImportDecl (..), parseHeader, parsePragmas+  , patchModuleId, hasLanguageExtension)++import Base.Messages+import Base.SCC (scc)+import CompilerOpts (Options (..), CppOpts (..), KnownExtension (..))+import CondCompile (condCompile)++-- |Different types of source files+data Source+    -- | A source file with pragmas and module imports+  = Source FilePath [ModulePragma] [ModuleIdent]+    -- | An interface file+  | Interface FilePath+    -- | An unknown file+  | Unknown+    deriving (Eq, Show)++type SourceEnv = Map.Map ModuleIdent Source++-- |Retrieve the dependencies of a source file in topological order+-- and possible errors during flattering+flatDeps :: Options -> FilePath -> CYIO [(ModuleIdent, Source)]+flatDeps opts fn = do+  sEnv <- deps opts Map.empty fn+  case flattenDeps sEnv of+    (env, []  ) -> ok env+    (_  , errs) -> failMessages errs++-- |Retrieve the dependencies of a source file as a 'SourceEnv'+deps :: Options -> SourceEnv -> FilePath -> CYIO SourceEnv+deps opts sEnv fn+  | ext   ==   icurryExt  = return sEnv+  | ext `elem` sourceExts = sourceDeps opts sEnv fn+  | otherwise             = targetDeps opts sEnv fn+  where ext = takeExtension fn++-- The following functions are used to lookup files related to a given+-- module. Source files for targets are looked up in the current+-- directory only. Two different search paths are used to look up+-- imported modules, the first is used to find source modules, whereas+-- the library path is used only for finding matching interface files. As+-- the compiler does not distinguish these paths, we actually check for+-- interface files in the source paths as well.++-- In order to compute the dependency graph, source files for each module+-- need to be looked up. When a source module is found, its header is+-- parsed in order to determine the modules that it imports, and+-- dependencies for these modules are computed recursively. The prelude+-- is added implicitly to the list of imported modules except for the+-- prelude itself.++-- |Retrieve the dependencies of a given target file+targetDeps :: Options -> SourceEnv -> FilePath -> CYIO SourceEnv+targetDeps opts sEnv fn = do+  mFile <- liftIO $ lookupFile [""] sourceExts fn+  case mFile of+    Nothing   -> return $ Map.insert (mkMIdent [fn]) Unknown sEnv+    Just file -> sourceDeps opts sEnv file++-- |Retrieve the dependencies of a given source file+sourceDeps :: Options -> SourceEnv -> FilePath -> CYIO SourceEnv+sourceDeps opts sEnv fn = readHeader opts fn >>= moduleDeps opts sEnv fn++-- |Retrieve the dependencies of a given module+moduleDeps :: Options -> SourceEnv -> FilePath -> Module a -> CYIO SourceEnv+moduleDeps opts sEnv fn mdl@(Module _ _ ps m _ _ _) = case Map.lookup m sEnv of+  Just  _ -> return sEnv+  Nothing -> do+    let imps  = imports opts mdl+        sEnv' = Map.insert m (Source fn ps imps) sEnv+    foldM (moduleIdentDeps opts) sEnv' imps++-- |Retrieve the imported modules and add the import of the Prelude+-- according to the compiler options.+imports :: Options -> Module a -> [ModuleIdent]+imports opts mdl@(Module _ _ _ m _ is _) = nub $+     [preludeMIdent | m /= preludeMIdent && not noImplicitPrelude]+  ++ [m' | ImportDecl _ m' _ _ _ <- is]+  where noImplicitPrelude = NoImplicitPrelude `elem` optExtensions opts+                              || mdl `hasLanguageExtension` NoImplicitPrelude++-- |Retrieve the dependencies for a given 'ModuleIdent'+moduleIdentDeps :: Options -> SourceEnv -> ModuleIdent -> CYIO SourceEnv+moduleIdentDeps opts sEnv m = case Map.lookup m sEnv of+  Just _  -> return sEnv+  Nothing -> do+    mFile <- liftIO $ lookupCurryModule ("." : optImportPaths opts)+                                        (optLibraryPaths opts) m+    case mFile of+      Nothing -> return $ Map.insert m Unknown sEnv+      Just fn+        | icurryExt `isSuffixOf` fn ->+            return $ Map.insert m (Interface fn) sEnv+        | otherwise                 -> do+            hdr@(Module _ _ _ m' _ _ _) <- readHeader opts fn+            if m == m' then moduleDeps opts sEnv fn hdr+                       else failMessages [errWrongModule m m']++readHeader :: Options -> FilePath -> CYIO (Module ())+readHeader opts fn = do+  mbFile <- liftIO $ readModule fn+  case mbFile of+    Nothing  -> failMessages [errMissingFile fn]+    Just src -> do+      prgs <- liftCYM $ parsePragmas fn src+      let cppOpts  = optCppOpts opts+          cppOpts' =+            cppOpts { cppRun = cppRun cppOpts || hasLanguageExtension prgs CPP }+      condC <- condCompile cppOpts' fn src+      hdr <- liftCYM $ parseHeader fn condC+      return $ patchModuleId fn hdr++-- If we want to compile the program instead of generating Makefile+-- dependencies, the environment has to be sorted topologically. Note+-- that the dependency graph should not contain any cycles.+flattenDeps :: SourceEnv -> ([(ModuleIdent, Source)], [Message])+flattenDeps = fdeps . sortDeps+  where+  sortDeps :: SourceEnv -> [[(ModuleIdent, Source)]]+  sortDeps = scc idents imported . Map.toList++  idents (m, _) = [m]++  imported (_, Source _ _ ms) = ms+  imported (_,             _) = []++  fdeps :: [[(ModuleIdent, Source)]] -> ([(ModuleIdent, Source)], [Message])+  fdeps = foldr checkdep ([], [])++  checkdep []    (srcs, errs) = (srcs      , errs      )+  checkdep [src] (srcs, errs) = (src : srcs, errs      )+  checkdep dep   (srcs, errs) = (srcs      , err : errs)+    where err = errCyclicImport $ map fst dep++errMissingFile :: FilePath -> Message+errMissingFile fn = message $ sep $ map text [ "Missing file:", fn ]++errWrongModule :: ModuleIdent -> ModuleIdent -> Message+errWrongModule m m' = message $ sep $+  [ text "Expected module for", text (moduleName m) <> comma+  , text "but found", text (moduleName m') ]++errCyclicImport :: [ModuleIdent] -> Message+errCyclicImport []  = internalError "CurryDeps.errCyclicImport: empty list"+errCyclicImport [m] = message $ sep $ map text+  [ "Recursive import for module", moduleName m ]+errCyclicImport ms  = message $ sep $+  text "Cyclic import dependency between modules" : punctuate comma inits+  ++ [text "and", lastm]+  where+  (inits, lastm)     = splitLast $ map (text . moduleName) ms+  splitLast []       = internalError "CurryDeps.splitLast: empty list"+  splitLast (x : []) = ([]    , x)+  splitLast (x : xs) = (x : ys, y) where (ys, y) = splitLast xs
− src/CurryDeps.lhs 
@@ -1,144 +0,0 @@--% $Id: CurryDeps.lhs,v 1.14 2004/02/09 17:10:05 wlux Exp $-%-% Copyright (c) 2002-2004, Wolfgang Lux-% See LICENSE for the full license.-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-% Extended by Sebastian Fischer (sebf@informatik.uni-kiel.de)-\nwfilename{CurryDeps.lhs}-\section{Building Programs}-This module implements the functions to compute the dependency-information between Curry modules. This is used to create Makefile-dependencies and to update programs composed of multiple modules.-\begin{verbatim}--> module CurryDeps(Source(..),->                  deps, flattenDeps, sourceDeps, moduleDeps->                 ) where--> import Data.List-> import qualified Data.Map as Map-> import Data.Maybe-> import Control.Monad--> import Curry.Base.Ident-> import Curry.Base.MessageMonad--> import Curry.Files.Filenames-> import Curry.Files.PathUtils--> import Curry.Syntax hiding(Interface(..))--> import SCC---> data Source = Source FilePath [ModuleIdent]->             | Interface FilePath->             | Unknown->             deriving (Eq,Ord,Show)-> type SourceEnv = Map.Map ModuleIdent Source--> deps :: [FilePath] -> [FilePath] -> SourceEnv -> FilePath -> IO SourceEnv-> deps paths libraryPaths mEnv fn->   | e `elem` sourceExts = sourceDeps paths libraryPaths (mkMIdent [r]) mEnv fn->   | e == icurryExt = return Map.empty->   | e `elem` objectExts = targetDeps paths libraryPaths mEnv r->   | otherwise = targetDeps paths libraryPaths mEnv fn->   where r = dropExtension fn->         e = takeExtension fn--> targetDeps :: [FilePath] -> [FilePath] -> SourceEnv -> FilePath->            -> IO SourceEnv-> targetDeps paths libraryPaths mEnv fn =->   lookupFile [""] sourceExts fn >>=->   maybe (return (Map.insert m Unknown mEnv)) (sourceDeps paths libraryPaths m mEnv)->   where m = mkMIdent [fn]--\end{verbatim}-The following functions are used to lookup files related to a given-module. Source files for targets are looked up in the current-directory only. Two different search paths are used to look up-imported modules, the first is used to find source modules, whereas-the library path is used only for finding matching interface files. As-the compiler does not distinguish these paths, we actually check for-interface files in the source paths as well.--Note that the functions \texttt{buildScript} and \texttt{makeDepend}-already remove all directories that are included in the both search-paths from the library paths in order to avoid scanning such-directories more than twice.-\begin{verbatim}--\end{verbatim}-In order to compute the dependency graph, source files for each module-need to be looked up. When a source module is found, its header is-parsed in order to determine the modules that it imports, and-dependencies for these modules are computed recursively. The prelude-is added implicitly to the list of imported modules except for the-prelude itself. Any errors reported by the parser are ignored.-\begin{verbatim}--> moduleDeps :: [FilePath] -> [FilePath] -> SourceEnv -> ModuleIdent->            -> IO SourceEnv-> moduleDeps paths libraryPaths mEnv m =->   case Map.lookup m mEnv of->     Just _ -> return mEnv->     Nothing ->->       do->         mbFn <- lookupModule paths libraryPaths m->         case mbFn of->           Just fn->             | icurryExt `isSuffixOf` fn ->->                 return (Map.insert m (Interface fn) mEnv)->             | otherwise -> sourceDeps paths libraryPaths m mEnv fn->           Nothing -> return (Map.insert m Unknown mEnv)--> sourceDeps :: [FilePath] -> [FilePath] -> ModuleIdent -> SourceEnv->            -> FilePath -> IO SourceEnv-> sourceDeps paths libraryPaths m mEnv fn =->   do->     s <- readModule fn->     case fst $ runMsg $ parseHeader fn s of->       Right (Module m' _ ds) ->->         let ms = imports m' ds in->         foldM (moduleDeps paths libraryPaths) (Map.insert m (Source fn ms) mEnv) ms->       Left _ -> return (Map.insert m (Source fn []) mEnv)--> imports :: ModuleIdent -> [Decl] -> [ModuleIdent]-> imports m ds = nub $->   [preludeMIdent | m /= preludeMIdent] ++ [m | ImportDecl _ m _ _ _ <- ds]----If we want to compile the program instead of generating Makefile-dependencies the environment has to be sorted topologically. Note-that the dependency graph should not contain any cycles.--> flattenDeps :: SourceEnv -> ([(ModuleIdent,Source)],[String])-> flattenDeps = fdeps . sortDeps->     where->     sortDeps :: SourceEnv -> [[(ModuleIdent,Source)]]->     sortDeps = scc modules imports . Map.toList->->     modules (m, _) = [m]->->     imports (_,Source _ ms) = ms->     imports (_,Interface _) = []->     imports (_,Unknown) = []->->     fdeps :: [[(ModuleIdent,Source)]] -> ([(ModuleIdent,Source)],[String])->     fdeps = foldr checkdep ([], [])->     ->     checkdep [] (ms', es')  = (ms',es')->     checkdep [m] (ms', es') = (m:ms',es')->     checkdep dep (ms', es') = (ms',cyclicError (map fst dep) : es')->->     cyclicError :: [ModuleIdent] -> String->     cyclicError (m:ms) =->         "Cylic import dependency between modules " ++ show m ++ rest ms->->     rest [m] = " and " ++ show m->     rest ms  = rest' ms->     rest' [m] = ", and " ++ show m->     rest' (m:ms) = ", " ++ show m ++ rest' ms
− src/CurryEnv.hs 
@@ -1,181 +0,0 @@---------------------------------------------------------------------------------------------------------------------------------------------------------------------- CurryEnv - Generates a record containing extracted and prepared data---            from a CurrySyntax module------ November 2005,--- Martin Engelke (men@informatik.uni-kiel.de)----module CurryEnv (CurryEnv(..), curryEnv) where--import Data.Maybe--import Curry.Base.Position-import Curry.Base.Ident--import Curry.Syntax--import Types-import Base------------------------------------------------------------------------------------- A record containing the following data for a module 'm':------    moduleId    - the name of 'm'---    exports     - the export list extracted from 'm'---    interface   - all exported declarations in 'm' (including exported ---                  imports)---    infixDecls  - interfaces of all infix declarations in 'm'---    typeSynonym - interfaces of all type synonyms in 'm'----data CurryEnv = CurryEnv{ moduleId     :: ModuleIdent,-			  exports      :: [Export],-			  imports      :: [IDecl],-			  interface    :: [IDecl],-			  infixDecls   :: [IDecl],-			  typeSynonyms :: [IDecl]-			} deriving Show-			  ------------------------------------------------------------------------------------- Returns a Curry environment for the module 'mod' and its corresponding--- environments 'mEnv' (imported modules), 'tcEnv' (table of type--- constructors) and 'intf' (the interface of 'mod')-curryEnv :: ModuleEnv -> TCEnv -> Interface -> Module -> CurryEnv-curryEnv mEnv tcEnv (Interface iid idecls) mod@(Module mid mExp decls)-   | iid == mid-     = CurryEnv{ moduleId     = mid,-		 exports      = maybe [] (\ (Exporting _ exps) -> exps) mExp,-		 imports      = genImportIntf decls,-		 interface    = idecls,-		 infixDecls   = genInfixDecls mod,-		 typeSynonyms = genTypeSyns tcEnv mod-	       }-   | otherwise-     = internalError ("CurryEnv: interface \"" ++ show iid -		      ++ "\" does not match module \"" ++ show mid ++ "\"")---------------------------------------------------------------------------------------------------------------------------------------------------------------------- Generate interfaces for import declarations-genImportIntf :: [Decl] -> [IDecl]-genImportIntf decls = reverse (map snd (foldl genImpIntf [] decls))-----genImpIntf imps (ImportDecl pos mid _ _ _)-   = maybe ((mid, IImportDecl pos mid):imps) (const imps) (lookup mid imps)-genImpIntf imps _ = imps-------------------------------------------------------------------------------------- Generate interface declaration for all infix declarations in the module-genInfixDecls :: Module -> [IDecl]-genInfixDecls (Module mident _ decls) = collectIInfixDecls mident decls-----collectIInfixDecls :: ModuleIdent -> [Decl] -> [IDecl]-collectIInfixDecls mident [] = []-collectIInfixDecls mident ((InfixDecl pos infixspec prec idents):decls)-   = (map (\ident -	   -> IInfixDecl pos infixspec prec (qualifyWith mident ident)) -	   idents)-     ++ (collectIInfixDecls mident decls)-collectIInfixDecls mident (_:decls) = collectIInfixDecls mident decls-------------------------------------------------------------------------------------- Generate interface declarations for all type synonyms in the module.-genTypeSyns :: TCEnv -> Module -> [IDecl]-genTypeSyns tcEnv (Module mident _ decls)-   = concatMap (genTypeSynDecl mident tcEnv) (filter isTypeSyn decls)-----genTypeSynDecl :: ModuleIdent -> TCEnv -> Decl -> [IDecl]-genTypeSynDecl mid tcEnv (TypeDecl pos ident params texpr)-   = [genTypeDecl pos mid ident params tcEnv texpr]-genTypeSynDecl _ _ _ -   = []-----genTypeDecl :: Position -> ModuleIdent -> Ident -> [Ident] -> TCEnv-	    -> TypeExpr -> IDecl-genTypeDecl pos mid ident params tcEnv texpr-   = ITypeDecl pos (qualifyWith mid ident) params-               (modifyTypeExpr tcEnv texpr)------modifyTypeExpr :: TCEnv -> TypeExpr -> TypeExpr-modifyTypeExpr tcEnv (ConstructorType qident typeexprs)-   = case (qualLookupTC qident tcEnv) of-       [AliasType _ arity rhstype]-          -> modifyTypeExpr tcEnv -	                    (genTypeSynDeref (zip [0 .. (arity-1)] typeexprs)-			                     rhstype)-       _  -> ConstructorType (fromMaybe qident (lookupTCId qident tcEnv))-                             (map (modifyTypeExpr tcEnv) typeexprs)-modifyTypeExpr _ (VariableType ident)-   = VariableType ident-modifyTypeExpr tcEnv (ArrowType type1 type2)-   = ArrowType (modifyTypeExpr tcEnv type1) (modifyTypeExpr tcEnv type2)-modifyTypeExpr tcEnv (TupleType typeexprs)-   | null typeexprs -     = ConstructorType qUnitId []-   | otherwise-     = ConstructorType (qTupleId (length typeexprs)) -                       (map (modifyTypeExpr tcEnv) typeexprs)-modifyTypeExpr tcEnv (ListType typeexpr)-   = ConstructorType (qualify listId) [(modifyTypeExpr tcEnv typeexpr)]-modifyTypeExpr tcEnv (RecordType fields rtype)-   = RecordType (map (\ (labs, texpr) -> (labs, (modifyTypeExpr tcEnv texpr)))-		     fields)-                (maybe Nothing (Just . modifyTypeExpr tcEnv) rtype)-----genTypeSynDeref :: [(Int,TypeExpr)] -> Type -> TypeExpr-genTypeSynDeref its (TypeConstructor qident typeexprs)-   = ConstructorType qident (map (genTypeSynDeref its) typeexprs)-genTypeSynDeref its (TypeVariable i)-   = fromMaybe (internalError ("@CurryInfo.genTypeSynDeref: " ++-			       "unkown type var index"))-               (lookup i its)-genTypeSynDeref its (TypeConstrained typeexprs i)-   = internalError ("@CurryInfo.genTypeSynDeref: " ++-		    "illegal constrained type occured")-genTypeSynDeref its (TypeArrow type1 type2)-   = ArrowType (genTypeSynDeref its type1) (genTypeSynDeref its type2)-genTypeSynDeref its (TypeSkolem i)-   = internalError ("@CurryInfo.genTypeSynDeref: " ++-		    "illegal skolem type occured")-genTypeSynDeref its (TypeRecord fields ri)-   = RecordType (map (\ (lab, texpr) -> ([lab], genTypeSynDeref its texpr))-		     fields)-                (maybe Nothing -		       (\i -> Just (genTypeSynDeref its (TypeVariable i)))-		       ri)-----lookupTCId :: QualIdent -> TCEnv -> Maybe QualIdent-lookupTCId qident tcEnv-   = case (qualLookupTC qident tcEnv) of-       [DataType qident' _ _]     -> Just qident'-       [RenamingType qident' _ _] -> Just qident'-       [AliasType qident' _ _]    -> Just qident'-       _                          -> Nothing----isTypeSyn :: Decl -> Bool-isTypeSyn (TypeDecl _ _ _ texpr)-   = case texpr of-       RecordType _ _ -> False-       _              -> True-isTypeSyn _ = False
− src/CurryHtml.hs 
@@ -1,190 +0,0 @@-module CurryHtml(source2html) where--import Data.Char hiding(Space)-import Control.Exception--import Curry.Base.Ident-import Curry.Base.MessageMonad--import Curry.Files.PathUtils (readModule, writeModule, getCurryPath)--import SyntaxColoring-import Curry.Syntax.Frontend as Frontend------- translate source file into HTML file with syntaxcoloring---- @param outputfilename---- @param sourcefilename-source2html :: [String] -> String -> String -> IO ()-source2html imports outputfilename sourcefilename = do-        let sourceprogname = removeExtension sourcefilename-            output = if null outputfilename -                     then sourceprogname ++ "_curry.html"-                     else outputfilename -            modulname = fileName sourceprogname-        fullfname <- getCurryPath imports sourcefilename-        program <- filename2program imports (maybe sourcefilename id fullfname)-        (if null outputfilename then writeModule True output -                                else writeFile   output)-           (program2html modulname program)-             ---- @param importpaths---- @param filename                  ---- @return program-filename2program :: [String] -> String -> IO Program-filename2program paths filename-    = do cont <- readModule filename-         typingParseResult <- (catchError (typingParse paths filename  cont))-         fullParseResult <- (catchError (fullParse paths filename  cont))-         parseResult <- (catchError (return (parse filename cont)))-         lexResult <- (catchError (return (Frontend.lex filename cont)))-         return (genProgram cont (typingParseResult : fullParseResult : [parseResult]) lexResult)------ this function intercepts errors and converts it to Messages      ---- @param a show-function for (Result a)                    ---- @param a function that generates a (Result a)---- @return (Result a) without runtimeerrors   ---- FIXME This is ugly. Avoid exceptions and report failure via MsgMonad instead! (hsi)-catchError :: Show a =>IO (MsgMonad a) -> IO (MsgMonad a)-catchError toDo = Control.Exception.catch (toDo >>= returnNF) handler -  where     -    -- This refers to base3-    handler (ErrorCall str) = return (failWith str)-    handler  e = return (failWith (show e))  -             -    returnNF a = normalform a `seq` return a-    normalform = length . show . runMsg-                -       ----- generates htmlcode with syntax highlighting            ---- @param modulname---- @param a program---- @return HTMLcode-program2html :: String ->Program -> String-program2html modulname codes =-    "<html>\n<head>\n<title>Module "++ -    modulname++-    "</title>\n" ++-    "<link rel=\"stylesheet\" type=\"text/css\" href=\"currydoc.css\">"++-    "</link>\n</head>\n<body style=\"font-family:'Courier New', Arial;\">\n<pre>\n" ++-    concat (map (code2html True . (\(_,_,c) -> c)) codes) ++-    "<pre>\n</body>\n</html>"            -            -            ---- which code has which color ---- @param code---- @return color of the code  -code2class :: Code -> String                          -code2class (Keyword _) = "keyword"-code2class (Space _)= ""-code2class NewLine = ""-code2class (ConstructorName ConstrPattern _) = "constructorname_constrpattern"-code2class (ConstructorName ConstrCall _) = "constructorname_constrcall"-code2class (ConstructorName ConstrDecla _) = "constructorname_constrdecla"-code2class (ConstructorName OtherConstrKind _) = "constructorname_otherconstrkind"-code2class (Function InfixFunction _) = "function_infixfunction"-code2class (Function TypSig _) = "function_typsig"-code2class (Function FunDecl _) = "function_fundecl"-code2class (Function FunctionCall _) = "function_functioncall"-code2class (Function OtherFunctionKind _) = "function_otherfunctionkind"-code2class (ModuleName _) = "modulename"-code2class (Commentary _) = "commentary"-code2class (NumberCode _) = "numbercode"-code2class (StringCode _) = "stringcode"-code2class (CharCode _) = "charcode"-code2class (Symbol _) = "symbol"-code2class (Identifier IdDecl _) = "identifier_iddecl"-code2class (Identifier IdOccur _) = "identifier_idoccur"-code2class (Identifier UnknownId _) = "identifier_unknownid"-code2class (TypeConstructor TypeDecla _) = "typeconstructor_typedecla"-code2class (TypeConstructor TypeUse _) = "typeconstructor_typeuse"-code2class (TypeConstructor TypeExport _) = "typeconstructor_typeexport"-code2class (CodeWarning _ _) = "codewarning"-code2class (NotParsed _) = "notparsed"---code2html :: Bool -> Code -> String    -code2html ownClass code@(CodeWarning _ c) =-     (if ownClass then spanTag (code2class code) else id)-              (code2html False c)       -code2html ownClass code@(Commentary _) =-    (if ownClass then spanTag (code2class code) else id)-      (replace '<' "<span>&lt</span>" (code2string code))                -code2html ownClass c-      | isCall c && ownClass = maybe tag (addHtmlLink tag) (getQualIdent c) -      | isDecl c && ownClass= maybe tag (addHtmlAnchor tag) (getQualIdent c)-      | otherwise = tag-    where tag = (if ownClass then spanTag (code2class c) else id)-                      (htmlQuote (code2string c)) -                                        -spanTag :: String -> String -> String-spanTag [] str = str-spanTag cl str = "<span class=\""++ cl ++ "\">" ++ str ++ "</span>"--replace :: Char -> String -> String -> String-replace old new = foldr (\ x -> if x == old then (new ++) else ([x]++)) ""--addHtmlAnchor :: String -> QualIdent -> String-addHtmlAnchor html qualIdent = "<a name=\""++ string2urlencoded (show (unqualify qualIdent)) ++"\"></a>" ++ html--addHtmlLink :: String -> QualIdent -> String-addHtmlLink html qualIdent =-   let (maybeModuleIdent,ident) = (qualidMod qualIdent, qualidId qualIdent) in-   "<a href=\"" ++ -   (maybe "" (\x -> show x ++ "_curry.html") maybeModuleIdent) ++ -   "#"++ -   string2urlencoded (show ident) ++-   "\">"++ -   html ++-   "</a>"--isCall :: Code -> Bool-isCall (TypeConstructor TypeExport _) = True-isCall (TypeConstructor _ _) = False-isCall (Identifier _ _) = False-isCall code = not (isDecl code) &&-                maybe False (const True) (getQualIdent code)--     -isDecl :: Code -> Bool-isDecl (ConstructorName ConstrDecla _) = True-isDecl (Function FunDecl _) = True-isDecl (TypeConstructor TypeDecla _) = True-isDecl _ = False ---fileName = reverse . takeWhile (/='/') . reverse --removeExtension = reverse . drop 1 . dropWhile (/='.') . reverse ------ Translates arbitrary strings into equivalent urlencoded string.-string2urlencoded :: String -> String-string2urlencoded = id-{--string2urlencoded [] = []-string2urlencoded (c:cs)-  | isAlphaNum c = c : string2urlencoded cs-  | c == ' '     = '+' : string2urlencoded cs-  | otherwise = show (ord c) ++ (if null cs then "" else ".") ++ string2urlencoded cs--}--htmlQuote :: String -> String-htmlQuote [] = []-htmlQuote (c:cs) | c=='<' = "&lt;"   ++ htmlQuote cs-                 | c=='>' = "&gt;"   ++ htmlQuote cs-                 | c=='&' = "&amp;"  ++ htmlQuote cs-                 | c=='"' = "&quot;" ++ htmlQuote cs-                 | c=='\228' = "&auml;" ++ htmlQuote cs-                 | c=='\246' = "&ouml;" ++ htmlQuote cs-                 | c=='\252' = "&uuml;" ++ htmlQuote cs-                 | c=='\196' = "&Auml;" ++ htmlQuote cs-                 | c=='\214' = "&Ouml;" ++ htmlQuote cs-                 | c=='\220' = "&Uuml;" ++ htmlQuote cs-                 | c=='\223' = "&szlig;"++ htmlQuote cs-                 | otherwise = c : htmlQuote cs-
− src/Desugar.lhs 
@@ -1,843 +0,0 @@-% $Id: Desugar.lhs,v 1.42 2004/02/15 22:10:32 wlux Exp $-%-% Copyright (c) 2001-2004, Wolfgang Lux-% See LICENSE for the full license.-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-%-\nwfilename{Desugar.lhs}-\section{Desugaring Curry Expressions}-The desugaring pass removes all syntactic sugar from the module. In-particular, the output of the desugarer will have the following-properties.-\begin{itemize}-\item All function definitions are $\eta$-expanded.\\-  {\em Note:} Since this version is used as a frontend for PAKCS, the -  $\eta$-expansion had been disabled.-\item No guarded right hand sides occur in equations, pattern-  declarations, and case alternatives. In addition, the declaration-  lists of the right hand sides are empty; local declarations are-  transformed into let expressions.-\item Patterns in equations and case alternatives are composed only of-  \begin{itemize}-  \item literals,-  \item variables,-  \item constructor applications, and-  \item as patterns.-  \end{itemize}-\item Expressions are composed only of-  \begin{itemize}-  \item literals,-  \item variables,-  \item constructors,-  \item (binary) applications,-  \item let expressions, and-  \item case expressions.-  \end{itemize}-\item Applications $N\:x$ in patterns and expressions, where $N$ is a-  newtype constructor, are replaced by a $x$. Note that neither the-  newtype declaration itself nor partial applications of newtype-  constructors are changed.\footnote{It were possible to replace-  partial applications of newtype constructor by \texttt{prelude.id}.-  However, our solution yields a more accurate output when the result-  of a computation includes partial applications.}-\item Function patterns are replaced by variables and are integrated-  in a guarded right hand side using the \texttt{=:<=} operator-\item Records, which currently must be declared using the keyword-  \texttt{type}, are transformed into data types with one constructor.-  Record construction and pattern matching are represented using the-  record constructor. Selection and update are represented using selector-  and update functions which are generated for each record declaration.-  The record constructor must be entered into the type environment as well-  as the selector functions and the update functions. -\end{itemize}--\ToDo{Use a different representation for the restricted code instead-of using the syntax tree from \texttt{CurrySyntax}.}--\textbf{As we are going to insert references to real prelude entities,-all names must be properly qualified before calling this module.}-\begin{verbatim}--> module Desugar(desugar) where--> import Data.Maybe-> import Control.Arrow(second)-> import Control.Monad.State as S-> import Data.List--> import Curry.Base.Position-> import Curry.Base.Ident-> import Curry.Syntax.Utils-> import Curry.Syntax--> import Types-> import Base-> import Typing-> import Utils----posE = undefined--\end{verbatim}-New identifiers may be introduced while desugaring pattern-declarations, case and $\lambda$-expressions, and list comprehensions.-As usual, we use a state monad transformer for generating unique-names. In addition, the state is also used for passing through the-type environment, which must be augmented with the types of these new-variables.-\begin{verbatim}--> type DesugarState a = S.StateT ValueEnv (S.State Int) a--> run :: DesugarState a -> ValueEnv -> a-> run m tyEnv = S.evalState (S.evalStateT m tyEnv) 1--\end{verbatim}-The desugaring phase keeps only the type, function, and value-declarations of the module. In the current version record declarations-are transformed into data types. The remaining type declarations are-not desugared and cannot occur in local declaration groups.-They are filtered out separately.--In order to use records within other modules, the export specification-of the module has to be extended with the selector and update functions of-all exported labels.--Actually, the transformation is slightly more general than necessary-as it allows value declarations at the top-level of a module.-\begin{verbatim}--> desugar :: ValueEnv -> TCEnv -> Module -> (Module,ValueEnv)-> desugar tyEnv tcEnv (Module m es ds) = (Module m es ds',tyEnv')->   where (ds',tyEnv') = run (desugarModule m tcEnv ds) tyEnv--> desugarModule :: ModuleIdent -> TCEnv -> [Decl] ->	        -> DesugarState ([Decl],ValueEnv)-> desugarModule m tcEnv ds = ->   do->     dss <- mapM (desugarRecordDecl m tcEnv) ds->     let ds' = concat dss->     ds'' <- desugarDeclGroup m tcEnv ds'->     tyEnv' <- S.get->     return (filter isTypeDecl ds' ++ ds'', tyEnv')--\end{verbatim}---Within a declaration group, all type signatures and evaluation-annotations are discarded. First, the patterns occurring in the left-hand sides are desugared. Due to lazy patterns this may add further-declarations to the group that must be desugared as well.-\begin{verbatim}--> desugarDeclGroup :: ModuleIdent -> TCEnv -> [Decl] -> DesugarState [Decl]-> desugarDeclGroup m tcEnv ds =->   do->     dss' <- mapM (desugarDeclLhs m tcEnv) (filter isValueDecl ds)->     mapM (desugarDeclRhs m tcEnv) (concat dss')--> desugarDeclLhs :: ModuleIdent -> TCEnv -> Decl -> DesugarState [Decl]-> desugarDeclLhs m tcEnv (PatternDecl p t rhs) =->   do->     (ds',t') <- desugarTerm m tcEnv p [] t->     dss' <- mapM (desugarDeclLhs m tcEnv) ds'->     return (PatternDecl p t' rhs : concat dss')-> desugarDeclLhs m tcEnv (FlatExternalDecl p fs) =->   do->     tyEnv <- S.get->     return (map (externalDecl tyEnv p) fs)->   where externalDecl tyEnv p f =->           ExternalDecl p CallConvPrimitive (Just (name f)) f->                        (fromType (typeOf tyEnv (Variable (qual f))))->         qual f->           | unRenameIdent f == f = qualifyWith m f->           | otherwise = qualify f-> desugarDeclLhs _ _ d = return [d]--\end{verbatim}-After desugaring its right hand side, each equation is $\eta$-expanded-by adding as many variables as necessary to the argument list and-applying the right hand side to those variables ({\em Note:} $\eta$-expansion-is disabled in the version for PAKCS).-Furthermore every occurrence of a record type within the type of a function-is simplified to the corresponding type constructor from the record-declaration. This is possible because currently records must not be empty-and a record label belongs to only one record declaration.-\begin{verbatim}--> desugarDeclRhs :: ModuleIdent -> TCEnv -> Decl -> DesugarState Decl-> desugarDeclRhs m tcEnv (FunctionDecl p f eqs) =->   do->     tyEnv <- S.get->     let ty =  (flip typeOf (Variable (qual f))) tyEnv->     liftM (FunctionDecl p f) ->	    (mapM (desugarEquation m tcEnv (arrowArgs ty)) eqs)->   where qual f->           | unRenameIdent f == f = qualifyWith m f->           | otherwise = qualify f-> desugarDeclRhs _ tcEnv (ExternalDecl p cc ie f ty) =->   return (ExternalDecl p cc (ie `mplus` Just (name f)) f ty)-> desugarDeclRhs m tcEnv (PatternDecl p t rhs) =->   liftM (PatternDecl p t) (desugarRhs m tcEnv p rhs)-> desugarDeclRhs _ tcEnv (ExtraVariables p vs) = return (ExtraVariables p vs)--> desugarEquation :: ModuleIdent -> TCEnv -> [Type] -> Equation ->	          -> DesugarState Equation-> desugarEquation m tcEnv tys (Equation p lhs rhs) =->   do->     (ds',ts') <- mapAccumM (desugarTerm m tcEnv p) [] ts->     rhs' <- desugarRhs m tcEnv p (addDecls ds' rhs)->     (ts'', rhs'') <- desugarFunctionPatterns m p ts' rhs'->     return (Equation p (FunLhs f ts'') rhs'')->   where (f,ts) = flatLhs lhs---\end{verbatim}-The transformation of patterns is straight forward except for lazy-patterns. A lazy pattern \texttt{\~}$t$ is replaced by a fresh-variable $v$ and a new local declaration $t$~\texttt{=}~$v$ in the-scope of the pattern. In addition, as-patterns $v$\texttt{@}$t$ where-$t$ is a variable or an as-pattern are replaced by $t$ in combination-with a local declaration for $v$.-\begin{verbatim}--> desugarLiteral :: Literal -> DesugarState (Either Literal ([SrcRef],[Literal]))-> desugarLiteral (Char p c) = return (Left (Char p c))-> desugarLiteral (Int v i)  = liftM (Left . fixType) S.get->   where ->    fixType tyEnv->      | typeOf tyEnv v == floatType ->          = Float (srcRefOf $ positionOfIdent v) (fromIntegral i)->      | otherwise = Int v i-> desugarLiteral (Float p f) = return (Left (Float p f))-> desugarLiteral (String (SrcRef [i]) cs) ->   = return (Right (consRefs i cs,zipWith (Char . SrcRef . (:[])) [i,i+2..] cs))->   where consRefs r []     = [SrcRef [r]]->         consRefs r (_:xs) = let r'=r+2 in r' `seq` (SrcRef [r']:consRefs r' xs)-> desugarLiteral (String is _) = error $ "internal error desugarLiteral; "++->                                        "wrong source ref for string: "  ++ show is--> desugarList :: [SrcRef] -> (SrcRef -> b -> b -> b) -> (SrcRef -> b) -> [b] -> b-> desugarList pos cons nil xs = snd (foldr cons' nil' xs)->   where rNil:rCs = reverse pos ->         nil'                = (rCs,nil rNil)->         cons' t (rC:rCs,ts) = (rCs,cons rC t ts)--> desugarTerm :: ModuleIdent -> TCEnv -> Position -> [Decl] -> ConstrTerm->             -> DesugarState ([Decl],ConstrTerm)-> desugarTerm m tcEnv p ds (LiteralPattern l) =->   desugarLiteral l >>=->   either (return . (,) ds . LiteralPattern)->          (\ (pos,ls) -> desugarTerm m tcEnv p ds $ ListPattern pos $ map LiteralPattern ls)-> desugarTerm m tcEnv p ds (NegativePattern _ l) =->   desugarTerm m tcEnv p ds (LiteralPattern (negateLiteral l))->   where negateLiteral (Int v i) = Int v (-i)->         negateLiteral (Float p f) = Float p (-f)->         negateLiteral _ = internalError "negateLiteral"-> desugarTerm _ _ _ ds (VariablePattern v) = return (ds,VariablePattern v)-> desugarTerm m tcEnv p ds (ConstructorPattern c [t]) =->   do->     tyEnv <- S.get->     liftM (if isNewtypeConstr tyEnv c then id else second (constrPat c))->           (desugarTerm m tcEnv p ds t)->   where constrPat c t = ConstructorPattern c [t]-> desugarTerm m tcEnv p ds (ConstructorPattern c ts) =->   liftM (second (ConstructorPattern c)) (mapAccumM (desugarTerm m tcEnv p) ds ts)-> desugarTerm m tcEnv p ds (InfixPattern t1 op t2) =->   desugarTerm m tcEnv p ds (ConstructorPattern op [t1,t2])-> desugarTerm m tcEnv p ds (ParenPattern t) = desugarTerm m tcEnv p ds t-> desugarTerm m tcEnv p ds (TuplePattern pos ts) =->   desugarTerm m tcEnv p ds (ConstructorPattern (tupleConstr ts) ts)->   where tupleConstr ts = addRef pos $ ->                          if null ts then qUnitId else qTupleId (length ts)-> desugarTerm m tcEnv p ds (ListPattern pos ts) =->   liftM (second (desugarList pos cons nil)) (mapAccumM (desugarTerm m tcEnv p) ds ts)->   where nil  p' = ConstructorPattern (addRef p' qNilId) []->         cons p' t ts = ConstructorPattern (addRef p' qConsId) [t,ts]--> desugarTerm m tcEnv p ds (AsPattern v t) =->   liftM (desugarAs p v) (desugarTerm m tcEnv p ds t)-> desugarTerm m tcEnv p ds (LazyPattern pos t) = desugarLazy pos m p ds t-> desugarTerm m tcEnv p ds (FunctionPattern f ts) =->   liftM (second (FunctionPattern f)) (mapAccumM (desugarTerm m tcEnv p) ds ts)-> desugarTerm m tcEnv p ds (InfixFuncPattern t1 f t2) =->   desugarTerm m tcEnv p ds (FunctionPattern f [t1,t2])-> desugarTerm m tcEnv p ds (RecordPattern fs _)->   | null fs = internalError "desugarTerm: empty record"->   | otherwise =->     do tyEnv <- S.get ->	 case (lookupValue (fieldLabel (head fs)) tyEnv) of->          [Label _ r _] -> ->            desugarRecordPattern m tcEnv p ds (map field2Tuple fs) r->          _ -> internalError "desugarTerm: no label"--> desugarAs :: Position -> Ident -> ([Decl],ConstrTerm) -> ([Decl],ConstrTerm)-> desugarAs p v (ds,t) =->  case t of->    VariablePattern v' -> (varDecl p v (mkVar v') : ds,t)->    AsPattern v' _ -> (varDecl p v (mkVar v') : ds,t)->    _ -> (ds,AsPattern v t)--> desugarLazy :: SrcRef -> ModuleIdent -> Position -> [Decl] -> ConstrTerm->             -> DesugarState ([Decl],ConstrTerm)-> desugarLazy pos m p ds t =->   case t of->     VariablePattern _ -> return (ds,t)->     ParenPattern t' -> desugarLazy pos m p ds t'->     AsPattern v t' -> liftM (desugarAs p v) (desugarLazy pos m p ds t')->     LazyPattern pos t' -> desugarLazy pos m p ds t'->     _ ->->       do->         v0 <- S.get >>= freshIdent m "_#lazy" . monoType . flip typeOf t->         let v' = addPositionIdent (AST pos) v0->         return (patDecl p{astRef=pos} t (mkVar v') : ds,VariablePattern v')---\end{verbatim}-A list of boolean guards is expanded into a nested if-then-else-expression, whereas a constraint guard is replaced by a case-expression. Note that if the guard type is \texttt{Success} only a-single guard is allowed for each equation.\footnote{This change was-introduced in version 0.8 of the Curry report.} We check for the-type \texttt{Bool} of the guard because the guard's type defaults to-\texttt{Success} if it is not restricted by the guard expression.-\begin{verbatim}--> desugarRhs :: ModuleIdent -> TCEnv -> Position -> Rhs -> DesugarState Rhs-> desugarRhs m tcEnv p rhs =->   do->     tyEnv <- S.get->     e' <- desugarExpr m tcEnv p (expandRhs tyEnv prelFailed rhs)->     return (SimpleRhs p e' [])--> expandRhs :: ValueEnv -> Expression -> Rhs -> Expression-> expandRhs tyEnv _ (SimpleRhs _ e ds) = Let ds e-> expandRhs tyEnv e0 (GuardedRhs es ds) = Let ds (expandGuards tyEnv e0 es)--> expandGuards :: ValueEnv -> Expression -> [CondExpr] -> Expression-> expandGuards tyEnv e0 es->   | booleanGuards tyEnv es = foldr mkIfThenElse e0 es->   | otherwise = mkCond es->   where mkIfThenElse (CondExpr p g e) = IfThenElse (srcRefOf p) g e->         mkCond [CondExpr p g e] = Apply (Apply prelCond g) e--> booleanGuards :: ValueEnv -> [CondExpr] -> Bool-> booleanGuards _ [] = False-> booleanGuards tyEnv (CondExpr _ g _ : es) =->   not (null es) || typeOf tyEnv g == boolType--> desugarExpr :: ModuleIdent -> TCEnv -> Position -> Expression->             -> DesugarState Expression-> desugarExpr m tcEnv p (Literal l) =->   desugarLiteral l >>=->   either (return . Literal) (\ (pos,ls) -> desugarExpr m tcEnv p $ List pos $ map Literal ls)-> desugarExpr _ _ _ (Variable v) = return (Variable v)-> desugarExpr _ _ _ (Constructor c) = return (Constructor c)-> desugarExpr m tcEnv p (Paren e) = desugarExpr m tcEnv p e-> desugarExpr m tcEnv p (Typed e _) = desugarExpr m tcEnv p e-> desugarExpr m tcEnv p (Tuple pos es) =->   liftM (apply (Constructor (tupleConstr es))) ->         (mapM (desugarExpr m tcEnv p) es)->   where tupleConstr es = addRef pos $ if null es then qUnitId else qTupleId (length es)-> desugarExpr m tcEnv p (List pos es) =->   liftM (desugarList pos cons nil) (mapM (desugarExpr m tcEnv p) es)->   where nil p'  = Constructor (addRef p' qNilId)->         cons p' = Apply . Apply (Constructor $ addRef p' qConsId)-> desugarExpr m tcEnv p (ListCompr pos e []) = desugarExpr m tcEnv p (List [pos,pos] [e])-> desugarExpr m tcEnv p (ListCompr r e (q:qs)) = ->   desugarQual m tcEnv p q (ListCompr r e qs)-> desugarExpr m tcEnv p (EnumFrom e) = ->   liftM (Apply prelEnumFrom) (desugarExpr m tcEnv p e)-> desugarExpr m tcEnv p (EnumFromThen e1 e2) =->   liftM (apply prelEnumFromThen) (mapM (desugarExpr m tcEnv p) [e1,e2])-> desugarExpr m tcEnv p (EnumFromTo e1 e2) =->   liftM (apply prelEnumFromTo) (mapM (desugarExpr m tcEnv p) [e1,e2])-> desugarExpr m tcEnv p (EnumFromThenTo e1 e2 e3) =->   liftM (apply prelEnumFromThenTo) (mapM (desugarExpr m tcEnv p) [e1,e2,e3])-> desugarExpr m tcEnv p (UnaryMinus op e) =->   do->     tyEnv <- S.get->     liftM (Apply (unaryMinus op (typeOf tyEnv e))) (desugarExpr m tcEnv p e)->   where unaryMinus op ty->           | op == minusId =->               if ty == floatType then prelNegateFloat else prelNegate->           | op == fminusId = prelNegateFloat->           | otherwise = internalError "unaryMinus"-> desugarExpr m tcEnv p (Apply (Constructor c) e) =->   do->     tyEnv <- S.get->     liftM (if isNewtypeConstr tyEnv c then id else (Apply (Constructor c)))->           (desugarExpr m tcEnv p e)-> desugarExpr m tcEnv p (Apply e1 e2) =->   do->     e1' <- desugarExpr m tcEnv p e1->     e2' <- desugarExpr m tcEnv p e2->     return (Apply e1' e2')-> desugarExpr m tcEnv p (InfixApply e1 op e2) =->   do->     op' <- desugarExpr m tcEnv p (infixOp op)->     e1' <- desugarExpr m tcEnv p e1->     e2' <- desugarExpr m tcEnv p e2->     return (Apply (Apply op' e1') e2')-> desugarExpr m tcEnv p (LeftSection e op) =->   do->     op' <- desugarExpr m tcEnv p (infixOp op)->     e' <- desugarExpr m tcEnv p e->     return (Apply op' e')-> desugarExpr m tcEnv p (RightSection op e) =->   do->     op' <- desugarExpr m tcEnv p (infixOp op)->     e' <- desugarExpr m tcEnv p e->     return (Apply (Apply prelFlip op') e')-> desugarExpr m tcEnv p exp@(Lambda r ts e) =->   do->     f <- S.get >>=->          freshIdent m "_#lambda" . polyType . flip typeOf exp->     desugarExpr m tcEnv p (Let [funDecl (AST r) f ts e] (mkVar f))-> desugarExpr m tcEnv p (Let ds e) =->   do->     ds' <- desugarDeclGroup m tcEnv ds->     e' <- desugarExpr m tcEnv p e->     return (if null ds' then e' else Let ds' e')-> desugarExpr m tcEnv p (Do sts e) = ->   desugarExpr m tcEnv p (foldr desugarStmt e sts)->   where desugarStmt (StmtExpr r e) e' = apply (prelBind_ r) [e,e']->         desugarStmt (StmtBind r t e) e' = apply (prelBind r) [e,Lambda r [t] e']->         desugarStmt (StmtDecl ds) e' = Let ds e'-> desugarExpr m tcEnv p (IfThenElse r e1 e2 e3) =->   do->     e1' <- desugarExpr m tcEnv p e1->     e2' <- desugarExpr m tcEnv p e2->     e3' <- desugarExpr m tcEnv p e3->     return (Case r e1' [caseAlt p truePattern e2',caseAlt p falsePattern e3'])-> desugarExpr m tcEnv p (Case r e alts)->   | null alts = return prelFailed->   | otherwise =->       do->         e' <- desugarExpr m tcEnv p e->         v <- S.get >>= freshIdent m "_#case" . monoType . flip typeOf e->         alts' <- mapM (desugarAltLhs m tcEnv) alts->         tyEnv <- S.get->         alts'' <- mapM (desugarAltRhs m tcEnv)->                        (map (expandAlt tyEnv v) (init (tails alts')))->         return (mkCase m v e' alts'')->   where mkCase m v e alts->           | v `elem` qfv m alts = Let [varDecl p v e] (Case r (mkVar v) alts)->           | otherwise = Case r e alts-> desugarExpr m tcEnv p (RecordConstr fs)->   | null fs = internalError "desugarExpr: empty record construction"->   | otherwise =->       do let l = fieldLabel (head fs)->	       fs' = map field2Tuple fs->          tyEnv <- S.get->	   case (lookupValue l tyEnv) of->            [Label l' r _] -> desugarRecordConstr m tcEnv p r fs'->            _  -> internalError "desugarExpr: illegal record construction"-> desugarExpr m tcEnv p (RecordSelection e l) =->   do tyEnv <- S.get->      case (lookupValue l tyEnv) of->        [Label _ r _] -> desugarRecordSelection m tcEnv p r l e->        _ -> internalError "desugarExpr: illegal record selection"-> desugarExpr m tcEnv p (RecordUpdate fs rexpr)->   | null fs = internalError "desugarExpr: empty record update"->   | otherwise =->       do let l = fieldLabel (head fs)->	       fs' = map field2Tuple fs->          tyEnv <- S.get->	   case (lookupValue l tyEnv) of->            [Label _ r _] -> desugarRecordUpdate m tcEnv p r rexpr fs'->            _  -> internalError "desugarExpr: illegal record update"--desugarExpr _ _ _ x = internalError $ "desugarExpr: unexpected expression " ++ show x--\end{verbatim}-If an alternative in a case expression has boolean guards and all of-these guards return \texttt{False}, the enclosing case expression does-not fail but continues to match the remaining alternatives against the-selector expression. In order to implement this semantics, which is-compatible with Haskell, we expand an alternative with boolean guards-such that it evaluates a case expression with the remaining cases that-are compatible with the matched pattern when the guards fail.-\begin{verbatim}--> desugarAltLhs :: ModuleIdent -> TCEnv -> Alt -> DesugarState Alt-> desugarAltLhs m tcEnv (Alt p t rhs) =->   do->     (ds',t') <- desugarTerm m tcEnv p [] t->     return (Alt p t' (addDecls ds' rhs))--> desugarAltRhs :: ModuleIdent -> TCEnv -> Alt -> DesugarState Alt-> desugarAltRhs m tcEnv (Alt p t rhs) = ->   liftM (Alt p t) (desugarRhs m tcEnv p rhs)--> expandAlt :: ValueEnv -> Ident -> [Alt] -> Alt-> expandAlt tyEnv v (Alt p t rhs : alts) = caseAlt p t (expandRhs tyEnv e0 rhs)->   where e0 = Case (srcRefOf p) (mkVar v) ->                   (filter (isCompatible t . altPattern) alts)->         altPattern (Alt _ t _) = t--> isCompatible :: ConstrTerm -> ConstrTerm -> Bool-> isCompatible (VariablePattern _) _ = True-> isCompatible _ (VariablePattern _) = True-> isCompatible (AsPattern _ t1) t2 = isCompatible t1 t2-> isCompatible t1 (AsPattern _ t2) = isCompatible t1 t2-> isCompatible (ConstructorPattern c1 ts1) (ConstructorPattern c2 ts2) =->   and ((c1 == c2) : zipWith isCompatible ts1 ts2)-> isCompatible (LiteralPattern l1) (LiteralPattern l2) = canon l1 == canon l2->   where canon (Int _ i) = Int anonId i->         canon l = l--\end{verbatim}-The frontend provides several extensions of the Curry functionality, which-have to be desugared as well. This part transforms the following extensions:-\begin{itemize}-\item runction patterns-\item records-\end{itemize}-\begin{verbatim}--> desugarFunctionPatterns :: ModuleIdent -> Position -> [ConstrTerm] -> Rhs->	                     -> DesugarState ([ConstrTerm], Rhs)-> desugarFunctionPatterns m p ts rhs = ->   do (ts', its) <- elimFunctionPattern m p ts->      rhs' <- genFunctionPatternExpr m p its rhs->      return (ts', rhs')--> desugarRecordDecl :: ModuleIdent -> TCEnv -> Decl -> DesugarState [Decl]-> desugarRecordDecl m tcEnv (TypeDecl p r vs (RecordType fss _)) =->   case (qualLookupTC r' tcEnv) of->     [AliasType _ n (TypeRecord fs' _)] ->->       do tyEnv <- S.get->	   let tys = concatMap (\ (ls,ty) -> replicate (length ls) ty) fss->	       --tys' = map (elimRecordTypes tyEnv) tys->	       rdecl = DataDecl p r vs [ConstrDecl p [] r tys]->	       rty' = TypeConstructor r' (map TypeVariable [0 .. n-1])->              rcts' = ForAllExist 0 n (foldr TypeArrow rty' (map snd fs'))->	   rfuncs <- mapM (genRecordFuncs m tcEnv p r' rty' (map fst fs')) fs'->	   S.modify (bindGlobalInfo DataConstructor m r rcts')->          return (rdecl:(concat rfuncs))->     _ -> internalError "desugarRecordDecl: no record"->   where r' = qualifyWith m r-> desugarRecordDecl _ _ decl = return [decl]--> desugarRecordPattern :: ModuleIdent -> TCEnv -> Position -> [Decl]->		       -> [(Ident,ConstrTerm)] -> QualIdent->		       -> DesugarState ([Decl],ConstrTerm)-> desugarRecordPattern m tcEnv p ds fs r =->   case (qualLookupTC r tcEnv) of->     [AliasType _ _ (TypeRecord fs' _)] ->->       do let ts = map (\ (l,_) ->		         -> fromMaybe (VariablePattern anonId)->		                      (lookup l fs))->		        fs'->	   desugarTerm m tcEnv p ds (ConstructorPattern r ts)--> desugarRecordConstr :: ModuleIdent -> TCEnv -> Position -> QualIdent ->	              -> [(Ident,Expression)] -> DesugarState Expression-> desugarRecordConstr m tcEnv p r fs =->   case (qualLookupTC r tcEnv) of->     [AliasType _ _ (TypeRecord fs' _)] ->->       do let cts = map (\ (l,_) -> ->	                  fromMaybe (internalError "desugarRecordConstr")->		                    (lookup l fs)) fs'->	   desugarExpr m tcEnv p (foldl Apply (Constructor r) cts)->     _ -> internalError "desugarRecordConstr: wrong type"--> desugarRecordSelection :: ModuleIdent -> TCEnv -> Position -> QualIdent ->		         -> Ident -> Expression -> DesugarState Expression-> desugarRecordSelection m tcEnv p r l e =->   desugarExpr m tcEnv p (Apply (Variable (qualRecSelectorId m r l)) e)--> desugarRecordUpdate :: ModuleIdent -> TCEnv -> Position -> QualIdent->	              -> Expression -> [(Ident,Expression)] ->	              -> DesugarState Expression-> desugarRecordUpdate m tcEnv p r rexpr fs =->   desugarExpr m tcEnv p (foldl (genRecordUpdate m r) rexpr fs)->   where->   genRecordUpdate m r rexpr (l,e) =->     Apply (Apply (Variable (qualRecUpdateId m r l)) rexpr) e--> elimFunctionPattern :: ModuleIdent -> Position -> [ConstrTerm]->		         -> DesugarState ([ConstrTerm], [(Ident,ConstrTerm)])-> elimFunctionPattern m p [] = return ([],[])-> elimFunctionPattern m p (t:ts)->    | containsFunctionPattern t->      = do tyEnv <- S.get->	    ident <- freshIdent m "_#funpatt" (monoType (typeOf tyEnv t))->	    (ts',its') <- elimFunctionPattern m p ts->           return ((VariablePattern ident):ts', (ident,t):its')->    | otherwise->      = do (ts', its') <- elimFunctionPattern m p ts->	    return (t:ts', its')--> containsFunctionPattern :: ConstrTerm -> Bool-> containsFunctionPattern (ConstructorPattern _ ts)->    = any containsFunctionPattern ts-> containsFunctionPattern (InfixPattern t1 _ t2)->    = any containsFunctionPattern [t1,t2]-> containsFunctionPattern (ParenPattern t)->    = containsFunctionPattern t-> containsFunctionPattern (TuplePattern _ ts)->    = any containsFunctionPattern ts-> containsFunctionPattern (ListPattern _ ts)->    = any containsFunctionPattern ts-> containsFunctionPattern (AsPattern _ t)->    = containsFunctionPattern t-> containsFunctionPattern (LazyPattern _ t)->    = containsFunctionPattern t-> containsFunctionPattern (FunctionPattern _ _) = True-> containsFunctionPattern (InfixFuncPattern _ _ _) = True-> containsFunctionPattern _ = False--> genFunctionPatternExpr :: ModuleIdent -> Position -> [(Ident, ConstrTerm)]->		            -> Rhs -> DesugarState Rhs-> genFunctionPatternExpr m _ its rhs@(SimpleRhs p expr decls)->    | null its = return rhs->    | otherwise->      = let ies = map (\ (i,t) -> (i, constrTerm2Expr t)) its->	     fpexprs = map (\ (ident, expr) ->		            -> Apply (Apply prelFuncPattEqu expr) ->		                     (Variable (qualify ident)))->	                   ies->	     fpexpr =  foldl (\e1 e2 -> Apply (Apply prelConstrConj e1) e2)->	                     (head fpexprs) ->		             (tail fpexprs)->	     freevars = foldl getConstrTermVars [] (map snd its)->            rhsexpr = Let [ExtraVariables p freevars]->		           (Apply (Apply prelCond fpexpr) expr)->        in  return (SimpleRhs p rhsexpr decls)  -> genFunctionPatternExpr _ _ _ rhs->    = internalError "genFunctionPatternExpr: unexpected right-hand-side"--> constrTerm2Expr :: ConstrTerm -> Expression-> constrTerm2Expr (LiteralPattern lit)->    = Literal lit-> constrTerm2Expr (VariablePattern ident)->    = Variable (qualify ident)-> constrTerm2Expr (ConstructorPattern qident cts)->    = foldl (\e1 e2 -> Apply e1 e2) ->            (Constructor qident) ->            (map constrTerm2Expr cts)-> constrTerm2Expr (FunctionPattern qident cts)->    = foldl (\e1 e2 -> Apply e1 e2) ->            (Variable qident) ->            (map constrTerm2Expr cts)-> constrTerm2Expr _->    = internalError "constrTerm2Expr: unexpected constructor term"--> getConstrTermVars :: [Ident] -> ConstrTerm -> [Ident]-> getConstrTermVars ids (VariablePattern ident)->    | elem ident ids = ids->    | otherwise      = ident:ids-> getConstrTermVars ids (ConstructorPattern _ cts)->    = foldl getConstrTermVars ids cts-> getConstrTermVars ids (InfixPattern c1 qid c2)->    = getConstrTermVars ids (ConstructorPattern qid [c1,c2])-> getConstrTermVars ids (ParenPattern c)->    = getConstrTermVars ids c-> getConstrTermVars ids (TuplePattern _ cts)->    = foldl getConstrTermVars ids cts-> getConstrTermVars ids (ListPattern _ cts)->    = foldl getConstrTermVars ids cts-> getConstrTermVars ids (AsPattern _ c)->    = getConstrTermVars ids c-> getConstrTermVars ids (LazyPattern _ c)->    = getConstrTermVars ids c-> getConstrTermVars ids (FunctionPattern _ cts)->    = foldl getConstrTermVars ids cts-> getConstrTermVars ids (InfixFuncPattern c1 qid c2)->    = getConstrTermVars ids (FunctionPattern qid [c1,c2])-> getConstrTermVars ids _->    = ids--> genRecordFuncs :: ModuleIdent -> TCEnv -> Position -> QualIdent -> Type ->	         -> [Ident] -> (Ident, Type) -> DesugarState [Decl]-> genRecordFuncs m tcEnv p r rty ls (l,ty) =->   case (qualLookupTC r tcEnv) of->     [AliasType _ n (TypeRecord fs _)] ->->       do let (selId, selFunc) = genSelectorFunc m p r ls l->              (updId, updFunc) = genUpdateFunc m p r ls l->	       selType = polyType (TypeArrow rty ty)->	       updType = polyType (TypeArrow rty (TypeArrow ty rty))->	   S.modify (bindFun m selId selType . bindFun m updId updType)->	   return [selFunc,updFunc]->     _ -> internalError "genRecordFuncs: wrong type"--> genSelectorFunc :: ModuleIdent -> Position -> QualIdent -> [Ident] -> Ident->	          -> (Ident, Decl)-> genSelectorFunc m p r ls l =->   let selId = recSelectorId r l->       cpatt = ConstructorPattern r (map VariablePattern ls)->	selLhs = FunLhs selId [cpatt]->	selRhs = SimpleRhs p (Variable (qualify l)) []->   in  (selId, FunctionDecl p selId [Equation p selLhs selRhs])--> genUpdateFunc :: ModuleIdent -> Position -> QualIdent -> [Ident] -> Ident->	        -> (Ident, Decl)-> genUpdateFunc m p r ls l =->   let updId = recUpdateId r l->	ls' = replaceIdent l anonId ls->	cpatt1 = ConstructorPattern r (map VariablePattern ls')->       cpatt2 = VariablePattern l->	cexpr = foldl Apply ->	              (Constructor r)->	              (map (Variable . qualify) ls) ->	updLhs = FunLhs updId [cpatt1, cpatt2]->	updRhs = SimpleRhs p cexpr []->   in  (updId, FunctionDecl p updId [Equation p updLhs updRhs])--> replaceIdent :: Ident -> Ident -> [Ident] -> [Ident]-> replaceIdent _ _ [] = []-> replaceIdent what with (id:ids)->   | what == id = with:ids->   | otherwise  = id:(replaceIdent what with ids)--\end{verbatim}-In general, a list comprehension of the form-\texttt{[}$e$~\texttt{|}~$t$~\texttt{<-}~$l$\texttt{,}~\emph{qs}\texttt{]}-is transformed into an expression \texttt{foldr}~$f$~\texttt{[]}~$l$ where $f$-is a new function defined as-\begin{quote}-  \begin{tabbing}-    $f$ $x$ \emph{xs} \texttt{=} \\-    \quad \= \texttt{case} $x$ \texttt{of} \\-          \> \quad \= $t$ \texttt{->} \texttt{[}$e$ \texttt{|} \emph{qs}\texttt{]} \texttt{++} \emph{xs} \\-          \>       \> \texttt{\_} \texttt{->} \emph{xs}-  \end{tabbing}-\end{quote}-Note that this translation evaluates the elements of $l$ rigidly,-whereas the translation given in the Curry report is flexible.-However, it does not seem very useful to have the comprehension-generate instances of $t$ which do not contribute to the list.--Actually, we generate slightly better code in a few special cases.-When $t$ is a plain variable, the \texttt{case} expression degenerates-into a let-binding and the auxiliary function thus becomes an alias-for \texttt{(++)}. Instead of \texttt{foldr~(++)} we use the-equivalent prelude function \texttt{concatMap}. In addition, if the-remaining list comprehension in the body of the auxiliary function has-no qualifiers -- i.e., if it is equivalent to \texttt{[$e$]} -- we-avoid the construction of the singleton list by calling \texttt{(:)}-instead of \texttt{(++)} and \texttt{map} in place of-\texttt{concatMap}, respectively. -}-\begin{verbatim}--> desugarQual :: ModuleIdent -> TCEnv -> Position -> Statement -> Expression->      -> DesugarState Expression-> desugarQual m tcEnv p (StmtExpr pos b) e = ->   desugarExpr m tcEnv p (IfThenElse pos b e (List [pos] []))-> desugarQual m tcEnv p (StmtBind refBind t l) e->   | isVarPattern t = desugarExpr m tcEnv p (qualExpr t e l)->   | otherwise =->       do->         tyEnv <- S.get->         v0 <- freshIdent m "_#var" (monoType (typeOf tyEnv t))->         l0 <- freshIdent m "_#var" (monoType (typeOf tyEnv e))->         let v  = addRefId refBind v0->             l' = addRefId refBind l0->         desugarExpr m tcEnv p (apply (prelFoldr refBind) ->                                      [foldFunct v l' e,List [refBind] [],l])->   where ->     qualExpr v (ListCompr _ e []) l ->       = apply (prelMap refBind) [Lambda refBind [v] e,l]->     qualExpr v e l = apply (prelConcatMap refBind) [Lambda refBind [v] e,l]-->     foldFunct v l e =->           Lambda refBind (map VariablePattern [v,l])->             (Case refBind (mkVar v)->                   [caseAlt {-refBind-} p t (append e (mkVar l)),->                    caseAlt {-refBind-} p (VariablePattern v) (mkVar l)])->->     append (ListCompr _ e []) l = apply (Constructor $ addRef refBind $ qConsId) [e,l]->     append e l = apply (prelAppend refBind) [e,l]->-> desugarQual m tcEnv p (StmtDecl ds) e = desugarExpr m tcEnv p (Let ds e)--\end{verbatim}-Generation of fresh names-\begin{verbatim}--> freshIdent :: ModuleIdent -> String -> TypeScheme -> DesugarState Ident-> freshIdent m prefix ty =->   do->     x <- liftM (mkName prefix) (S.lift (S.modify succ >> S.get))->     S.modify (bindFun m x ty)->     return x->   where mkName pre n = mkIdent (pre ++ show n)--\end{verbatim}-Prelude entities-\begin{verbatim}--> prelBind = prel ">>="-> prelBind_ = prel ">>"-> prelFlip = Variable $ preludeIdent "flip"-> prelEnumFrom = Variable $ preludeIdent "enumFrom"-> prelEnumFromTo = Variable $ preludeIdent "enumFromTo"-> prelEnumFromThen = Variable $ preludeIdent "enumFromThen"-> prelEnumFromThenTo = Variable $ preludeIdent "enumFromThenTo"-> prelFailed = Variable $ preludeIdent "failed"-> prelMap r = Variable $ addRef r $ preludeIdent "map"-> prelFoldr = prel "foldr"-> prelAppend = prel "++"-> prelConcatMap = prel "concatMap"-> prelNegate = Variable $ preludeIdent "negate"-> prelNegateFloat = Variable $ preludeIdent "negateFloat"-> prelCond = Variable $ preludeIdent "cond"-> prelFuncPattEqu = Variable $ preludeIdent "=:<="-> prelConstrConj = Variable $ preludeIdent "&"--> prel s r = Variable (addRef r (preludeIdent s))--> truePattern = ConstructorPattern qTrueId []-> falsePattern = ConstructorPattern qFalseId []---> preludeIdent :: String -> QualIdent-> preludeIdent = qualifyWith preludeMIdent . mkIdent--\end{verbatim}-Auxiliary definitions-\begin{verbatim}--> isNewtypeConstr :: ValueEnv -> QualIdent -> Bool-> isNewtypeConstr tyEnv c =->   case qualLookupValue c tyEnv of->     [DataConstructor _ _] -> False->     [NewtypeConstructor _ _] -> True->     _ -> internalError ("isNewtypeConstr " ++ show c) --internalError "isNewtypeConstr"--> isVarPattern :: ConstrTerm -> Bool-> isVarPattern (VariablePattern _) = True-> isVarPattern (ParenPattern t) = isVarPattern t-> isVarPattern (AsPattern _ t) = isVarPattern t-> isVarPattern (LazyPattern _ _) = True-> isVarPattern _ = False--> funDecl :: Position -> Ident -> [ConstrTerm] -> Expression -> Decl-> funDecl p f ts e =->   FunctionDecl p f [Equation p (FunLhs f ts) (SimpleRhs p e [])]--> patDecl :: Position -> ConstrTerm -> Expression -> Decl-> patDecl p t e = PatternDecl p t (SimpleRhs p e [])--> varDecl :: Position -> Ident -> Expression -> Decl-> varDecl p = patDecl p . VariablePattern--> addDecls :: [Decl] -> Rhs -> Rhs-> addDecls ds (SimpleRhs p e ds') = SimpleRhs p e (ds ++ ds')-> addDecls ds (GuardedRhs es ds') = GuardedRhs es (ds ++ ds')--> caseAlt :: Position -> ConstrTerm -> Expression -> Alt-> caseAlt p t e = Alt p t (SimpleRhs p e [])--> apply :: Expression -> [Expression] -> Expression-> apply = foldl Apply--> mkVar :: Ident -> Expression-> mkVar = Variable . qualify---\end{verbatim}
+ src/Env/Class.hs view
@@ -0,0 +1,75 @@+{- |+    Module      :  $Header$+    Description :  Environment of classes+    Copyright   :  (c) 2016 - 2020 Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  fte@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    The compiler maintains information about all type classes in an+    environment that maps type classes to a sorted list of their direct+    superclasses and all their associated class methods with an additional+    flag stating whether an default implementation has been provided or not.+    For both the type class identifier and the list of super classes original+    names are used. Thus, the use of a flat environment is sufficient.+-}++module Env.Class+  ( ClassEnv, initClassEnv+  , ClassInfo, bindClassInfo, mergeClassInfo, lookupClassInfo+  , superClasses, allSuperClasses, classMethods, hasDefaultImpl+  ) where++import           Data.List       (nub, sort)+import qualified Data.Map as Map (Map, empty, insertWith, lookup)++import Curry.Base.Ident++import Base.Messages (internalError)++type ClassInfo = ([QualIdent], [(Ident, Bool)])++type ClassEnv = Map.Map QualIdent ClassInfo++initClassEnv :: ClassEnv+initClassEnv = Map.empty++bindClassInfo :: QualIdent -> ClassInfo -> ClassEnv -> ClassEnv+bindClassInfo cls (sclss, ms) =+  Map.insertWith mergeClassInfo cls (sort sclss, ms)++-- We have to be careful when merging two class infos into one as hidden class+-- declarations in interfaces provide no information about class methods. If+-- one of the method lists is empty, we simply take the other one. This way,+-- we do overwrite the list of class methods that may have been entered into+-- the class environment before with an empty list.++mergeClassInfo :: ClassInfo -> ClassInfo -> ClassInfo+mergeClassInfo (sclss1, ms1) (_, ms2) = (sclss1, if null ms1 then ms2 else ms1)++lookupClassInfo :: QualIdent -> ClassEnv -> Maybe ClassInfo+lookupClassInfo = Map.lookup++superClasses :: QualIdent -> ClassEnv -> [QualIdent]+superClasses cls clsEnv = case lookupClassInfo cls clsEnv of+  Just (sclss, _) -> sclss+  _ -> internalError $ "Env.Classes.superClasses: " ++ show cls++allSuperClasses :: QualIdent -> ClassEnv -> [QualIdent]+allSuperClasses cls clsEnv = nub $ classes cls+  where+    classes cls' = cls' : concatMap classes (superClasses cls' clsEnv)++classMethods :: QualIdent -> ClassEnv -> [Ident]+classMethods cls clsEnv = case lookupClassInfo cls clsEnv of+  Just (_, ms) -> map fst ms+  _ -> internalError $ "Env.Classes.classMethods: " ++ show cls++hasDefaultImpl :: QualIdent -> Ident -> ClassEnv -> Bool+hasDefaultImpl cls f clsEnv = case lookupClassInfo cls clsEnv of+  Just (_, ms) -> case lookup f ms of+    Just dflt -> dflt+    Nothing -> internalError $ "Env.Classes.hasDefaultImpl: " ++ show f+  _ -> internalError $ "Env.Classes.hasDefaultImpl: " ++ show cls
+ src/Env/Instance.hs view
@@ -0,0 +1,54 @@+{- |+    Module      :  $Header$+    Description :  Environment of instances+    Copyright   :  (c) 2016 - 2020 Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  fte@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    The compiler maintains information about defined instances in an+    environment that maps pairs of type classes and type constructors+    to the name of the module where the instance is declared, the context+    as given in the instance declaration, and a list of the class methods+    implemented in the specific instance along with their arity. A flat+    environment is sufficient because instances are visible globally and+    cannot be hidden. Instances are recorded only with the original names+    of the type class and type constructor involved. The context also uses+    original names and is already minimized.+-}++module Env.Instance+  ( InstIdent, ppInstIdent, InstInfo+  , InstEnv, initInstEnv, bindInstInfo, removeInstInfo, lookupInstInfo+  ) where++import qualified Data.Map as Map (Map, empty, insert, delete, lookup)++import Curry.Base.Ident+import Curry.Base.Pretty+import Curry.Syntax.Pretty++import Base.Types++type InstIdent = (QualIdent, QualIdent)++ppInstIdent :: InstIdent -> Doc+ppInstIdent (qcls, qtc) = ppQIdent qcls <+> ppQIdent qtc++type InstInfo = (ModuleIdent, PredSet, [(Ident, Int)])++type InstEnv = Map.Map InstIdent InstInfo++initInstEnv :: InstEnv+initInstEnv = Map.empty++bindInstInfo :: InstIdent -> InstInfo -> InstEnv -> InstEnv+bindInstInfo = Map.insert++removeInstInfo  :: InstIdent -> InstEnv -> InstEnv+removeInstInfo = Map.delete++lookupInstInfo :: InstIdent -> InstEnv -> Maybe InstInfo+lookupInstInfo = Map.lookup
+ src/Env/Interface.hs view
@@ -0,0 +1,31 @@+{- |+    Module      :  $Header$+    Description :  Environment of imported interfaces+    Copyright   :  (c) 2002 - 2004 Wolfgang Lux+                       2011 - 2013 Björn Peemöller+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module provides an environment for imported interfaces.+-}+module Env.Interface where++import qualified Data.Map as Map (Map, empty, lookup)++import Curry.Base.Ident (ModuleIdent)+import Curry.Syntax     (Interface)++-- |Environment which maps the 'ModuleIdent' of an imported module+-- to the corresponding 'Interface'.+type InterfaceEnv = Map.Map ModuleIdent Interface++-- |Initial 'InterfaceEnv'.+initInterfaceEnv :: InterfaceEnv+initInterfaceEnv = Map.empty++-- |Lookup the 'Interface' for an imported module.+lookupInterface :: ModuleIdent -> InterfaceEnv -> Maybe Interface+lookupInterface = Map.lookup
+ src/Env/ModuleAlias.hs view
@@ -0,0 +1,41 @@+{- |+    Module      :  $Header$+    Description :  Environment of module aliases+    Copyright   :  (c) 2002 - 2004, Wolfgang Lux+                       2011 - 2013, Björn Peemöller+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module provides an environment for resolving module aliases.++    For example, if module @FiniteMap@ is imported via++    @import FiniteMap as FM@++    then @FM@ is an alias for @FiniteMap@, and @FiniteMap@ is aliased by @FM@.+-}+module Env.ModuleAlias ( AliasEnv, initAliasEnv, importAliases ) where++import qualified Data.Map   as Map (Map, empty, insert)+import           Data.Maybe        (fromMaybe)++import Curry.Base.Ident (ModuleIdent)+import Curry.Syntax     (ImportDecl (..))++-- |Mapping from the original name of an imported module to its alias.+type AliasEnv = Map.Map ModuleIdent ModuleIdent++-- |Initial alias environment+initAliasEnv :: AliasEnv+initAliasEnv = Map.empty++-- |Create an alias environment from a list of import declarations+importAliases :: [ImportDecl] -> AliasEnv+importAliases = foldr bindAlias initAliasEnv++-- |Bind an alias for a module from a single import declaration+bindAlias :: ImportDecl -> AliasEnv -> AliasEnv+bindAlias (ImportDecl _ mid _ alias _) = Map.insert mid $ fromMaybe mid alias
+ src/Env/OpPrec.hs view
@@ -0,0 +1,111 @@+{- |+    Module      :  $Header$+    Description :  Environment of operator precedences+    Copyright   :  (c) 2002 - 2004, Wolfgang Lux+                       2011 - 2013, Björn Peemöller+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    In order to parse infix expressions correctly, the compiler must know+    the precedence and fixity of each operator. Operator precedences are+    associated with entities and will be checked after renaming was+    applied. Nevertheless, we need to save precedences for ambiguous names+    in order to handle them correctly while computing the exported+    interface of a module.++    If no fixity is assigned to an operator, it will be given the default+    precedence 9 and assumed to be a left-associative operator.++    /Note:/ this modified version uses Haskell type 'Integer'+    for representing the precedence. This change had to be done due to the+    introduction of unlimited integer constants in the parser / lexer.+-}+module Env.OpPrec+  ( OpPrec (..), defaultP, defaultAssoc, defaultPrecedence, mkPrec+  , OpPrecEnv,  PrecInfo (..), bindP, lookupP, qualLookupP, initOpPrecEnv+  ) where++import Curry.Base.Ident+import Curry.Base.Pretty (Pretty(..))+import Curry.Syntax      (Infix (..))++import Base.TopEnv++import Data.Maybe        (fromMaybe)++import Text.PrettyPrint++-- |Operator precedence.+data OpPrec = OpPrec Infix Precedence deriving Eq++type Precedence = Integer++-- TODO: Change to real show instance and provide Pretty instance+-- if used anywhere.+instance Show OpPrec where+  showsPrec _ (OpPrec fix p) = showString (assoc fix) . shows p+    where+    assoc InfixL = "left "+    assoc InfixR = "right "+    assoc Infix  = "non-assoc "++instance Pretty OpPrec where+  pPrint (OpPrec fix p) = pPrint fix <+> integer p++-- |Default operator declaration (associativity and precedence).+defaultP :: OpPrec+defaultP = OpPrec defaultAssoc defaultPrecedence++-- |Default operator associativity.+defaultAssoc :: Infix+defaultAssoc = InfixL++-- |Default operator precedence.+defaultPrecedence :: Precedence+defaultPrecedence = 9++mkPrec :: Maybe Precedence -> Precedence+mkPrec mprec = fromMaybe defaultPrecedence mprec++-- |Precedence information for an identifier.+data PrecInfo = PrecInfo QualIdent OpPrec deriving (Eq, Show)++instance Entity PrecInfo where+  origName (PrecInfo op _) = op++instance Pretty PrecInfo where+  pPrint (PrecInfo qid prec) = pPrint qid <+> pPrint prec++-- |Environment mapping identifiers to their operator precedence.+type OpPrecEnv = TopEnv PrecInfo++-- |Initial 'OpPrecEnv'.+initOpPrecEnv :: OpPrecEnv+initOpPrecEnv = predefTopEnv qConsId consPrec emptyTopEnv++-- |Precedence of list constructor.+consPrec :: PrecInfo+consPrec = PrecInfo qConsId (OpPrec InfixR 5)++-- |Bind an operator precedence.+bindP :: ModuleIdent -> Ident -> OpPrec -> OpPrecEnv -> OpPrecEnv+bindP m op p+  | hasGlobalScope op = bindTopEnv op info . qualBindTopEnv qop info+  | otherwise         = bindTopEnv op info+  where qop  = qualifyWith m op+        info = PrecInfo qop p++-- The lookup functions for the environment which maintains the operator+-- precedences are simpler than for the type and value environments+-- because they do not need to handle tuple constructors.++-- |Lookup the operator precedence for an 'Ident'.+lookupP :: Ident -> OpPrecEnv -> [PrecInfo]+lookupP = lookupTopEnv++-- |Lookup the operator precedence for an 'QualIdent'.+qualLookupP :: QualIdent -> OpPrecEnv -> [PrecInfo]+qualLookupP = qualLookupTopEnv
+ src/Env/Type.hs view
@@ -0,0 +1,70 @@+{- |+    Module      :  $Header$+    Description :  Environment of type identifiers+    Copyright   :  (c) 2016        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    At the type level, we distinguish data and renaming types, synonym+    types, and type classes. Type variables are not recorded. Type+    synonyms use a kind of their own so that the compiler can verify that+    no type synonyms are used in type expressions in interface files.+-}++module Env.Type+  ( TypeKind (..), toTypeKind,+    TypeEnv, bindTypeKind, lookupTypeKind, qualLookupTypeKind+  ) where++import Curry.Base.Ident++import Base.Messages (internalError)+import Base.TopEnv+import Base.Types (constrIdent, methodName)++import Env.TypeConstructor (TypeInfo (..))++import Data.List (union)++data TypeKind+  = Data  QualIdent [Ident]+  | Alias QualIdent+  | Class QualIdent [Ident]+  deriving (Eq, Show)++instance Entity TypeKind where+  origName (Data  tc  _) = tc+  origName (Alias tc   ) = tc+  origName (Class cls _) = cls++  merge (Data tc cs) (Data tc' cs')+    | tc == tc' = Just $ Data tc $ cs `union` cs'+  merge (Alias tc) (Alias tc')+    | tc == tc' = Just $ Alias tc+  merge (Class cls ms) (Class cls' ms')+    | cls == cls' = Just $Class cls $ ms `union` ms'+  merge _ _ = Nothing++toTypeKind :: TypeInfo -> TypeKind+toTypeKind (DataType     tc    _ cs) = Data tc (map constrIdent cs)+toTypeKind (RenamingType tc    _ nc) = Data tc [constrIdent nc]+toTypeKind (AliasType    tc  _ _  _) = Alias tc+toTypeKind (TypeClass    cls   _ ms) = Class cls (map methodName ms)+toTypeKind (TypeVar               _) =+  internalError "Env.Type.toTypeKind: type variable"++type TypeEnv = TopEnv TypeKind++bindTypeKind :: ModuleIdent -> Ident -> TypeKind -> TypeEnv -> TypeEnv+bindTypeKind m ident tk = bindTopEnv ident tk . qualBindTopEnv qident tk+  where+    qident = qualifyWith m ident++lookupTypeKind :: Ident -> TypeEnv -> [TypeKind]+lookupTypeKind = lookupTopEnv++qualLookupTypeKind :: QualIdent -> TypeEnv -> [TypeKind]+qualLookupTypeKind = qualLookupTopEnv
+ src/Env/TypeConstructor.hs view
@@ -0,0 +1,221 @@+{- |+    Module      :  $Header$+    Description :  Environment of type constructors+    Copyright   :  (c) 2002 - 2004 Wolfgang Lux+                       2011        Björn Peemöller+                       2016        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    For all defined types the compiler must maintain kind information.+    For algebraic data types and renaming types the compiler also records+    all data constructors belonging to that type, for alias types the+    type expression to be expanded is saved. Futhermore, recording the+    arity is necessary for alias types because the right hand side, i.e.,+    the type expression, can have arbitrary kind and therefore the type+    alias' arity cannot be determined from its own kind. For instance,+    the type alias type List = [] has the kind * -> *, but its arity is 0.+    In order to manage the import and export of types, the names of the+    original definitions are also recorded. On import two types are+    considered equal if their original names match.++    The information for a data constructor comprises the number of+    existentially quantified type variables, the context and the list+    of the argument types. Note that renaming type constructors have only+    one type argument.++    For type classes the all their methods are saved. Type classes are+    recorded in the type constructor environment because type constructors+    and type classes share a common name space.++    For type variables only their kind is recorded in the environment.++    Importing and exporting algebraic data types and renaming types is+    complicated by the fact that the constructors of the type may be+    (partially) hidden in the interface. This facilitates the definition+    of abstract data types. An abstract type is always represented as a+    data type without constructors in the interface regardless of whether+    it is defined as a data type or as a renaming type. When only some+    constructors of a data type are hidden, those constructors are+    replaced by underscores in the interface. Furthermore, if the+    right-most constructors of a data type are hidden, they are not+    exported at all in order to make the interface more stable against+    changes which are private to the module.+-}+{-# LANGUAGE CPP #-}+module Env.TypeConstructor+  ( TypeInfo (..), tcKind, clsKind, varKind, clsMethods+  , TCEnv, initTCEnv, bindTypeInfo, rebindTypeInfo+  , lookupTypeInfo, qualLookupTypeInfo, qualLookupTypeInfoUnique+  , getOrigName, reverseLookupByOrigName+  ) where++#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif++import Curry.Base.Ident+import Curry.Base.Pretty (Pretty(..), blankLine)++import Base.Kinds+import Base.Messages (internalError)+import Base.PrettyKinds ()+import Base.PrettyTypes ()+import Base.TopEnv+import Base.Types+import Base.Utils         ((++!))++import Text.PrettyPrint++data TypeInfo+  = DataType     QualIdent Kind [DataConstr]+  | RenamingType QualIdent Kind DataConstr+  | AliasType    QualIdent Kind Int Type+  | TypeClass    QualIdent Kind [ClassMethod]+  | TypeVar      Kind+    deriving Show++instance Entity TypeInfo where+  origName (DataType     tc    _ _) = tc+  origName (RenamingType tc    _ _) = tc+  origName (AliasType    tc  _ _ _) = tc+  origName (TypeClass    cls   _ _) = cls+  origName (TypeVar              _) =+    internalError "Env.TypeConstructor.origName: type variable"++  merge (DataType tc k cs) (DataType tc' k' cs')+    | tc == tc' && k == k' && (null cs || null cs' || cs == cs') =+    Just $ DataType tc k $ if null cs then cs' else cs+  merge (DataType tc k _) (RenamingType tc' k' nc)+    | tc == tc' && k == k' = Just (RenamingType tc k nc)+  merge l@(RenamingType tc k _) (DataType tc' k' _)+    | tc == tc' && k == k' = Just l+  merge l@(RenamingType tc k _) (RenamingType tc' k' _)+    | tc == tc' && k == k' = Just l+  merge l@(AliasType tc k _ _) (AliasType tc' k' _ _)+    | tc == tc' && k == k' = Just l+  merge (TypeClass cls k ms) (TypeClass cls' k' ms')+    | cls == cls' && k == k' && (null ms || null ms' || ms == ms') =+    Just $ TypeClass cls k $ if null ms then ms' else ms+  merge _ _ = Nothing++instance Pretty TypeInfo where+  pPrint (DataType qid k cs)    =      text "data" <+> pPrint qid+                                   <>  text "/" <> pPrint k+                                   <+> equals+                                   <+> hsep (punctuate (text "|") (map pPrint cs))+  pPrint (RenamingType qid k c) =      text "newtype" <+> pPrint qid+                                   <>  text "/" <> pPrint k+                                   <+> equals <+> pPrint c+  pPrint (AliasType qid k ar ty)=      text "type" <+> pPrint qid+                                   <>  text "/" <> pPrint k <> text "/" <> int ar+                                   <+> equals <+> pPrint ty+  pPrint (TypeClass qid k ms)   =      text "class" <+> pPrint qid+                                   <>  text "/" <> pPrint k+                                   <+> equals+                                   <+> vcat (blankLine : map pPrint ms)+  pPrint (TypeVar _)            =+    internalError $ "Env.TypeConstructor.Pretty.TypeInfo.pPrint: type variable"++tcKind :: ModuleIdent -> QualIdent -> TCEnv -> Kind+tcKind m tc tcEnv = case qualLookupTypeInfo tc tcEnv of+  [DataType     _ k   _] -> k+  [RenamingType _ k   _] -> k+  [AliasType    _ k _ _] -> k+  _ -> case qualLookupTypeInfo (qualQualify m tc) tcEnv of+    [DataType     _ k   _] -> k+    [RenamingType _ k   _] -> k+    [AliasType    _ k _ _] -> k+    _ -> internalError $+           "Env.TypeConstructor.tcKind: no type constructor: " ++ show tc++clsKind :: ModuleIdent -> QualIdent -> TCEnv -> Kind+clsKind m cls tcEnv = case qualLookupTypeInfo cls tcEnv of+  [TypeClass _ k _] -> k+  _ -> case qualLookupTypeInfo (qualQualify m cls) tcEnv of+    [TypeClass _ k _] -> k+    _ -> internalError $+           "Env.TypeConstructor.clsKind: no type class: " ++ show cls++varKind :: Ident -> TCEnv -> Kind+varKind tv tcEnv+  | isAnonId tv = KindStar+  | otherwise = case lookupTypeInfo tv tcEnv of+    [TypeVar k] -> k+    _ -> internalError "Env.TypeConstructor.varKind: no type variable"++clsMethods :: ModuleIdent -> QualIdent -> TCEnv -> [Ident]+clsMethods m cls tcEnv = case qualLookupTypeInfo cls tcEnv of+  [TypeClass _ _ ms] -> map methodName ms+  _ -> case qualLookupTypeInfo (qualQualify m cls) tcEnv of+    [TypeClass _ _ ms] -> map methodName ms+    _ -> internalError $ "Env.TypeConstructor.clsMethods: " ++ show cls++-- Types can only be defined on the top-level; no nested environments are+-- needed for them. Tuple types must be handled as a special case because+-- there is an infinite number of potential tuple types making it+-- impossible to insert them into the environment in advance.++type TCEnv = TopEnv TypeInfo++initTCEnv :: TCEnv+initTCEnv = foldr (uncurry $ predefTC . unapplyType False) emptyTopEnv predefTypes+  where+    predefTC (TypeConstructor tc, tys) =+      predefTopEnv tc . DataType tc (simpleKind $ length tys)+    predefTC _                        =+      internalError "Env.TypeConstructor.initTCEnv.predefTC: no type constructor"++bindTypeInfo :: ModuleIdent -> Ident -> TypeInfo -> TCEnv -> TCEnv+bindTypeInfo m ident ti = bindTopEnv ident ti . qualBindTopEnv qident ti+  where+    qident = qualifyWith m ident++rebindTypeInfo :: ModuleIdent -> Ident -> TypeInfo -> TCEnv -> TCEnv+rebindTypeInfo m ident ti = rebindTopEnv ident ti . qualRebindTopEnv qident ti+  where+    qident = qualifyWith m ident++lookupTypeInfo :: Ident -> TCEnv -> [TypeInfo]+lookupTypeInfo ident tcEnv = lookupTopEnv ident tcEnv ++! lookupTupleTC ident++qualLookupTypeInfo :: QualIdent -> TCEnv -> [TypeInfo]+qualLookupTypeInfo ident tcEnv =+  qualLookupTopEnv ident tcEnv ++! lookupTupleTC (unqualify ident)++qualLookupTypeInfoUnique :: ModuleIdent -> QualIdent -> TCEnv -> [TypeInfo]+qualLookupTypeInfoUnique m qident tcEnv =+  case qualLookupTypeInfo qident tcEnv of+    []   -> []+    [ti] -> [ti]+    tis  -> case qualLookupTypeInfo (qualQualify m qident) tcEnv of+      []  -> tis+      [ti] -> [ti]+      tis' -> tis'++getOrigName :: ModuleIdent -> QualIdent -> TCEnv -> QualIdent+getOrigName m tc tcEnv = case qualLookupTypeInfo tc tcEnv of+  [y] -> origName y+  _ -> case qualLookupTypeInfo (qualQualify m tc) tcEnv of+    [y] -> origName y+    _ -> internalError $ "Env.TypeConstructor.getOrigName: " ++ show tc++reverseLookupByOrigName :: QualIdent -> TCEnv -> [QualIdent]+reverseLookupByOrigName on+  | isQTupleId on = const [on]+  | otherwise     = map fst . filter ((== on) . origName . snd) . allBindings++lookupTupleTC :: Ident -> [TypeInfo]+lookupTupleTC tc | isTupleId tc = [tupleTCs !! (tupleArity tc - 2)]+                 | otherwise    = []++tupleTCs :: [TypeInfo]+tupleTCs = map typeInfo tupleData+  where+    typeInfo dc@(DataConstr _ tys) =+      let n = length tys in DataType (qTupleId n) (simpleKind n) [dc]+    typeInfo (RecordConstr  _ _ _) =+      internalError "Env.TypeConstructor.tupleTCs: record constructor"
+ src/Env/Value.hs view
@@ -0,0 +1,207 @@+{- |+    Module      :  $Header$+    Description :  Environment for functions, constructors and labels+    Copyright   :  (c) 2001 - 2004 Wolfgang Lux+                       2011        Björn Peemöller+                       2015        Jan Tikovsky+                       2016        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    In order to test the type correctness of a module, the compiler needs+    to determine the type of every data constructor, function and+    variable in the module.+    For the purpose of type checking there is no+    need for distinguishing between variables and functions. For all objects+    their original names and their types are saved. In addition, the compiler+    also saves the (optional) list of field labels for data and newtype+    constructors. Data constructors and functions also contain arity+    information. On import two values are considered equal if their original+    names match.+-}+{-# LANGUAGE CPP #-}+module Env.Value+  ( ValueEnv, ValueInfo (..)+  , bindGlobalInfo, bindFun, qualBindFun, rebindFun, unbindFun+  , lookupValue, qualLookupValue, qualLookupValueUnique+  , initDCEnv+  , ValueType (..), bindLocalVars, bindLocalVar+  ) where++#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif++import Curry.Base.Ident+import Curry.Base.Pretty (Pretty(..))++import Base.Messages (internalError)+import Base.PrettyTypes ()+import Base.TopEnv+import Base.Types+import Base.Utils ((++!))++import Text.PrettyPrint++data ValueInfo+  -- |Data constructor with original name, arity, list of record labels and type+  = DataConstructor    QualIdent                   Int [Ident] TypeScheme+  -- |Newtype constructor with original name, record label and type+  -- (arity is always 1)+  | NewtypeConstructor QualIdent                       Ident   TypeScheme+  -- |Value with original name, class method name, arity and type+  | Value              QualIdent (Maybe QualIdent) Int         TypeScheme+  -- |Record label with original name, list of constructors for which label+  -- is a valid field and type (arity is always 1)+  | Label              QualIdent [QualIdent]                   TypeScheme+    deriving Show++instance Entity ValueInfo where+  origName (DataConstructor    orgName _ _ _) = orgName+  origName (NewtypeConstructor orgName   _ _) = orgName+  origName (Value              orgName _ _ _) = orgName+  origName (Label              orgName   _ _) = orgName++  merge (DataConstructor c1 ar1 ls1 ty1) (DataConstructor c2 ar2 ls2 ty2)+    | c1 == c2 && ar1 == ar2 && ty1 == ty2 = do+      ls' <- sequence (zipWith mergeLabel ls1 ls2)+      Just (DataConstructor c1 ar1 ls' ty1)+  merge (NewtypeConstructor c1 l1 ty1) (NewtypeConstructor c2 l2 ty2)+    | c1 == c2 && ty1 == ty2 = do+      l' <- mergeLabel l1 l2+      Just (NewtypeConstructor c1 l' ty1)+  merge (Value x1 ar1 cm1 ty1) (Value x2 ar2 cm2 ty2)+    | x1 == x2 && ar1 == ar2 && cm1 == cm2 && ty1 == ty2 =+      Just (Value x1 ar1 cm1 ty1)+  merge (Label l1 cs1 ty1) (Label l2 cs2 ty2)+    | l1 == l2 && cs1 == cs2 && ty1 == ty2 = Just (Label l1 cs1 ty1)+  merge _ _ = Nothing++instance Pretty ValueInfo where+  pPrint (DataConstructor qid ar _ tySc) =     text "data" <+> pPrint qid+                                           <>  text "/" <> int ar+                                           <+> equals <+> pPrint tySc+  pPrint (NewtypeConstructor qid _ tySc) =     text "newtype" <+> pPrint qid+                                           <+> equals <+> pPrint tySc+  pPrint (Value qid _ ar tySc)           =     pPrint qid+                                           <>  text "/" <> int ar+                                           <+> equals <+> pPrint tySc+  pPrint (Label qid _ tySc)              =     text "label" <+> pPrint qid+                                           <+> equals <+> pPrint tySc++mergeLabel :: Ident -> Ident -> Maybe Ident+mergeLabel l1 l2+  | l1 == anonId = Just l2+  | l2 == anonId = Just l1+  | l1 == l2     = Just l1+  | otherwise    = Nothing++-- Even though value declarations may be nested, the compiler uses only+-- flat environments for saving type information. This is possible+-- because all identifiers are renamed by the compiler. Here we need+-- special cases for handling tuple constructors.+--+-- Note: the function 'qualLookupValue' has been extended to+-- allow the usage of the qualified list constructor (Prelude.:).++type ValueEnv = TopEnv ValueInfo++bindGlobalInfo :: (QualIdent -> a -> ValueInfo) -> ModuleIdent -> Ident -> a+               -> ValueEnv -> ValueEnv+bindGlobalInfo f m c ty = bindTopEnv c v . qualBindTopEnv qc v+  where qc = qualifyWith m c+        v  = f qc ty++bindFun :: ModuleIdent -> Ident -> Maybe QualIdent -> Int -> TypeScheme+        -> ValueEnv -> ValueEnv+bindFun m f cm a ty+  | hasGlobalScope f = bindTopEnv f v . qualBindTopEnv qf v+  | otherwise        = bindTopEnv f v+  where qf = qualifyWith m f+        v  = Value qf cm a ty++qualBindFun :: ModuleIdent -> Ident -> Maybe QualIdent -> Int -> TypeScheme+            -> ValueEnv -> ValueEnv+qualBindFun m f cm a ty = qualBindTopEnv qf $ Value qf cm a ty+  where qf = qualifyWith m f++rebindFun :: ModuleIdent -> Ident -> Maybe QualIdent -> Int -> TypeScheme+          -> ValueEnv -> ValueEnv+rebindFun m f cm a ty+  | hasGlobalScope f = rebindTopEnv f v . qualRebindTopEnv qf v+  | otherwise        = rebindTopEnv f v+  where qf = qualifyWith m f+        v  = Value qf cm a ty++unbindFun :: Ident -> ValueEnv -> ValueEnv+unbindFun = unbindTopEnv++lookupValue :: Ident -> ValueEnv -> [ValueInfo]+lookupValue x tyEnv = lookupTopEnv x tyEnv ++! lookupTuple x++qualLookupValue :: QualIdent -> ValueEnv -> [ValueInfo]+qualLookupValue x tyEnv = qualLookupTopEnv x tyEnv+                      ++! lookupTuple (unqualify x)++qualLookupValueUnique :: ModuleIdent -> QualIdent -> ValueEnv -> [ValueInfo]+qualLookupValueUnique m x tyEnv = case qualLookupValue x tyEnv of+  []  -> []+  [v] -> [v]+  vs  -> case qualLookupValue (qualQualify m x) tyEnv of+    []  -> vs+    [v] -> [v]+    qvs -> qvs++lookupTuple :: Ident -> [ValueInfo]+lookupTuple c | isTupleId c = [tupleDCs !! (tupleArity c - 2)]+              | otherwise   = []++tupleDCs :: [ValueInfo]+tupleDCs = map dataInfo tupleData+  where dataInfo (DataConstr _ tys) =+          let n = length tys+          in  DataConstructor (qTupleId n) n (replicate n anonId) $+                ForAll n $ predType $ foldr TypeArrow (tupleType tys) tys+        dataInfo (RecordConstr _ _ _) =+          internalError $ "Env.Value.tupleDCs: " ++ show tupleDCs++-- Since all predefined types are free of existentially quantified type+-- variables and have an empty predicate set, we can ignore both of them+-- when entering the types into the value environment.++initDCEnv :: ValueEnv+initDCEnv = foldr predefDC emptyTopEnv+  [ (c, length tys, constrType (polyType ty) tys)+  | (ty, cs) <- predefTypes, DataConstr c tys <- cs ]+  where predefDC (c, a, ty) = predefTopEnv c' (DataConstructor c' a ls ty)+          where ls = replicate a anonId+                c' = qualify c+        constrType (ForAll n (PredType ps ty)) =+          ForAll n . PredType ps . foldr TypeArrow ty++-- The functions 'bindLocalVar' and 'bindLocalVars' add the type of one or+-- many local variables or functions to the value environment. In contrast+-- to global functions, we do not care about the name of the module containing+-- the variable or function's definition.++class ValueType t where+  toValueType :: Type -> t+  fromValueType :: t -> PredType++instance ValueType Type where+  toValueType = id+  fromValueType = predType++instance ValueType PredType where+  toValueType = predType+  fromValueType = id++bindLocalVars :: ValueType t => [(Ident, Int, t)] -> ValueEnv -> ValueEnv+bindLocalVars = flip $ foldr bindLocalVar++bindLocalVar :: ValueType t => (Ident, Int, t) -> ValueEnv -> ValueEnv+bindLocalVar (v, a, ty) =+  bindTopEnv v $ Value (qualify v) Nothing a $ typeScheme $ fromValueType ty
− src/Eval.lhs 
@@ -1,96 +0,0 @@--% $Id: Eval.lhs,v 1.12 2004/02/08 15:35:12 wlux Exp $-%-% Copyright (c) 2001-2004, Wolfgang Lux-% See LICENSE for the full license.-%-\nwfilename{Eval.lhs}-\section{Collecting Evaluation Annotations}-The module \texttt{Eval} computes the evaluation annotation-environment. There is no need to check the annotations because this-happens already while checking the definitions of the module.-\begin{verbatim}--> module Eval(evalEnv) where--> import qualified Data.Map as Map--> import Curry.Syntax-> import Base---\end{verbatim}-The function \texttt{evalEnv} collects all evaluation annotations of-the module by traversing the syntax tree.-\begin{verbatim}--> evalEnv :: [Decl] -> EvalEnv-> evalEnv = foldr collectAnnotsDecl Map.empty--> collectAnnotsDecl :: Decl -> EvalEnv -> EvalEnv-> collectAnnotsDecl (EvalAnnot _ fs ev) env = foldr (flip Map.insert ev) env fs-> collectAnnotsDecl (FunctionDecl _ _ eqs) env = foldr collectAnnotsEqn env eqs-> collectAnnotsDecl (PatternDecl _ _ rhs) env = collectAnnotsRhs rhs env-> collectAnnotsDecl _ env = env--> collectAnnotsEqn :: Equation -> EvalEnv -> EvalEnv-> collectAnnotsEqn (Equation _ _ rhs) env = collectAnnotsRhs rhs env--> collectAnnotsRhs :: Rhs -> EvalEnv -> EvalEnv-> collectAnnotsRhs (SimpleRhs _ e ds) env =->   collectAnnotsExpr e (foldr collectAnnotsDecl env ds)-> collectAnnotsRhs (GuardedRhs es ds) env =->   foldr collectAnnotsCondExpr (foldr collectAnnotsDecl env ds) es--> collectAnnotsCondExpr :: CondExpr -> EvalEnv -> EvalEnv-> collectAnnotsCondExpr (CondExpr _ g e) env =->   collectAnnotsExpr g (collectAnnotsExpr e env)--> collectAnnotsExpr :: Expression -> EvalEnv -> EvalEnv-> collectAnnotsExpr (Literal _) env = env-> collectAnnotsExpr (Variable _) env = env-> collectAnnotsExpr (Constructor _) env = env-> collectAnnotsExpr (Paren e) env = collectAnnotsExpr e env-> collectAnnotsExpr (Typed e _) env = collectAnnotsExpr e env-> collectAnnotsExpr (Tuple _ es) env = foldr collectAnnotsExpr env es-> collectAnnotsExpr (List _ es) env = foldr collectAnnotsExpr env es-> collectAnnotsExpr (ListCompr _ e qs) env =->   collectAnnotsExpr e (foldr collectAnnotsStmt env qs)-> collectAnnotsExpr (EnumFrom e) env = collectAnnotsExpr e env-> collectAnnotsExpr (EnumFromThen e1 e2) env =->   collectAnnotsExpr e1 (collectAnnotsExpr e2 env)-> collectAnnotsExpr (EnumFromTo e1 e2) env =->   collectAnnotsExpr e1 (collectAnnotsExpr e2 env)-> collectAnnotsExpr (EnumFromThenTo e1 e2 e3) env =->   collectAnnotsExpr e1 (collectAnnotsExpr e2 (collectAnnotsExpr e3 env))-> collectAnnotsExpr (UnaryMinus _ e) env = collectAnnotsExpr e env-> collectAnnotsExpr (Apply e1 e2) env =->   collectAnnotsExpr e1 (collectAnnotsExpr e2 env)-> collectAnnotsExpr (InfixApply e1 _ e2) env =->   collectAnnotsExpr e1 (collectAnnotsExpr e2 env)-> collectAnnotsExpr (LeftSection e _) env = collectAnnotsExpr e env-> collectAnnotsExpr (RightSection _ e) env = collectAnnotsExpr e env-> collectAnnotsExpr (Lambda _ _ e) env = collectAnnotsExpr e env-> collectAnnotsExpr (Let ds e) env =->   foldr collectAnnotsDecl (collectAnnotsExpr e env) ds-> collectAnnotsExpr (Do sts e) env =->   foldr collectAnnotsStmt (collectAnnotsExpr e env) sts-> collectAnnotsExpr (IfThenElse _ e1 e2 e3) env =->   collectAnnotsExpr e1 (collectAnnotsExpr e2 (collectAnnotsExpr e3 env))-> collectAnnotsExpr (Case _ e alts) env =->   collectAnnotsExpr e (foldr collectAnnotsAlt env alts)-> collectAnnotsExpr (RecordConstr fs) env =->   foldr collectAnnotsExpr env (map fieldTerm fs)-> collectAnnotsExpr (RecordSelection e _) env = collectAnnotsExpr e env-> collectAnnotsExpr (RecordUpdate fs e) env =->   foldr collectAnnotsExpr (collectAnnotsExpr e env) (map fieldTerm fs)--> collectAnnotsStmt :: Statement -> EvalEnv -> EvalEnv-> collectAnnotsStmt (StmtExpr _ e) env = collectAnnotsExpr e env-> collectAnnotsStmt (StmtDecl ds) env = foldr collectAnnotsDecl env ds-> collectAnnotsStmt (StmtBind _ _ e) env = collectAnnotsExpr e env--> collectAnnotsAlt :: Alt -> EvalEnv -> EvalEnv-> collectAnnotsAlt (Alt _ _ rhs) env = collectAnnotsRhs rhs env--\end{verbatim}
+ src/Exports.hs view
@@ -0,0 +1,425 @@+{- |+    Module      :  $Header$+    Description :  Computation of export interface+    Copyright   :  (c) 2000 - 2004 Wolfgang Lux+                       2005        Martin Engelke+                       2011 - 2016 Björn Peemöller+                       2015        Jan Tikovsky+                       2016        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module provides the computation of the exported interface of a+    compiled module. The function 'exportInterface' uses the expanded export+    specifications and the corresponding environments in order to compute+    the interface of the module.+-}+module Exports (exportInterface) where++import           Data.List         (nub)+import qualified Data.Map   as Map (foldrWithKey, toList)+import           Data.Maybe        (mapMaybe)+import qualified Data.Set   as Set ( Set, empty, insert, deleteMin, fromList+                                   , member, toList )++import Curry.Base.Position+import Curry.Base.SpanInfo+import Curry.Base.Ident+import Curry.Syntax++import Base.CurryKinds (fromKind')+import Base.CurryTypes (fromQualType, fromQualPredType)+import Base.Messages+import Base.Types++import Env.Class+import Env.OpPrec          (OpPrecEnv, PrecInfo (..), OpPrec (..), qualLookupP)+import Env.Instance+import Env.TypeConstructor ( TCEnv, TypeInfo (..), tcKind, clsKind+                           , qualLookupTypeInfo )+import Env.Value           (ValueEnv, ValueInfo (..), qualLookupValue)++import CompilerEnv++import Base.Kinds++-- ---------------------------------------------------------------------------+-- Computation of the interface+-- ---------------------------------------------------------------------------++-- After checking that the interface is not ambiguous, the compiler+-- generates the interface's declarations from the list of exported+-- functions and values. In order to make the interface more stable+-- against private changes in the module, we remove the hidden data+-- constructors of a data type in the interface when they occur+-- right-most in the declaration. In addition, newtypes whose constructor+-- is not exported are transformed into (abstract) data types.+--+-- If a type is imported from another module, its name is qualified with+-- the name of the module where it is defined. The same applies to an+-- exported function.++exportInterface :: CompilerEnv -> Module a -> Interface+exportInterface env (Module _ _ _ m (Just (Exporting _ es)) _ _) =+  exportInterface' m es (opPrecEnv env) (tyConsEnv env) (valueEnv env)+    (classEnv env) (instEnv env)+exportInterface _   (Module _ _ _ _ Nothing                 _ _) =+  internalError "Exports.exportInterface: no export specification"++exportInterface' :: ModuleIdent -> [Export] -> OpPrecEnv -> TCEnv -> ValueEnv+                 -> ClassEnv -> InstEnv -> Interface+exportInterface' m es pEnv tcEnv vEnv clsEnv inEnv = Interface m imports decls'+  where+  tvs     = filter (`notElem` tcs) identSupply+  tcs     = mapMaybe (localIdent m) $ definedTypes decls'+  imports = map (IImportDecl NoPos) $ usedModules decls'+  precs   = foldr (infixDecl m pEnv) [] es+  types   = foldr (typeDecl m tcEnv clsEnv tvs) [] es+  values  = foldr (valueDecl m vEnv tvs) [] es+  insts   = Map.foldrWithKey (instDecl m tcEnv tvs) [] inEnv+  decls   = precs ++ types ++ values ++ insts+  decls'  = closeInterface m tcEnv clsEnv inEnv tvs Set.empty decls++infixDecl :: ModuleIdent -> OpPrecEnv -> Export -> [IDecl] -> [IDecl]+infixDecl m pEnv (Export             _ f) ds = iInfixDecl m pEnv f ds+infixDecl m pEnv (ExportTypeWith _ tc cs) ds =+  foldr (iInfixDecl m pEnv . qualifyLike tc) ds cs+infixDecl _ _ _ _ = internalError "Exports.infixDecl: no pattern match"++iInfixDecl :: ModuleIdent -> OpPrecEnv -> QualIdent -> [IDecl] -> [IDecl]+iInfixDecl m pEnv op ds = case qualLookupP op pEnv of+  []                        -> ds+  [PrecInfo _ (OpPrec f p)] -> IInfixDecl NoPos f p (qualUnqualify m op) : ds+  _                         -> internalError "Exports.infixDecl"++-- Data types and renaming types whose constructors and field labels are+-- not exported are exported as abstract types, i.e., their constructors+-- do not appear in the interface. If only some constructors or field+-- labels of a type are not exported all constructors appear in the+-- interface, but a pragma marks the constructors and field labels which+-- are not exported as hidden to prevent their use in user code.++typeDecl :: ModuleIdent -> TCEnv -> ClassEnv -> [Ident] -> Export -> [IDecl]+         -> [IDecl]+typeDecl _ _     _      _   (Export             _ _) ds = ds+typeDecl m tcEnv clsEnv tvs (ExportTypeWith _ tc xs) ds =+  case qualLookupTypeInfo tc tcEnv of+    [DataType tc' k cs]+      | null xs   -> iTypeDecl IDataDecl m tvs tc' k []  [] : ds+      | otherwise -> iTypeDecl IDataDecl m tvs tc' k cs' hs : ds+      where hs    = filter (`notElem` xs) (csIds ++ ls)+            cs'   = map (constrDecl m n tvs) cs+            ls    = nub (concatMap recordLabels cs')+            csIds = map constrIdent cs+            n = kindArity k+    [RenamingType tc' k c]+      | null xs   -> iTypeDecl IDataDecl    m tvs tc' k [] [] : ds+      | otherwise -> iTypeDecl INewtypeDecl m tvs tc' k nc hs : ds+      where hs  = filter (`notElem` xs) (cId : ls)+            nc  = newConstrDecl m tvs c+            ls  = nrecordLabels nc+            cId = constrIdent c+    [AliasType tc' k n ty] -> ITypeDecl NoPos tc'' k' tvs' ty' : ds+      where tc'' = qualUnqualify m tc'+            k'   = fromKind' k n+            tvs' = take n tvs+            ty'  = fromQualType m tvs' ty+    [TypeClass qcls k ms] -> IClassDecl NoPos cx qcls' k' tv ms' hs : ds+      where qcls' = qualUnqualify m qcls+            cx    = [ Constraint NoSpanInfo (qualUnqualify m scls)+                        (VariableType NoSpanInfo tv)+                    | scls <- superClasses qcls clsEnv ]+            k'    = fromKind' k 0+            tv    = head tvs+            ms'   = map (methodDecl m tvs) ms+            hs    = filter (`notElem` xs) (map methodName ms)+    _ -> internalError "Exports.typeDecl"+typeDecl _ _ _ _ _ _ = internalError "Exports.typeDecl: no pattern match"++iTypeDecl+  :: (Position -> QualIdent -> Maybe KindExpr -> [Ident] -> a -> [Ident] -> IDecl)+  -> ModuleIdent -> [Ident] -> QualIdent -> Kind -> a -> [Ident] -> IDecl+iTypeDecl f m tvs tc k x hs = f NoPos (qualUnqualify m tc) k' (take n tvs) x hs+  where n  = kindArity k+        k' = fromKind' k n++constrDecl :: ModuleIdent -> Int -> [Ident] -> DataConstr -> ConstrDecl+constrDecl m _ tvs (DataConstr c [ty1, ty2])+  | isInfixOp c = ConOpDecl NoSpanInfo ty1' c ty2'+  where [ty1', ty2'] = map (fromQualType m tvs) [ty1, ty2]+constrDecl m _ tvs (DataConstr c tys) =+  ConstrDecl NoSpanInfo c tys'+  where tys' = map (fromQualType m tvs) tys+constrDecl m _ tvs (RecordConstr c ls tys) =+  RecordDecl NoSpanInfo c fs+  where+    tys' = map (fromQualType m tvs) tys+    fs   = zipWith (FieldDecl NoSpanInfo . return) ls tys'++newConstrDecl :: ModuleIdent -> [Ident] -> DataConstr -> NewConstrDecl+newConstrDecl m tvs (DataConstr c tys)+  = NewConstrDecl NoSpanInfo c (fromQualType m tvs (head tys))+newConstrDecl m tvs (RecordConstr c ls tys)+  = NewRecordDecl NoSpanInfo c (head ls, fromQualType m tvs (head tys))++-- When exporting a class method, we have to remove the implicit class context.+-- Due to the sorting of the predicate set, this is fortunatly very easy. The+-- implicit class context is always the minimum element as the class variable+-- is assigned the index 0 and no other constraints on it are allowed.++methodDecl :: ModuleIdent -> [Ident] -> ClassMethod -> IMethodDecl+methodDecl m tvs (ClassMethod f a (PredType ps ty)) = IMethodDecl NoPos f a $+  fromQualPredType m tvs $ PredType (Set.deleteMin ps) ty++valueDecl :: ModuleIdent -> ValueEnv -> [Ident] -> Export -> [IDecl] -> [IDecl]+valueDecl m vEnv tvs (Export     _ f) ds = case qualLookupValue f vEnv of+  [Value _ cm a (ForAll _ pty)] ->+    IFunctionDecl NoPos (qualUnqualify m f)+      (fmap (const (head tvs)) cm) a (fromQualPredType m tvs pty) : ds+  [Label _ _ _ ] -> ds -- Record labels are collected somewhere else.+  _ -> internalError $ "Exports.valueDecl: " ++ show f+valueDecl _ _ _ (ExportTypeWith _ _ _) ds = ds+valueDecl _ _ _ _ _ = internalError "Exports.valueDecl: no pattern match"++instDecl :: ModuleIdent -> TCEnv -> [Ident] -> InstIdent -> InstInfo -> [IDecl]+         -> [IDecl]+instDecl m tcEnv tvs ident@(cls, tc) info@(m', _, _) ds+  | qidModule cls /= Just m' && qidModule tc /= Just m' =+    iInstDecl m tcEnv tvs ident info : ds+  | otherwise = ds++iInstDecl :: ModuleIdent -> TCEnv -> [Ident] -> InstIdent -> InstInfo -> IDecl+iInstDecl m tcEnv tvs (cls, tc) (m', ps, is) =+  IInstanceDecl NoPos cx (qualUnqualify m cls) ty is mm+  where pty = PredType ps $ applyType (TypeConstructor tc) $+                map TypeVariable [0 .. n-1]+        QualTypeExpr _ cx ty = fromQualPredType m tvs pty+        n = kindArity (tcKind m tc tcEnv) - kindArity (clsKind m cls tcEnv)+        mm = if m == m' then Nothing else Just m'++-- The compiler determines the list of imported modules from the set of+-- module qualifiers that are used in the interface. Careful readers+-- probably will have noticed that the functions above carefully strip+-- the module prefix from all entities that are defined in the current+-- module. Note that the list of modules returned from+-- 'usedModules' is not necessarily a subset of the modules that+-- were imported into the current module. This will happen when an+-- imported module re-exports entities from another module. E.g., given+-- the three modules+--+-- @+-- module A where { data A = A; }+-- module B(A(..)) where { import A; }+-- module C where { import B; x = A; }+-- @+--+-- the interface for module @C@ will import module @A@ but not module @B@.++usedModules :: [IDecl] -> [ModuleIdent]+usedModules ds = nub' (modules ds [])+  where nub' = Set.toList . Set.fromList++class HasModule a where+  modules :: a -> [ModuleIdent] -> [ModuleIdent]++instance HasModule a => HasModule (Maybe a) where+  modules = maybe id modules++instance HasModule a => HasModule [a] where+  modules xs ms = foldr modules ms xs++instance HasModule IDecl where+  modules (IInfixDecl            _ _ _ op) = modules op+  modules (HidingDataDecl        _ tc _ _) = modules tc+  modules (IDataDecl        _ tc _ _ cs _) = modules tc . modules cs+  modules (INewtypeDecl     _ tc _ _ nc _) = modules tc . modules nc+  modules (ITypeDecl          _ tc _ _ ty) = modules tc . modules ty+  modules (IFunctionDecl      _ f _ _ qty) = modules f . modules qty+  modules (HidingClassDecl   _ cx cls _ _) = modules cx . modules cls+  modules (IClassDecl   _ cx cls _ _ ms _) =+    modules cx . modules cls . modules ms+  modules (IInstanceDecl _ cx cls ty _ mm) =+    modules cx . modules cls . modules ty . modules mm++instance HasModule ConstrDecl where+  modules (ConstrDecl    _ _ tys) = modules tys+  modules (ConOpDecl _ ty1 _ ty2) = modules ty1 . modules ty2+  modules (RecordDecl     _ _ fs) = modules fs++instance HasModule FieldDecl where+  modules (FieldDecl _ _ ty) = modules ty++instance HasModule NewConstrDecl where+  modules (NewConstrDecl _ _      ty) = modules ty+  modules (NewRecordDecl _ _ (_, ty)) = modules ty++instance HasModule IMethodDecl where+  modules (IMethodDecl _ _ _ qty) = modules qty++instance HasModule Constraint where+  modules (Constraint _ cls ty) = modules cls . modules ty++instance HasModule TypeExpr where+  modules (ConstructorType _ tc) = modules tc+  modules (ApplyType  _ ty1 ty2) = modules ty1 . modules ty2+  modules (VariableType     _ _) = id+  modules (TupleType      _ tys) = modules tys+  modules (ListType        _ ty) = modules ty+  modules (ArrowType  _ ty1 ty2) = modules ty1 . modules ty2+  modules (ParenType       _ ty) = modules ty+  modules (ForallType    _ _ ty) = modules ty++instance HasModule QualTypeExpr where+  modules (QualTypeExpr _ cx ty) = modules cx . modules ty++instance HasModule QualIdent where+  modules = modules . qidModule++instance HasModule ModuleIdent where+  modules = (:)++-- After the interface declarations have been computed, the compiler+-- eventually must add hidden (data) type and class declarations to the+-- interface for all those types and classs which were used in the interface+-- but not exported from the current module, so that these type constructors+-- can always be distinguished from type variables. Besides hidden type and+-- class declarations, the compiler also adds instance declarations to the+-- interface. Since class and instance declarations added to an interface can+-- require the inclusion of further classes by their respective contexts,+-- closing an interface is implemented as a fix-point computation which+-- starts from the initial interface.++data IInfo = IOther | IType QualIdent | IClass QualIdent | IInst InstIdent+  deriving (Eq, Ord)++iInfo :: IDecl -> IInfo+iInfo (IInfixDecl           _ _ _ _) = IOther+iInfo (HidingDataDecl      _ tc _ _) = IType tc+iInfo (IDataDecl       _ tc _ _ _ _) = IType tc+iInfo (INewtypeDecl    _ tc _ _ _ _) = IType tc+iInfo (ITypeDecl          _ _ _ _ _) = IOther+iInfo (HidingClassDecl  _ _ cls _ _) = IClass cls+iInfo (IClassDecl   _ _ cls _ _ _ _) = IClass cls+iInfo (IInstanceDecl _ _ cls ty _ _) = IInst (cls, typeConstr ty)+iInfo (IFunctionDecl      _ _ _ _ _) = IOther++closeInterface :: ModuleIdent -> TCEnv -> ClassEnv -> InstEnv -> [Ident]+               -> Set.Set IInfo -> [IDecl] -> [IDecl]+closeInterface _ _ _ _ _ _ [] = []+closeInterface m tcEnv clsEnv inEnv tvs is (d:ds)+  | i == IOther       =+    d : closeInterface m tcEnv clsEnv inEnv tvs is (ds ++ ds')+  | i `Set.member` is = closeInterface m tcEnv clsEnv inEnv tvs is ds+  | otherwise         =+    d : closeInterface m tcEnv clsEnv inEnv tvs (Set.insert i is) (ds ++ ds')+  where i   = iInfo d+        ds' = hiddenTypes m tcEnv clsEnv tvs d +++                instances m tcEnv inEnv tvs is i++hiddenTypes :: ModuleIdent -> TCEnv -> ClassEnv -> [Ident] -> IDecl -> [IDecl]+hiddenTypes m tcEnv clsEnv tvs d =+  map hiddenTypeDecl $ filter (not . isPrimTypeId) (usedTypes d [])+  where hiddenTypeDecl tc = case qualLookupTypeInfo (qualQualify m tc) tcEnv of+          [DataType       _ k _] -> hidingDataDecl k+          [RenamingType   _ k _] -> hidingDataDecl k+          [TypeClass    cls k _] -> hidingClassDecl k $ superClasses cls clsEnv+          _                      ->+            internalError $ "Exports.hiddenTypeDecl: " ++ show tc+          where hidingDataDecl k =+                  let n = kindArity k+                      k' = fromKind' k n+                  in  HidingDataDecl NoPos tc k' $ take n tvs+                hidingClassDecl k sclss =+                  let cx = [ Constraint NoSpanInfo (qualUnqualify m scls)+                               (VariableType NoSpanInfo tv)+                           | scls <- sclss ]+                      tv = head tvs+                      k' = fromKind' k 0+                  in  HidingClassDecl NoPos cx tc k' tv++instances :: ModuleIdent -> TCEnv -> InstEnv -> [Ident] -> Set.Set IInfo+          -> IInfo -> [IDecl]+instances _ _ _ _ _ IOther = []+instances m tcEnv inEnv tvs is (IType tc) =+  [ iInstDecl m tcEnv tvs ident info+  | (ident@(cls, tc'), info@(m', _, _)) <- Map.toList inEnv,+    qualQualify m tc == tc',+    if qidModule cls == Just m' then Set.member (IClass (qualUnqualify m cls)) is+                                else qidModule tc' == Just m' ]+instances m tcEnv inEnv tvs is (IClass cls) =+  [ iInstDecl m tcEnv tvs ident info+  | (ident@(cls', tc), info@(m', _, _)) <- Map.toList inEnv,+    qualQualify m cls == cls',+    qidModule cls' == Just m',+    m /= m' || isPrimTypeId tc+            || qidModule tc /= Just m+            || Set.member (IType (qualUnqualify m tc)) is ]+instances _ _ _ _ _ (IInst _) = []++definedTypes :: [IDecl] -> [QualIdent]+definedTypes ds = foldr definedType [] ds+  where+  definedType :: IDecl -> [QualIdent] -> [QualIdent]+  definedType (HidingDataDecl     _ tc _ _) tcs = tc : tcs+  definedType (IDataDecl      _ tc _ _ _ _) tcs = tc : tcs+  definedType (INewtypeDecl   _ tc _ _ _ _) tcs = tc : tcs+  definedType (ITypeDecl      _ tc _ _ _  ) tcs = tc : tcs+  definedType (HidingClassDecl _ _ cls _ _) tcs = cls : tcs+  definedType (IClassDecl  _ _ cls _ _ _ _) tcs = cls : tcs+  definedType _                             tcs = tcs++class HasType a where+  usedTypes :: a -> [QualIdent] -> [QualIdent]++instance HasType a => HasType (Maybe a) where+  usedTypes = maybe id usedTypes++instance HasType a => HasType [a] where+  usedTypes xs tcs = foldr usedTypes tcs xs++instance HasType IDecl where+  usedTypes (IInfixDecl            _ _ _ _) = id+  usedTypes (HidingDataDecl        _ _ _ _) = id+  usedTypes (IDataDecl        _ _ _ _ cs _) = usedTypes cs+  usedTypes (INewtypeDecl     _ _ _ _ nc _) = usedTypes nc+  usedTypes (ITypeDecl          _ _ _ _ ty) = usedTypes ty+  usedTypes (IFunctionDecl     _ _ _ _ qty) = usedTypes qty+  usedTypes (HidingClassDecl    _ cx _ _ _) = usedTypes cx+  usedTypes (IClassDecl    _ cx _ _ _ ms _) = usedTypes cx . usedTypes ms+  usedTypes (IInstanceDecl _ cx cls ty _ _) =+    usedTypes cx . (cls :) . usedTypes ty++instance HasType ConstrDecl where+  usedTypes (ConstrDecl    _ _ tys) = usedTypes tys+  usedTypes (ConOpDecl _ ty1 _ ty2) =+    usedTypes ty1 . usedTypes ty2+  usedTypes (RecordDecl     _ _ fs) = usedTypes fs++instance HasType FieldDecl where+  usedTypes (FieldDecl _ _ ty) = usedTypes ty++instance HasType NewConstrDecl where+  usedTypes (NewConstrDecl      _ _ ty) = usedTypes ty+  usedTypes (NewRecordDecl _ _ (_, ty)) = usedTypes ty++instance HasType IMethodDecl where+  usedTypes (IMethodDecl _ _ _ qty) = usedTypes qty++instance HasType Constraint where+  usedTypes (Constraint _ cls ty) = (cls :) . usedTypes ty++instance HasType TypeExpr where+  usedTypes (ConstructorType _ tc) = (tc :)+  usedTypes (ApplyType _ ty1 ty2) = usedTypes ty1 . usedTypes ty2+  usedTypes (VariableType     _ _) = id+  usedTypes (TupleType      _ tys) = usedTypes tys+  usedTypes (ListType        _ ty) = usedTypes ty+  usedTypes (ArrowType  _ ty1 ty2) = usedTypes ty1 . usedTypes ty2+  usedTypes (ParenType       _ ty) = usedTypes ty+  usedTypes (ForallType    _ _ ty) = usedTypes ty++instance HasType QualTypeExpr where+  usedTypes (QualTypeExpr _ cx ty) = usedTypes cx . usedTypes ty
− src/Exports.lhs 
@@ -1,463 +0,0 @@--% $Id: Exports.lhs,v 1.32 2004/02/13 19:23:57 wlux Exp $-%-% Copyright (c) 2000-2004, Wolfgang Lux-% See LICENSE for the full license.-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-%-\nwfilename{Exports.lhs}-\section{Creating Interfaces}-This section describes how the exported interface of a compiled module-is computed.-\begin{verbatim}--> module Exports(expandInterface,exportInterface) where--> import Data.List-> import Data.Maybe-> import qualified Data.Set as Set-> import qualified Data.Map as Map--> import Curry.Syntax-> import Types-> import Curry.Base.Position-> import Curry.Base.Ident-> import Base-> import TopEnv--\end{verbatim}-The interface of a module is computed in two steps. The function-\texttt{expandInterface} checks the export specifications of the-module and expands them into a list containing all exported types and-functions, combining multiple exports for the same entity. The-expanded export specifications refer to the original names of all-entities. The function \texttt{exportInterface} uses the expanded-specifications and the corresponding environments in order to compute-to the interface of the module.-\begin{verbatim}--> expandInterface :: Module -> TCEnv -> ValueEnv -> Module-> expandInterface (Module m es ds) tcEnv tyEnv =->     --error (show es')->   case findDouble [unqualify tc | ExportTypeWith tc _ <- es'] of->     Nothing ->->       case findDouble ([c | ExportTypeWith _ cs <- es', c <- cs] ++->                    [unqualify f | Export f <- es']) of->         Nothing -> Module m (Just (Exporting NoPos es')) ds->         Just v -> errorAt' (ambiguousExportValue v)->     Just tc -> errorAt' (ambiguousExportType tc) ->   where ms = Set.fromList [fromMaybe m asM | ImportDecl _ m _ asM _ <- ds]->         es' = joinExports $->               maybe (expandLocalModule tcEnv tyEnv)->                     (expandSpecs ms m tcEnv tyEnv)->                     es--\end{verbatim}-While checking all export specifications, the compiler expands-specifications of the form \verb|T(..)| into-\texttt{T($C_1,\dots,C_n$)}, where $C_1,\dots,C_n$ are the data-constructors or the record labels of type \texttt{T}, and replaces -an export specification-\verb|module M| by specifications for all entities which are defined-in module \texttt{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 \verb|T()|. Note that the export specification \texttt{x} may-export a type constructor \texttt{x} \emph{and} a global function-\texttt{x} at the same time.--\em{Note:} This frontend allows redeclaration and export of imported-identifiers.-\begin{verbatim}--> expandSpecs :: Set.Set ModuleIdent -> ModuleIdent -> TCEnv -> ValueEnv->             -> ExportSpec -> [Export]-> expandSpecs ms m tcEnv tyEnv (Exporting _ es) =->   concat (map (expandExport ms m tcEnv tyEnv) es)--> expandExport :: Set.Set ModuleIdent -> ModuleIdent -> TCEnv->              -> ValueEnv -> Export -> [Export]-> expandExport _ m tcEnv tyEnv (Export x) = expandThing m tcEnv tyEnv x-> expandExport _ m tcEnv _ (ExportTypeWith tc cs) =->   expandTypeWith m tcEnv tc cs-> expandExport _ m tcEnv tyEnv (ExportTypeAll tc) = ->   expandTypeAll m tyEnv tcEnv tc-> expandExport ms m tcEnv tyEnv (ExportModule m')->   | m == m' = (if m `Set.member` ms then expandModule tcEnv tyEnv m else [])->               ++ expandLocalModule tcEnv tyEnv->   | m' `Set.member` ms = expandModule tcEnv tyEnv m'->   | otherwise = errorAt' (moduleNotImported m')--> expandThing :: ModuleIdent -> TCEnv -> ValueEnv -> QualIdent->                -> [Export]-> expandThing m tcEnv tyEnv tc =->   case qualLookupTC tc tcEnv of->     [] -> expandThing' m tyEnv tc Nothing->     [t] -> expandThing' m tyEnv tc (Just [ExportTypeWith (origName t) []])->     _ -> errorAt' (ambiguousType tc)--> expandThing' :: ModuleIdent -> ValueEnv -> QualIdent->              -> Maybe [Export] -> [Export]-> expandThing' m tyEnv f tcExport =->   case (qualLookupValue f tyEnv) of->     [] -> fromMaybe (errorAt' (undefinedEntity f)) tcExport->     [Value f' _] -> Export f' : fromMaybe [] tcExport->     [_] -> fromMaybe (errorAt' (exportDataConstr f)) tcExport->     vs -> case (qualLookupValue (qualQualify m f) tyEnv) of->             [] -> fromMaybe (errorAt' (undefinedEntity f)) tcExport->             [Value f'' _] -> Export f'' : fromMaybe [] tcExport->             [_] -> fromMaybe (errorAt' (exportDataConstr f)) tcExport->             _   -> errorAt' (ambiguousName f)--> expandTypeWith :: ModuleIdent -> TCEnv -> QualIdent -> [Ident] ->	 -> [Export]-> expandTypeWith m tcEnv tc cs =->   case qualLookupTC tc tcEnv of->     [] -> errorAt' (undefinedType tc)->     [t]->       | isDataType t -> [ExportTypeWith (origName t)->                            (map (checkConstr (constrs t)) (nub cs))]->       | isRecordType t -> [ExportTypeWith (origName t)->                            (map (checkLabel (labels t)) (nub cs))]->       | otherwise -> errorAt' (nonDataType tc)->     _ -> errorAt' (ambiguousType tc)->   where checkConstr cs c->           | c `elem` cs = c->           | otherwise = errorAt' (undefinedDataConstr tc c)->         checkLabel ls l->	    | l' `elem` ls = l'->           | otherwise = errorAt' (undefinedLabel tc l)->	   where l' = renameLabel l--> expandTypeAll :: ModuleIdent -> ValueEnv -> TCEnv -> QualIdent ->	-> [Export]-> expandTypeAll m tyEnv tcEnv tc =->   case qualLookupTC tc tcEnv of->     [] -> errorAt' (undefinedType tc)->     [t]->       | isDataType t -> [exportType tyEnv t]->       | isRecordType t -> exportRecord m t->       | otherwise -> errorAt' (nonDataType tc)->     _ -> errorAt' (ambiguousType tc)--> expandLocalModule :: TCEnv -> ValueEnv -> [Export]-> expandLocalModule tcEnv tyEnv =->   [exportType tyEnv t | (_,t) <- localBindings tcEnv] ++->   [Export f' | (f,Value f' _) <- localBindings tyEnv, f == unRenameIdent f]--> expandModule :: TCEnv -> ValueEnv -> ModuleIdent -> [Export]-> expandModule tcEnv tyEnv m =->   [exportType tyEnv t | (_,t) <- moduleImports m tcEnv] ++->   [Export f | (_,Value f _) <- moduleImports m tyEnv]--> exportType :: ValueEnv -> TypeInfo -> Export-> exportType tyEnv t ->   | isRecordType t -- = ExportTypeWith (origName t) (labels t)->     = let ls = labels t->           r  = origName t->       in  case (lookupValue (head ls) tyEnv) of->             [Label _ r' _] -> if r == r' then ExportTypeWith r ls->		                   else ExportTypeWith r []->             _ -> internalError "exportType"->   | otherwise = ExportTypeWith (origName t) (constrs t)--> exportRecord :: ModuleIdent -> TypeInfo -> [Export]-> exportRecord m t = [ExportTypeWith (origName t) (labels t)]--\end{verbatim}-The expanded list of exported entities may contain duplicates. These-are removed by the function \texttt{joinExports}.-\begin{verbatim}--> joinExports :: [Export] -> [Export]-> joinExports es =->   [ExportTypeWith tc cs | (tc,cs) <- Map.toList (foldr joinType Map.empty es)] ++->   [Export f | f <- 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--> joinFun :: Export -> Set.Set QualIdent -> Set.Set QualIdent-> joinFun (Export f) fs = f `Set.insert` fs-> joinFun (ExportTypeWith _ _) fs = fs--\end{verbatim}-After checking that the interface is not ambiguous, the compiler-generates the interface's declarations from the list of exported-functions and values. In order to make the interface more stable-against private changes in the module, we remove the hidden data-constructors of a data type in the interface when they occur-right-most in the declaration. In addition, newtypes whose constructor-is not exported are transformed into (abstract) data types.--If a type is imported from another module, its name is qualified with-the name of the module where it is defined. The same applies to an-exported function.-\begin{verbatim}--> exportInterface :: Module -> PEnv -> TCEnv -> ValueEnv -> Interface-> exportInterface (Module m (Just (Exporting _ es)) _) pEnv tcEnv tyEnv =->   Interface m (imports ++ precs ++ hidden ++ ds)->   where imports = map (IImportDecl NoPos) (usedModules ds)->         precs = foldr (infixDecl m pEnv) [] es->         hidden = map (hiddenTypeDecl m tcEnv) (hiddenTypes ds)->         ds = foldr (typeDecl m tcEnv) (foldr (funDecl m tyEnv) [] es) es-> exportInterface (Module _ Nothing _) _ _ _ = internalError "exportInterface"--> infixDecl :: ModuleIdent -> PEnv -> Export -> [IDecl] -> [IDecl]-> infixDecl m pEnv (Export f) ds = iInfixDecl m pEnv f ds-> infixDecl m pEnv (ExportTypeWith tc cs) ds =->   foldr (iInfixDecl m pEnv . qualifyLike (qualidMod tc)) ds cs->   where qualifyLike = maybe qualify qualifyWith--> iInfixDecl :: ModuleIdent -> PEnv -> QualIdent -> [IDecl] -> [IDecl]-> iInfixDecl m pEnv op ds =->   case qualLookupP op pEnv of->     [] -> ds->     [PrecInfo _ (OpPrec fix pr)] ->->       IInfixDecl NoPos fix pr (qualUnqualify m op) : ds->     _ -> internalError "infixDecl"--> typeDecl :: ModuleIdent -> TCEnv -> Export -> [IDecl] -> [IDecl]-> typeDecl _ _ (Export _) ds = ds-> typeDecl m tcEnv (ExportTypeWith tc cs) ds =->   case qualLookupTC tc tcEnv of->     [DataType tc n cs'] ->->       iTypeDecl IDataDecl m tc n->          (constrDecls m (drop n nameSupply) cs cs') : ds->     [RenamingType tc n (Data c n' ty)]->       | c `elem` cs ->->           iTypeDecl INewtypeDecl m tc n (NewConstrDecl NoPos tvs c ty') : ds->       | otherwise -> iTypeDecl IDataDecl m tc n [] : ds->       where tvs = take n' (drop n nameSupply)->             ty' = fromQualType m ty->     [AliasType tc n ty] ->->       case ty of ->	  TypeRecord fs _ ->->           let ty' = TypeRecord (filter (\ (l,_) -> elem l cs) fs) Nothing->           in  iTypeDecl ITypeDecl m tc n (fromQualType m ty') : ds->         _ -> iTypeDecl ITypeDecl m tc n (fromQualType m ty) : ds->     _ -> internalError "typeDecl"--> iTypeDecl :: (Position -> QualIdent -> [Ident] -> a -> IDecl)->            -> ModuleIdent -> QualIdent -> Int -> a -> IDecl-> iTypeDecl f m tc n = f NoPos (qualUnqualify m tc) (take n nameSupply)--> constrDecls :: ModuleIdent -> [Ident] -> [Ident] -> [Maybe (Data [Type])]->             -> [Maybe ConstrDecl]-> constrDecls m tvs cs = clean . map (>>= constrDecl m tvs)->   where clean = reverse . dropWhile isNothing . reverse->         constrDecl m tvs (Data c n tys)->           | c `elem` cs =->               Just (iConstrDecl (take n tvs) c (map (fromQualType m) tys))->           | otherwise = Nothing--> iConstrDecl :: [Ident] -> Ident -> [TypeExpr] -> ConstrDecl-> iConstrDecl tvs op [ty1,ty2]->   | isInfixOp op = ConOpDecl NoPos tvs ty1 op ty2-> iConstrDecl tvs c tys = ConstrDecl NoPos tvs c tys--> funDecl :: ModuleIdent -> ValueEnv -> Export -> [IDecl] -> [IDecl]-> funDecl m tyEnv (Export f) ds =->   case qualLookupValue f tyEnv of->     [Value _ (ForAll _ ty)] ->->       IFunctionDecl NoPos (qualUnqualify m f) (arrowArity ty) ->		  (fromQualType m ty) : ds->     _ -> internalError ("funDecl: " ++ show f)-> funDecl _ _ (ExportTypeWith _ _) ds = ds---\end{verbatim}-The compiler determines the list of imported modules from the set of-module qualifiers that are used in the interface. Careful readers-probably will have noticed that the functions above carefully strip-the module prefix from all entities that are defined in the current-module. Note that the list of modules returned from-\texttt{usedModules} is not necessarily a subset of the modules that-were imported into the current module. This will happen when an-imported module re-exports entities from another module. E.g., given-the three modules-\begin{verbatim}-module A where { data A = A; }-module B(A(..)) where { import A; }-module C where { import B; x = A; }-\end{verbatim}-the interface for module \texttt{C} will import module \texttt{A} but-not module \texttt{B}.-\begin{verbatim}--> usedModules :: [IDecl] -> [ModuleIdent]-> usedModules ds = nub (catMaybes (map qualidMod (foldr identsDecl [] ds)))->   where nub = Set.toList . Set.fromList--> identsDecl :: IDecl -> [QualIdent] -> [QualIdent]-> identsDecl (IDataDecl _ tc _ cs) xs =->   tc : foldr identsConstrDecl xs (catMaybes cs)-> identsDecl (INewtypeDecl _ tc _ nc) xs = tc : identsNewConstrDecl nc xs-> identsDecl (ITypeDecl _ tc _ ty) xs = tc : identsType ty xs-> identsDecl (IFunctionDecl _ f _ ty) xs = f : identsType ty xs--> identsConstrDecl :: ConstrDecl -> [QualIdent] -> [QualIdent]-> identsConstrDecl (ConstrDecl _ _ _ tys) xs = foldr identsType xs tys-> identsConstrDecl (ConOpDecl _ _ ty1 _ ty2) xs =->   identsType ty1 (identsType ty2 xs)--> identsNewConstrDecl :: NewConstrDecl -> [QualIdent] -> [QualIdent]-> identsNewConstrDecl (NewConstrDecl _ _ _ ty) xs = identsType ty xs--> identsType :: TypeExpr -> [QualIdent] -> [QualIdent]-> identsType (ConstructorType tc tys) xs = tc : foldr identsType xs tys-> identsType (VariableType _) xs = xs-> identsType (TupleType tys) xs = foldr identsType xs tys-> identsType (ListType ty) xs = identsType ty xs-> identsType (ArrowType ty1 ty2) xs = identsType ty1 (identsType ty2 xs)-> identsType (RecordType fs rty) xs =->   foldr identsType (maybe xs (\ty -> identsType ty xs) rty) (map snd fs)--\end{verbatim}-After the interface declarations have been computed, the compiler-eventually must add hidden (data) type declarations to the interface-for all those types which were used in the interface but not exported-from the current module, so that these type constructors can always be-distinguished from type variables.-\begin{verbatim}--> hiddenTypeDecl :: ModuleIdent -> TCEnv -> QualIdent -> IDecl-> hiddenTypeDecl m tcEnv tc =->   case qualLookupTC (qualQualify m tc) tcEnv of->     [DataType _ n _] -> hidingDataDecl tc n->     [RenamingType _ n _] -> hidingDataDecl tc n->     _ ->  internalError "hiddenTypeDecl"->   where hidingDataDecl tc n =->           HidingDataDecl NoPos (unqualify tc) (take n nameSupply)--> hiddenTypes :: [IDecl] -> [QualIdent]-> hiddenTypes ds = [tc | tc <- Set.toList tcs, not (isQualified tc)]->   where tcs = foldr Set.delete (Set.fromList (usedTypes ds))->                     (definedTypes ds)--> usedTypes :: [IDecl] -> [QualIdent]-> usedTypes ds = foldr usedTypesDecl [] ds--> usedTypesDecl :: IDecl -> [QualIdent] -> [QualIdent]-> usedTypesDecl (IDataDecl _ _ _ cs) tcs =->   foldr usedTypesConstrDecl tcs (catMaybes cs)-> usedTypesDecl (INewtypeDecl _ _ _ nc) tcs = usedTypesNewConstrDecl nc tcs-> usedTypesDecl (ITypeDecl _ _ _ ty) tcs = usedTypesType ty tcs-> usedTypesDecl (IFunctionDecl _ _ _ ty) tcs = usedTypesType ty tcs--> usedTypesConstrDecl :: ConstrDecl -> [QualIdent] -> [QualIdent]-> usedTypesConstrDecl (ConstrDecl _ _ _ tys) tcs = foldr usedTypesType tcs tys-> usedTypesConstrDecl (ConOpDecl _ _ ty1 _ ty2) tcs =->   usedTypesType ty1 (usedTypesType ty2 tcs)--> usedTypesNewConstrDecl :: NewConstrDecl -> [QualIdent] -> [QualIdent]-> usedTypesNewConstrDecl (NewConstrDecl _ _ _ ty) tcs = usedTypesType ty tcs--> usedTypesType :: TypeExpr -> [QualIdent] -> [QualIdent]-> usedTypesType (ConstructorType tc tys) tcs = tc : foldr usedTypesType tcs tys-> usedTypesType (VariableType _) tcs = tcs-> usedTypesType (TupleType tys) tcs = foldr usedTypesType tcs tys-> usedTypesType (ListType ty) tcs = usedTypesType ty tcs-> usedTypesType (ArrowType ty1 ty2) tcs =->   usedTypesType ty1 (usedTypesType ty2 tcs)-> usedTypesType (RecordType fs rty) tcs =->   foldr usedTypesType ->         (maybe tcs (\ty -> usedTypesType ty tcs) rty) ->         (map snd fs)--> definedTypes :: [IDecl] -> [QualIdent]-> definedTypes ds = foldr definedType [] ds--> definedType :: IDecl -> [QualIdent] -> [QualIdent]-> definedType (IDataDecl _ tc _ _) tcs = tc : tcs-> definedType (INewtypeDecl _ tc _ _) tcs = tc : tcs-> definedType (ITypeDecl _ tc _ _) tcs = tc : tcs-> definedType (IFunctionDecl _ _ _ _)  tcs = tcs--\end{verbatim}-Auxiliary definitions-\begin{verbatim}---> isDataType :: TypeInfo -> Bool-> isDataType (DataType _ _ _) = True-> isDataType (RenamingType _ _ _) = True-> isDataType (AliasType _ _ _) = False--> isRecordType :: TypeInfo -> Bool-> isRecordType (AliasType _ _ (TypeRecord _ _)) = True-> isRecordType _ = False--> constrs :: TypeInfo -> [Ident]-> constrs (DataType _ _ cs) = [c | Just (Data c _ _) <- cs]-> constrs (RenamingType _ _ (Data c _ _)) = [c]-> constrs (AliasType _ _ _) = []--> labels :: TypeInfo -> [Ident]-> labels (AliasType _ _ (TypeRecord fs _)) = map fst fs-> labels _ = []--\end{verbatim}-Error messages-\begin{verbatim}--> undefinedEntity :: QualIdent -> (Position,String)-> undefinedEntity x =->   (positionOfQualIdent x,->    "Entity " ++ qualName x ++ " in export list is not defined")--> undefinedType :: QualIdent -> (Position,String)-> undefinedType tc = ->   (positionOfQualIdent tc,->    "Type " ++ qualName tc ++ " in export list is not defined")--> moduleNotImported :: ModuleIdent -> (Position,String)-> moduleNotImported m = ->   (positionOfModuleIdent m,->    "Module " ++ moduleName m ++ " not imported")--> ambiguousExportType :: Ident -> (Position,String)-> ambiguousExportType x = ->   (positionOfIdent x,->    "Ambiguous export of type " ++ name x)--> ambiguousExportValue :: Ident -> (Position,String)-> ambiguousExportValue x = ->   (positionOfIdent x,->    "Ambiguous export of " ++ name x)--> ambiguousType :: QualIdent -> (Position,String)-> ambiguousType tc = ->   (positionOfQualIdent tc,->    "Ambiguous type " ++ qualName tc)--> ambiguousName :: QualIdent -> (Position,String)-> ambiguousName x = ->   (positionOfQualIdent x,->    "Ambiguous name " ++ qualName x)--> exportDataConstr :: QualIdent -> (Position,String)-> exportDataConstr c = ->   (positionOfQualIdent c,->    "Data constructor " ++ qualName c ++ " in export list")--> nonDataType :: QualIdent -> (Position,String)-> nonDataType tc = ->   (positionOfQualIdent tc,->    qualName tc ++ " is not a data type")--> undefinedDataConstr :: QualIdent -> Ident -> (Position,String)-> undefinedDataConstr tc c =->   (positionOfIdent c,    ->    name c ++ " is not a data constructor of type " ++ qualName tc)--> undefinedLabel :: QualIdent -> Ident -> (Position,String)-> undefinedLabel r l =->   (positionOfIdent l,    ->    name l ++ " is not a label of the record " ++ qualName r)--\end{verbatim}
+ src/Files/CymakePath.hs view
@@ -0,0 +1,32 @@+{- |+    Module      :  $Header$+    Description :  File pathes+    Copyright   :  (c) 2011, Björn Peemöller (bjp@informatik.uni-kiel.de)+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module contains functions to obtain the version number and path+    of the front end binary.+-}+module Files.CymakePath (getCymake, cymakeGreeting, cymakeVersion) where++import Data.Version (showVersion)+import System.FilePath ((</>))+import Paths_curry_frontend++-- | Show a greeting of the current front end+cymakeGreeting :: String+cymakeGreeting = "This is the Curry front end, version " ++ cymakeVersion++-- | Retrieve the version number of cymake+cymakeVersion :: String+cymakeVersion = showVersion version++-- | Retrieve the location of the front end executable+getCymake :: IO String+getCymake = do+  cymakeDir <- getBinDir+  return $ cymakeDir </> "curry-frontend"
− src/GenAbstractCurry.hs 
@@ -1,1041 +0,0 @@---------------------------------------------------------------------------------------------------------------------------------------------------------------------- GenAbstractCurry - Generates an AbstractCurry program term---                    (type 'CurryProg')------ July 2005,--- Martin Engelke (men@informatik.uni-kiel.de)----module GenAbstractCurry (genTypedAbstract, -			 genUntypedAbstract) where--import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.Maybe-import Data.List-import Data.Char--import Curry.Syntax-import Curry.Syntax.Utils-import Curry.AbstractCurry--import Base-import Types-import Curry.Base.Ident-import Curry.Base.Position-import TopEnv-------------------------------------------------------------------------------------- Generates standard (type infered) AbstractCurry code from a CurrySyntax--- module. The function needs the type environment 'tyEnv' to determin the--- infered function types.-genTypedAbstract :: ValueEnv -> TCEnv -> Module -> CurryProg-genTypedAbstract tyEnv tcEnv mod-   = genAbstract (genAbstractEnv TypedAcy tyEnv tcEnv mod) mod----- Generates untyped AbstractCurry code from a CurrySyntax module. The type--- signature takes place in every function type annotation, if it exists, --- otherwise the dummy type "Prelude.untyped" is used.-genUntypedAbstract :: ValueEnv -> TCEnv -> Module -> CurryProg-genUntypedAbstract tyEnv tcEnv mod-   = genAbstract (genAbstractEnv UntypedAcy tyEnv tcEnv mod) mod--------------------------------------------------------------------------------------------------------------------------------------------------------------------- Private...---- Generates an AbstractCurry program term from the syntax tree-genAbstract :: AbstractEnv -> Module -> CurryProg-genAbstract env (Module mid exp decls)-   = let partitions = foldl partitionDecl emptyPartitions decls-         modname    = moduleName mid -	 (imps, _)  -	     = mapfoldl genImportDecl env (reverse (importDecls partitions))-	 (types, _) -	     = mapfoldl genTypeDecl env (reverse (typeDecls partitions))-	 (_, funcs) -	     = Map.mapAccumWithKey (genFuncDecl False) -	                env -			(funcDecls partitions)-	 (ops, _)   -	     = mapfoldl genOpDecl env (reverse (opDecls partitions))-     in  CurryProg modname imps types (Map.elems funcs) ops--------------------------------------------------------------------------------------------------------------------------------------------------------------------- The following types and functions can be used to spread a list of--- CurrySyntax declarations into four parts: a list of imports, a list of--- type declarations (data types and type synonyms), a table of function--- declarations and a list of fixity declarations.----- Inserts a CurrySyntax top level declaration into a partition.--- Note: declarations are collected in reverse order.-partitionDecl :: Partitions -> Decl -> Partitions-partitionDecl partitions (TypeSig pos ids typeexpr)-   = partitionFuncDecls (\id -> TypeSig pos [id] typeexpr) partitions ids-partitionDecl partitions (EvalAnnot pos ids annot)-   = partitionFuncDecls (\id -> EvalAnnot pos [id] annot) partitions ids-partitionDecl partitions (FunctionDecl pos id equs)-   = partitionFuncDecls (const (FunctionDecl pos id equs)) partitions [id]-partitionDecl partitions (ExternalDecl pos conv name id typeexpr)-   = partitionFuncDecls (const (ExternalDecl pos conv name id typeexpr))-                     partitions-		     [id]-partitionDecl partitions (FlatExternalDecl pos ids)-   = partitionFuncDecls (\id -> FlatExternalDecl pos [id]) partitions ids-partitionDecl partitions (InfixDecl pos fix prec idents)-   = partitions {opDecls = map (\id -> (InfixDecl pos fix prec [id])) idents-		           ++ opDecls partitions }-partitionDecl partitions decl-   = case decl of-       ImportDecl _ _ _ _ _ -         -> partitions {importDecls = decl: importDecls partitions }-       DataDecl _ _ _ _     -         -> partitions {typeDecls = decl : typeDecls partitions }-       TypeDecl _ _ _ _     -         -> partitions {typeDecls = decl : typeDecls partitions }-       _ -> partitions------partitionFuncDecls :: (Ident -> Decl) -> Partitions -> [Ident] -> Partitions-partitionFuncDecls genDecl partitions ids-   = partitions {funcDecls = foldl partitionFuncDecl (funcDecls partitions) ids}- where-   partitionFuncDecl funcs' id-      = Map.insert id (genDecl id : fromMaybe [] (Map.lookup id funcs')) funcs'----- Data type for representing partitions of CurrySyntax declarations--- (according to the definition of the AbstractCurry program--- representation; type 'CurryProg').--- Since a complete function declaration usually consist of more than one--- declaration (e.g. rules, type signature etc.), it is necessary --- to collect them within an association list-data Partitions = Partitions {importDecls :: [Decl],-			      typeDecls   :: [Decl],-			      funcDecls   :: Map.Map Ident [Decl],-			      opDecls     :: [Decl]-			     } deriving Show---- Generates initial partitions.-emptyPartitions = Partitions {importDecls = [],-			      typeDecls   = [],-			      funcDecls   = Map.empty,-			      opDecls     = []-			     } ------------------------------------------------------------------------------------- The following functions convert CurrySyntax terms to AbstractCurry--- terms.-----genImportDecl :: AbstractEnv -> Decl -> (String, AbstractEnv)-genImportDecl env (ImportDecl _ mid _ _ _) = (moduleName mid, env)------genTypeDecl :: AbstractEnv -> Decl -> (CTypeDecl, AbstractEnv)-genTypeDecl env (DataDecl _ ident params cdecls)-   = let (idxs, env1)    = mapfoldl genTVarIndex env params-	 (cdecls', env2) = mapfoldl genConsDecl env1 cdecls-     in  (CType (genQName True env2 (qualifyWith (moduleId env) ident))-	        (genVisibility env2 ident)-	        (zip idxs (map name params))-	        cdecls',-	  resetScope env2)-genTypeDecl env (TypeDecl _ ident params typeexpr)-   = let (idxs, env1)      = mapfoldl genTVarIndex env params-	 (typeexpr', env2) = genTypeExpr env1 typeexpr-     in  (CTypeSyn (genQName True env2 (qualifyWith (moduleId env) ident))-	           (genVisibility env2 ident)-	           (zip idxs (map name params))-	           typeexpr',-	  resetScope env2)-genTypeDecl env (NewtypeDecl pos ident _ _)-   = errorAt pos "'newtype' declarations are not supported in AbstractCurry"-genTypeDecl env _-   = internalError "unexpected declaration"------genConsDecl :: AbstractEnv -> ConstrDecl -> (CConsDecl, AbstractEnv)-genConsDecl env (ConstrDecl _ _ ident params)-   = let (params', env') = mapfoldl genTypeExpr env params-     in  (CCons (genQName False env' (qualifyWith (moduleId env) ident))-	        (length params)-	        (genVisibility env' ident)-	        params',-	  env')-genConsDecl env (ConOpDecl pos ids ltype ident rtype)-   = genConsDecl env (ConstrDecl pos ids ident [ltype, rtype])------genTypeExpr :: AbstractEnv -> TypeExpr -> (CTypeExpr, AbstractEnv)-genTypeExpr env (ConstructorType qident targs)-   = let (targs', env') = mapfoldl genTypeExpr env targs-     in  (CTCons (genQName True env' qident) targs', env')-genTypeExpr env (VariableType ident)-   | isJust midx = (CTVar (fromJust midx, name ident), env)-   | otherwise   = (CTVar (idx, name ident), env')- where-   midx        = getTVarIndex env ident-   (idx, env') = genTVarIndex env ident-genTypeExpr env (TupleType targs)-   | len > 1   = genTypeExpr env (ConstructorType (qTupleId len) targs)-   | len == 0  = genTypeExpr env (ConstructorType qUnitId targs)-   | len == 1  = genTypeExpr env (head targs)- where len = length targs-genTypeExpr env (ListType typeexpr)-   = genTypeExpr env (ConstructorType qListId [typeexpr])-genTypeExpr env (ArrowType texpr1 texpr2)-   = let (texpr1', env1) = genTypeExpr env texpr1-	 (texpr2', env2) = genTypeExpr env1 texpr2-     in  (CFuncType texpr1' texpr2', env2)-genTypeExpr env (RecordType fss mr)-   = let fs = concatMap (\ (ls,typeexpr) -> map (\l -> (l,typeexpr)) ls) fss-         (ls,ts) = unzip fs-         (ts',env1) = mapfoldl genTypeExpr env ts-         ls' = map name ls-     in case mr of-           Nothing-             -> (CRecordType (zip ls' ts') Nothing, env1)-           Just tvar@(VariableType _)-             -> let (CTVar iname, env2) = genTypeExpr env1 tvar-                in  (CRecordType (zip ls' ts') (Just iname), env2)-           (Just r@(RecordType _ _))-             -> let (CRecordType fields rbase, env2) = genTypeExpr env1 r-		    fields' = foldr (uncurry insertEntry) -				    fields-			            (zip ls' ts')-		in  (CRecordType fields' rbase, env2)-           _ -> internalError "illegal record base"----- NOTE: every infix declaration must declare exactly one operator.-genOpDecl :: AbstractEnv -> Decl -> (COpDecl, AbstractEnv)-genOpDecl env (InfixDecl _ fix prec [ident])-   = (COp (genQName False env (qualifyWith (moduleId env) ident))-          (genFixity fix)-          (fromInteger prec),-      env)------genFixity :: Infix -> CFixity-genFixity InfixL = CInfixlOp-genFixity InfixR = CInfixrOp-genFixity Infix  = CInfixOp----- Generate an AbstractCurry function declaration from a list of CurrySyntax--- function declarations.--- NOTES: ---   - every declaration in 'decls' must declare exactly one function.---   - since infered types are internally represented in flat style,---     all type variables are renamed with generated symbols when---     generating typed AbstractCurry.-genFuncDecl :: Bool -> AbstractEnv -> Ident -> [Decl] -> (AbstractEnv, CFuncDecl)-genFuncDecl isLocal env ident decls-   | not (null decls)-     = let name          = genQName False env (qualify ident)-	   visibility    = genVisibility env ident-           evalannot     = maybe CFlex -	                         (\ (EvalAnnot _ _ ea) -> genEvalAnnot ea)-				 (find isEvalAnnot decls)-           (mtype, env1) = maybe (Nothing, env) -                                 (\ (t, env') -> (Just t, env'))-				 (genFuncType env decls)-	   (rules, env2) = maybe ([], env1)-			         (\ (FunctionDecl _ _ equs)-				  -> mapfoldl genRule env1 equs)-				 (find isFunctionDecl decls)-           mexternal     = fmap genExternal (find isExternal decls)-	   arity         = compArity mtype rules-           typeexpr      = fromMaybe (CTCons ("Prelude","untyped") []) mtype-           rule          = compRule evalannot rules mexternal-           env3          = if isLocal then env1 else resetScope env2-       in  (env3, CFunc name arity visibility typeexpr rule)-   | otherwise-     = internalError ("missing declaration for function \""-		      ++ show ident ++ "\"")- where-   genFuncType env decls-      | acytype == UntypedAcy-	= fmap (genTypeSig env) (find isTypeSig decls)-      | acytype == TypedAcy-	= fmap (genTypeExpr env) mftype-      | otherwise -	= Nothing-    where -    acytype = acyType env-    mftype  | isLocal   -	      = lookupType ident (typeEnv env)-	    | otherwise -	      = qualLookupType (qualifyWith (moduleId env) ident)-	                       (typeEnv env)--   genTypeSig env (TypeSig _ _ ts)          = genTypeExpr env ts-   genTypeSig env (ExternalDecl _ _ _ _ ts) = genTypeExpr env ts--   genExternal (ExternalDecl _ _ mname ident _)-      = CExternal (fromMaybe (name ident) mname)-   genExternal (FlatExternalDecl _ [ident])-      = CExternal (name ident)-   genExternal _-      = internalError "illegal external declaration occured"--   compArity mtypeexpr rules-      | not (null rules)-        = let (CRule patts _ _) = head rules in length patts-      | otherwise-        = maybe (internalError ("unable to compute arity for function \""-				++ show ident ++ "\""))-	        compArityFromType-		mtypeexpr--   compArityFromType (CTVar _)        = 0-   compArityFromType (CFuncType _ t2) = 1 + compArityFromType t2-   compArityFromType (CTCons _ _)     = 0--   compRule evalannot rules mexternal-      | not (null rules) = CRules evalannot rules-      | otherwise-	= fromMaybe (internalError ("missing rule for function \""-				    ++ show ident ++ "\""))-	            mexternal------genRule :: AbstractEnv -> Equation -> (CRule, AbstractEnv)-genRule env (Equation pos lhs rhs)-   = let (patts, env1)  = mapfoldl (genPattern pos)-			           (beginScope env) -				   (simplifyLhs lhs)-	 (locals, env2) = genLocalDecls env1 (simplifyRhsLocals rhs)-	 (crhss, env3)  = mapfoldl (genCrhs pos) env2 (simplifyRhsExpr rhs)-     in  (CRule patts crhss locals, endScope env3)------genCrhs :: Position -> AbstractEnv -> (Expression, Expression) -           -> ((CExpr, CExpr), AbstractEnv)-genCrhs pos env (cond, expr)-   = let (cond', env1) = genExpr pos env cond-	 (expr', env2) = genExpr pos env1 expr-     in  ((cond', expr'), env2)----- NOTE: guarded expressions and 'where' declarations in local pattern--- declarations are not supported in PAKCS-genLocalDecls :: AbstractEnv -> [Decl] -> ([CLocalDecl], AbstractEnv)-genLocalDecls env decls-   = genLocals (foldl genLocalIndex env decls)-               (funcDecls (foldl partitionDecl emptyPartitions decls))-	       decls- where-   genLocalIndex env (PatternDecl _ constr _)-      = genLocalPatternIndex env constr-   genLocalIndex env (ExtraVariables _ idents)-      = let (_, env') = mapfoldl genVarIndex env idents-	in  env'-   genLocalIndex env _-       = env--   genLocalPatternIndex env (VariablePattern ident)-      = snd (genVarIndex env ident)-   genLocalPatternIndex env (ConstructorPattern _ args)-      = foldl genLocalPatternIndex env args-   genLocalPatternIndex env (InfixPattern c1 _ c2)-      = foldl genLocalPatternIndex env [c1,c2]-   genLocalPatternIndex env (ParenPattern c)-      = genLocalPatternIndex env c-   genLocalPatternIndex env (TuplePattern _ args)-      = foldl genLocalPatternIndex env args-   genLocalPatternIndex env (ListPattern _ args)-      = foldl genLocalPatternIndex env args-   genLocalPatternIndex env (AsPattern ident c)-      = genLocalPatternIndex (snd (genVarIndex env ident)) c-   genLocalPatternIndex env (LazyPattern _ c)-      = genLocalPatternIndex env c-   genLocalPatternIndex env (RecordPattern fields mc)-      = let env' = foldl genLocalPatternIndex env (map fieldTerm fields)-        in  maybe env' (genLocalPatternIndex env') mc-   genLocalPatternIndex env _-      = env--   -- The association list 'fdecls' is necessary because function-   -- rules may not be together in the declaration list-   genLocals :: AbstractEnv -> Map.Map Ident [Decl] -> [Decl] -	        -> ([CLocalDecl], AbstractEnv)-   genLocals env _ [] = ([], env)-   genLocals env fdecls ((FunctionDecl _ ident _):decls)-      = let (funcdecl, env1) = genLocalFuncDecl (beginScope env) fdecls ident-	    (locals, env2)   = genLocals (endScope env1) fdecls decls-        in  (funcdecl:locals, env2)-   genLocals env fdecls ((ExternalDecl _ _ _ ident _):decls)-      = let (funcdecl, env1) = genLocalFuncDecl (beginScope env) fdecls ident-	    (locals, env2)   = genLocals (endScope env1) fdecls decls-        in  (funcdecl:locals, env2)-   genLocals env fdecls ((FlatExternalDecl pos idents):decls)-      | null idents = genLocals env fdecls decls-      | otherwise -        = let (funcdecl, env1) -		= genLocalFuncDecl (beginScope env) fdecls (head idents)-	      (locals, env2) -		= genLocals (endScope env1)-		            fdecls -			    (FlatExternalDecl pos (tail idents):decls)-          in  (funcdecl:locals, env2)-   genLocals env fdecls (PatternDecl pos constr rhs : decls)-      = let (patt, env1)    = genLocalPattern pos env constr-	    (plocals, env2) = genLocalDecls (beginScope env1) -			                    (simplifyRhsLocals rhs)-	    (expr, env3)    = genLocalPattRhs pos env2 (simplifyRhsExpr rhs)-	    (locals, env4)  = genLocals (endScope env3) fdecls decls-	in  (CLocalPat patt expr plocals:locals, env4)-   genLocals env fdecls ((ExtraVariables pos idents):decls)-      | null idents  = genLocals env fdecls decls-      | otherwise-        = let ident  = head idents-	      idx    = fromMaybe -		         (internalError ("cannot find index"-					 ++ " for free variable \""-					 ++ show ident ++ "\""))-		         (getVarIndex env ident)-	      decls' = ExtraVariables pos (tail idents) : decls-	      (locals, env') = genLocals env fdecls decls'-          in (CLocalVar (idx, name ident) : locals, env')-   genLocals env fdecls ((TypeSig _ _ _):decls)-      = genLocals env fdecls decls-   genLocals _ _ decl = internalError ("unexpected local declaration: \n"-				       ++ show (head decl))--   genLocalFuncDecl :: AbstractEnv -> Map.Map Ident [Decl] -> Ident -		       -> (CLocalDecl, AbstractEnv)-   genLocalFuncDecl env fdecls ident-      = let fdecl = fromMaybe -		      (internalError ("missing declaration" -				      ++ " for local function \""-				      ++ show ident ++ "\""))-		      (Map.lookup ident fdecls)-	    (_, funcdecl) = genFuncDecl True env ident fdecl-        in  (CLocalFunc funcdecl, env)--   genLocalPattern pos env (LiteralPattern lit)-      = case lit of-       String _ cs -         -> genLocalPattern pos env -                 (ListPattern [] (map (LiteralPattern . Char noRef) cs))-       _ -> (CPLit (genLiteral lit), env)-   genLocalPattern pos env (VariablePattern ident)-      = let idx = fromMaybe -		     (internalError ("cannot find index"-				    ++ " for pattern variable \""-				    ++ show ident ++ "\""))-		     (getVarIndex env ident)   -        in  (CPVar (idx, name ident), env)-   genLocalPattern pos env (ConstructorPattern qident args)-      = let (args', env') = mapfoldl (genLocalPattern pos) env args-	in (CPComb (genQName False env qident) args', env')-   genLocalPattern pos env (InfixPattern larg qident rarg)-      = genLocalPattern pos env (ConstructorPattern qident [larg, rarg])-   genLocalPattern pos env (ParenPattern patt)-      = genLocalPattern pos env patt-   genLocalPattern pos env (TuplePattern _ args)-      | len > 1  -        = genLocalPattern pos env (ConstructorPattern (qTupleId len) args)-      | len == 1-	= genLocalPattern pos env (head args)-      | len == 0-	= genLocalPattern pos env (ConstructorPattern qUnitId [])-    where len = length args-   genLocalPattern pos env (ListPattern _ args)-      = genLocalPattern pos env -	  (foldr (\p1 p2 -> ConstructorPattern qConsId [p1,p2])-	   (ConstructorPattern qNilId [])-	   args)-   genLocalPattern pos _ (NegativePattern _ _)-      = errorAt pos "negative patterns are not supported in AbstractCurry"-   genLocalPattern pos env (AsPattern ident cterm)-      = let (patt, env1) = genLocalPattern pos env cterm-	    idx          = fromMaybe -			      (internalError ("cannot find index"-					      ++ " for alias variable \""-					      ++ show ident ++ "\""))-			      (getVarIndex env1 ident)-        in  (CPAs (idx, name ident) patt, env1)-   genLocalPattern pos env (LazyPattern _ cterm)-      = let (patt, env') = genLocalPattern pos env cterm-        in  (CPLazy patt, env')-   genLocalPattern pos env (RecordPattern fields mr)-      = let (fields', env1) = mapfoldl (genField genLocalPattern) env fields-	    (mr', env2)-		= maybe (Nothing, env1)-		        (applyFst Just . genLocalPattern pos env1)-			mr-	in  (CPRecord fields' mr', env2)--   genLocalPattRhs pos env [(Variable qSuccessFunId, expr)]-      = genExpr pos env expr-   genLocalPattRhs pos _ _-      = errorAt pos ("guarded expressions in pattern declarations"-		     ++ " are not supported in AbstractCurry")------genExpr :: Position -> AbstractEnv -> Expression -> (CExpr, AbstractEnv)-genExpr pos env (Literal lit)-   = case lit of-       String _ cs -> genExpr pos env (List [] (map (Literal . Char noRef) cs))-       _           -> (CLit (genLiteral lit), env)-genExpr _ env (Variable qident)-   | isJust midx          = (CVar (fromJust midx, name ident), env)-   | qident == qSuccessId = (CSymbol (genQName False env qSuccessFunId), env)-   | otherwise            = (CSymbol (genQName False env qident), env)- where-   ident = unqualify qident-   midx  = getVarIndex env ident-genExpr _ env (Constructor qident)-   = (CSymbol (genQName False env qident), env)-genExpr pos env (Paren expr)-   = genExpr pos env expr-genExpr pos env (Typed expr _)-   = genExpr pos env expr-genExpr pos env (Tuple _ args)-   | len > 1-     = genExpr pos env (foldl Apply (Variable (qTupleId (length args))) args)-   | len == 1-     = genExpr pos env (head args)-   | len == 0-     = genExpr pos env (Variable qUnitId)- where len = length args-genExpr pos env (List _ args)-   = let cons = Constructor qConsId-	 nil  = Constructor qNilId-     in  genExpr pos env (foldr (Apply . Apply cons) nil args)-genExpr pos env (ListCompr _ expr stmts)-   = let (stmts', env1) = mapfoldl (genStatement pos) (beginScope env) stmts-	 (expr', env2)  = genExpr pos env1 expr-     in  (CListComp expr' stmts', endScope env2)-genExpr pos env (EnumFrom expr)-   = genExpr pos env (Apply (Variable qEnumFromId) expr)-genExpr pos env (EnumFromThen expr1 expr2)-   = genExpr pos env (Apply (Apply (Variable qEnumFromThenId) expr1) expr2)-genExpr pos env (EnumFromTo expr1 expr2)-   = genExpr pos env (Apply (Apply (Variable qEnumFromToId) expr1) expr2)-genExpr pos env (EnumFromThenTo expr1 expr2 expr3)-   = genExpr pos env (Apply (Apply (Apply (Variable qEnumFromThenToId) -				    expr1) expr2) expr3)-genExpr pos env (UnaryMinus _ expr)-   = genExpr pos env (Apply (Variable qNegateId) expr)-genExpr pos env (Apply expr1 expr2)-   = let (expr1', env1) = genExpr pos env expr1-	 (expr2', env2) = genExpr pos env1 expr2-     in  (CApply expr1' expr2', env2)-genExpr pos env (InfixApply expr1 op expr2)-   = genExpr pos env (Apply (Apply (opToExpr op) expr1) expr2)-genExpr pos env (LeftSection expr op)-   = let ident  = freshVar env "x"-	 patt   = VariablePattern ident-	 var    = Variable (qualify ident)-	 applic = Apply (Apply (opToExpr op) expr) var -     in  genExpr pos env (Lambda noRef [patt] applic)-genExpr pos env (RightSection op expr)-   = let ident  = freshVar env "x"-	 patt   = VariablePattern ident-	 var    = Variable (qualify ident)-	 applic = Apply (Apply (opToExpr op) var) expr -     in  genExpr pos env (Lambda noRef [patt] applic)-genExpr pos env (Lambda _ params expr)-   = let (params', env1) = mapfoldl (genPattern pos) (beginScope env) params-	 (expr', env2)   = genExpr pos env1 expr-     in  (CLambda params' expr', endScope env2)-genExpr pos env (Let decls expr)-   = let (decls', env1) = genLocalDecls (beginScope env) decls-	 (expr', env2)  = genExpr pos env1 expr-     in  (CLetDecl decls' expr', endScope env2)-genExpr pos env (Do stmts expr)-   = let (stmts', env1) = mapfoldl (genStatement pos) (beginScope env) stmts-	 (expr', env2)  = genExpr pos env1 expr-     in  (CDoExpr (stmts' ++ [CSExpr expr']), endScope env2)-genExpr pos env (IfThenElse _ expr1 expr2 expr3)-   = genExpr pos env (Apply (Apply (Apply (Variable qIfThenElseId)-				    expr1) expr2) expr3)-genExpr pos env (Case _ expr alts)-   = let (expr', env1) = genExpr pos env expr-	 (alts', env2) = mapfoldl genBranchExpr env1 alts-     in  (CCase expr' alts', env2)-genExpr pos env (RecordConstr fields)-   = let (fields', env1) = mapfoldl (genField genExpr) env fields-     in  (CRecConstr fields', env1)-genExpr pos env (RecordSelection expr label)-   = let (expr', env1) = genExpr pos env expr-     in  (CRecSelect expr' (name label), env1)-genExpr pos env (RecordUpdate fields expr)-   = let (fields', env1) = mapfoldl (genField genExpr) env fields-         (expr', env2)   = genExpr pos env1 expr-     in  (CRecUpdate fields' expr', env2)------genStatement :: Position -> AbstractEnv -> Statement -	        -> (CStatement, AbstractEnv)-genStatement pos env (StmtExpr _ expr)-   = let (expr', env') = genExpr pos env expr-     in  (CSExpr expr', env')-genStatement _ env (StmtDecl decls)-   = let (decls', env') = genLocalDecls env decls-     in  (CSLet decls', env')-genStatement pos env (StmtBind _ patt expr)-   = let (expr', env1) = genExpr pos env expr-	 (patt', env2) = genPattern pos env1 patt-     in  (CSPat patt' expr', env2)----- NOTE: guarded expressions and local declarations in case branches--- are not supported in PAKCS-genBranchExpr :: AbstractEnv -> Alt -> (CBranchExpr, AbstractEnv)-genBranchExpr env (Alt pos patt rhs)-   = let (patt', env1) = genPattern pos (beginScope env) patt-	 (expr', env2) = genBranchRhs pos env1 (simplifyRhsExpr rhs)-     in  (CBranch patt' expr', endScope env2)- where-   genBranchRhs pos env [(Variable qSuccessFunId, expr)]-      = genExpr pos env expr-   genBranchRhs pos _ _-      = errorAt pos ("guarded expressions in case alternatives"-		     ++ " are not supported in AbstractCurry")------genPattern :: Position -> AbstractEnv -> ConstrTerm -> (CPattern, AbstractEnv)-genPattern pos env (LiteralPattern lit)-   = case lit of-       String _ cs -         -> genPattern pos env (ListPattern [] (map (LiteralPattern . Char noRef) cs))-       _ -> (CPLit (genLiteral lit), env)-genPattern _ env (VariablePattern ident)-   = let (idx, env') = genVarIndex env ident-     in  (CPVar (idx, name ident), env')-genPattern pos env (ConstructorPattern qident args)-   = let (args', env') = mapfoldl (genPattern pos) env args-     in  (CPComb (genQName False env qident) args', env')-genPattern pos env (InfixPattern larg qident rarg)-   = genPattern pos env (ConstructorPattern qident [larg, rarg])-genPattern pos env (ParenPattern patt)-   = genPattern pos env patt-genPattern pos env (TuplePattern _ args)-   | len > 1-     = genPattern pos env (ConstructorPattern (qTupleId len) args)-   | len == 1-     = genPattern pos env (head args)-   | len == 0-     = genPattern pos env (ConstructorPattern qUnitId [])- where len = length args-genPattern pos env (ListPattern _ args)-   = genPattern pos env (foldr (\x1 x2 -> ConstructorPattern qConsId [x1, x2]) -		         (ConstructorPattern qNilId []) -		         args)-genPattern pos _ (NegativePattern _ _)-   = errorAt pos "negative patterns are not supported in AbstractCurry"-genPattern pos env (AsPattern ident cterm)-   = let (patt, env1) = genPattern pos env cterm-	 (idx, env2) = genVarIndex env1 ident-     in  (CPAs (idx, name ident) patt, env2)-genPattern pos env (LazyPattern _ cterm)-   = let (patt, env') = genPattern pos env cterm-     in  (CPLazy patt, env')-genPattern pos env (FunctionPattern qident cterms)-   = let (patts, env') = mapfoldl (genPattern pos) env cterms-     in  (CPFuncComb (genQName False env qident) patts, env')-genPattern pos env (InfixFuncPattern cterm1 qident cterm2)-   = genPattern pos env (FunctionPattern qident [cterm1, cterm2])-genPattern pos env (RecordPattern fields mr)-   = let (fields', env1) = mapfoldl (genField genPattern) env fields-         (mr', env2)     = maybe (Nothing, env1)-                                 (applyFst Just . genPattern pos env1)-				 mr-     in  (CPRecord fields' mr', env2)------genField :: (Position -> AbstractEnv -> a -> (b, AbstractEnv))-	 -> AbstractEnv -> Field a -> (CField b, AbstractEnv)-genField genTerm env (Field pos label term)-   = let (term',env1) = genTerm pos env term-     in  ((name label, term'), env1)-----genLiteral :: Literal -> CLiteral-genLiteral (Char _ c)  = CCharc c-genLiteral (Int _ i)   = CIntc i-genLiteral (Float _ f) = CFloatc f-genLiteral _           = internalError "unsupported literal"----- Notes: --- - Some prelude identifiers are not quialified. The first check ensures---   that they get a correct qualifier.--- - The test for unqualified identifiers is necessary to qualify---   them correctly in the untyped AbstractCurry representation.-genQName :: Bool -> AbstractEnv -> QualIdent -> QName-genQName isTypeCons env qident-   | isPreludeSymbol qident-     = genQualName (qualQualify preludeMIdent qident)-   | not (isQualified qident)-     = genQualName (getQualIdent (unqualify qident))-   | otherwise-     = genQualName qident- where-  genQualName qid-     = let (mmid, id) = (qualidMod qid, qualidId qid)-	   mid = maybe (moduleId env)-		       (\mid' -> fromMaybe mid' (Map.lookup mid' (imports env)))-		       mmid-       in  (moduleName mid, name id)--  getQualIdent id-     | isTypeCons = case (lookupTC id (tconsEnv env)) of-		      --[DataType qid _ _] -> qid-		      --[RenamingType qid _ _] -> qid-		      --[AliasType qid _ _] -> qid-		      [info] -> origName info-		      _ ->  qualifyWith (moduleId env) id-     | otherwise  = case (lookupValue id (typeEnv env)) of-		      --[DataConstructor qid _] -> qid-		      --[NewtypeConstructor qid _] -> qid-		      --[Value qid _] -> qid-		      [info] -> origName info-		      _ -> qualifyWith (moduleId env) id-		      ------genVisibility :: AbstractEnv -> Ident -> CVisibility-genVisibility env ident-   | isExported env ident = Public-   | otherwise            = Private------genEvalAnnot :: EvalAnnotation -> CEvalAnnot-genEvalAnnot EvalRigid  = CRigid-genEvalAnnot EvalChoice = CChoice------------------------------------------------------------------------------------- This part defines an environment containing all necessary information--- for generating the AbstractCurry representation of a CurrySyntax term.---- Data type for representing an AbstractCurry generator environment.------    moduleName  - name of the module---    typeEnv     - table of all known types---    exports     - table of all exported symbols from the module---    imports     - table of import aliases---    varIndex    - index counter for generating variable indices---    tvarIndex   - index counter for generating type variable indices---    varScope    - stack of variable tables---    tvarScope   - stack of type variable tables---    acyType     - type of AbstractCurry code to be generated-data AbstractEnv = AbstractEnv {moduleId   :: ModuleIdent,-				typeEnv    :: ValueEnv,-				tconsEnv   :: TCEnv,-				exports    :: Set.Set Ident,-				imports    :: Map.Map ModuleIdent ModuleIdent,-				varIndex   :: Int,-				tvarIndex  :: Int,-				varScope   :: [Map.Map Ident Int],-				tvarScope  :: [Map.Map Ident Int],-                                acyType    :: AbstractType-			       } deriving Show---- Data type representing the type of AbstractCurry code to be generated--- (typed infered or untyped (i.e. type signated))-data AbstractType = TypedAcy | UntypedAcy deriving (Eq, Show)----- Initializes the AbstractCurry generator environment.-genAbstractEnv :: AbstractType -> ValueEnv -> TCEnv -> Module -> AbstractEnv-genAbstractEnv absType tyEnv tcEnv (Module mid exps decls)-   = AbstractEnv -       {moduleId     = mid,-	typeEnv      = tyEnv,-	tconsEnv     = tcEnv,-	exports      = foldl (buildExportTable mid decls) Set.empty exps',-	imports      = foldl buildImportTable Map.empty decls,-	varIndex     = 0,-	tvarIndex    = 0,-	varScope     = [Map.empty],-	tvarScope    = [Map.empty],-        acyType      = absType-       }- where-   exps' = maybe (buildExports mid decls) (\ (Exporting _ es) -> es) exps----- Generates a list of exports for all specified top level declarations-buildExports :: ModuleIdent -> [Decl] -> [Export]-buildExports _ [] = []-buildExports mid (DataDecl _ ident _ _:ds) -   = ExportTypeAll (qualifyWith mid ident) : buildExports mid ds-buildExports mid ((NewtypeDecl _ ident _ _):ds)-   = ExportTypeAll (qualifyWith mid ident) : buildExports mid ds-buildExports mid ((TypeDecl _ ident _ _):ds)-   = Export (qualifyWith mid ident) : buildExports mid ds-buildExports mid ((FunctionDecl _ ident _):ds)-   = Export (qualifyWith mid ident) : buildExports mid ds-buildExports mid (ExternalDecl _ _ _ ident _ : ds)-   = Export (qualifyWith mid ident) : buildExports mid ds-buildExports mid (FlatExternalDecl _ idents : ds)-   = map (Export . qualifyWith mid) idents ++ buildExports mid ds-buildExports mid (_:ds) = buildExports mid ds----- Builds a table containing all exported (i.e. public) identifiers--- from a module.-buildExportTable :: ModuleIdent -> [Decl] -> Set.Set Ident -> Export -                 -> Set.Set Ident-buildExportTable mid _ exptab (Export qident)-   | isJust (localIdent mid qident)-     = insertExportedIdent exptab (unqualify qident)-   | otherwise = exptab-buildExportTable mid _ exptab (ExportTypeWith qident ids)-   | isJust (localIdent mid qident)-     = foldl insertExportedIdent -             (insertExportedIdent exptab (unqualify qident))-             ids-   | otherwise  = exptab-buildExportTable mid decls exptab (ExportTypeAll qident)-   | isJust ident'-     = foldl insertExportedIdent-             (insertExportedIdent exptab ident)-             (maybe [] getConstrIdents (find (isDataDeclOf ident) decls))-   | otherwise = exptab- where -   ident' = localIdent mid qident-   ident  = fromJust ident'-buildExportTable _ _ exptab (ExportModule _) = exptab-----insertExportedIdent :: Set.Set Ident -> Ident -> Set.Set Ident-insertExportedIdent env ident = Set.insert ident env-----getConstrIdents :: Decl -> [Ident]-getConstrIdents (DataDecl _ _ _ constrs)-   = map getConstrIdent constrs- where-   getConstrIdent (ConstrDecl _ _ ident _)  = ident-   getConstrIdent (ConOpDecl _ _ _ ident _) = ident----- Builds a table for dereferencing import aliases-buildImportTable :: Map.Map ModuleIdent ModuleIdent -> Decl-		    -> Map.Map ModuleIdent ModuleIdent-buildImportTable env (ImportDecl _ mid _ malias _)-   = Map.insert (fromMaybe mid malias) mid env-buildImportTable env _ = env----- Checks whether an identifier is exported or not.-isExported :: AbstractEnv -> Ident -> Bool-isExported env ident = Set.member ident (exports env)----- Generates an unique index for the  variable 'ident' and inserts it--- into the  variable table of the current scope.-genVarIndex :: AbstractEnv -> Ident -> (Int, AbstractEnv)-genVarIndex env ident -   = let idx   = varIndex env-         vtabs = varScope env-	 vtab  = head vtabs --if null vtabs then Map.empty else head vtabs-     in  (idx, env {varIndex = idx + 1,-		    varScope = Map.insert ident idx vtab : sureTail vtabs})---- Generates an unique index for the type variable 'ident' and inserts it--- into the type variable table of the current scope.-genTVarIndex :: AbstractEnv -> Ident -> (Int, AbstractEnv)-genTVarIndex env ident-   = let idx   = tvarIndex env-         vtabs = tvarScope env-	 vtab  = head vtabs --if null vtabs then Map.empty else head vtabs-     in  (idx, env {tvarIndex = idx + 1,-		    tvarScope = Map.insert ident idx vtab : sureTail vtabs })----- Looks up the unique index for the variable 'ident' in the--- variable table of the current scope.-getVarIndex :: AbstractEnv -> Ident -> Maybe Int-getVarIndex env ident = Map.lookup ident (head (varScope env))---- Looks up the unique index for the type variable 'ident' in the type--- variable table of the current scope.-getTVarIndex :: AbstractEnv -> Ident -> Maybe Int-getTVarIndex env ident = Map.lookup ident (head (tvarScope env))----- Generates an indentifier which doesn't occur in the variable table--- of the current scope.-freshVar :: AbstractEnv -> String -> Ident-freshVar env name = genFreshVar env name 0- where-   genFreshVar env name idx-      | isJust (getVarIndex env ident)-         = genFreshVar env name (idx + 1)-      | otherwise -         = ident-    where ident = mkIdent (name ++ show idx)---- Sets the index counter back to zero and deletes all stack entries.-resetScope :: AbstractEnv -> AbstractEnv-resetScope env = env {varIndex  = 0,-		      tvarIndex = 0,-		      varScope  = [Map.empty],-		      tvarScope = [Map.empty]}---- Starts a new scope, i.e. copies and pushes the variable table of the current --- scope onto the top of the stack-beginScope :: AbstractEnv -> AbstractEnv-beginScope env = env {varScope  = head vs :vs,-		      tvarScope = head tvs :tvs }- where- vs  = varScope env- tvs = tvarScope env---- End the current scope, i.e. pops and deletes the variable table of the--- current scope from the top of the stack.-endScope :: AbstractEnv -> AbstractEnv-endScope env = env {varScope  = if oneElement vs then vs else tail vs,-		    tvarScope = if oneElement tvs then tvs else tail tvs}- where- vs  = varScope env- tvs = tvarScope env------------------------------------------------------------------------------------- Miscellaneous...---- Some identifiers...-qEnumFromId       = qualifyWith preludeMIdent (mkIdent "enumFrom")-qEnumFromThenId   = qualifyWith preludeMIdent (mkIdent "enumFromThen")-qEnumFromToId     = qualifyWith preludeMIdent (mkIdent "enumFromTo")-qEnumFromThenToId = qualifyWith preludeMIdent (mkIdent "enumFromThenTo")-qNegateId         = qualifyWith preludeMIdent (mkIdent "negate")-qIfThenElseId     = qualifyWith preludeMIdent (mkIdent "if_then_else")-qSuccessFunId     = qualifyWith preludeMIdent (mkIdent "success")----- The following functions check whether a declaration is of a certain kind-isFunctionDecl :: Decl -> Bool-isFunctionDecl (FunctionDecl _ _ _) = True-isFunctionDecl _                    = False--isExternal :: Decl -> Bool-isExternal (ExternalDecl _ _ _ _ _) = True-isExternal (FlatExternalDecl _ _)   = True-isExternal _                        = False----- Checks, whether a declaration is the data declaration of 'ident'.-isDataDeclOf :: Ident -> Decl -> Bool-isDataDeclOf ident (DataDecl _ ident' _ _) -   = ident == ident'-isDataDeclOf _ _  -   = False----- Checks, whether a symbol is defined in the Prelude.-isPreludeSymbol :: QualIdent -> Bool-isPreludeSymbol qident-   = let (mmid, ident) = (qualidMod qident, qualidId qident)-     in  (isJust mmid && preludeMIdent == fromJust mmid)-         || elem ident [unitId, listId, nilId, consId]-	 || isTupleId ident----- Converts an infix operator to an expression-opToExpr :: InfixOp -> Expression-opToExpr (InfixOp qident)     = Variable qident-opToExpr (InfixConstr qident) = Constructor qident----- Looks up the type of a qualified symbol in the type environment and--- converts it to a CurrySyntax type term.-qualLookupType :: QualIdent -> ValueEnv -> Maybe TypeExpr-qualLookupType qident tyEnv-   = case (qualLookupValue qident tyEnv) of-       [Value _ ts] -> (\ (ForAll _ ty) -> Just (fromType ty)) ts-       _            -> Nothing---- Looks up the type of a symbol in the type environment and--- converts it to a CurrySyntax type term.-lookupType :: Ident -> ValueEnv -> Maybe TypeExpr-lookupType ident tyEnv-   = case (lookupValue ident tyEnv) of-       [Value _ ts] -> (\ (ForAll _ ty) -> Just (fromType ty)) ts-       _            -> Nothing----- The following functions transform left-hand-side and right-hand-side terms--- for a better handling-simplifyLhs :: Lhs -> [ConstrTerm]-simplifyLhs = snd . flatLhs--simplifyRhsExpr :: Rhs -> [(Expression, Expression)]-simplifyRhsExpr (SimpleRhs _ expr _) -   = [(Variable qSuccessId, expr)]-simplifyRhsExpr (GuardedRhs crhs _)  -   = map (\ (CondExpr _ cond expr) -> (cond, expr)) crhs--simplifyRhsLocals :: Rhs -> [Decl]-simplifyRhsLocals (SimpleRhs _ _ locals) = locals-simplifyRhsLocals (GuardedRhs _ locals)  = locals----- FIXME This mapfold is a twisted mapAccumL--- A combination of 'map' and 'foldl'. It maps a function to a list--- from left to right while updating the argument 'e' continously.-mapfoldl :: (a -> b -> (c,a)) -> a -> [b] -> ([c], a)-mapfoldl _ e []     = ([], e)-mapfoldl f e (x:xs) = let (x', e')   = f e x-                          (xs', e'') = mapfoldl f e' xs-                      in  (x':xs', e'')---- Inserts an element under a key into an association list-insertEntry :: Eq a => a -> b -> [(a,b)] -> [(a,b)]-insertEntry k e [] = [(k,e)]-insertEntry k e ((x,y):xys)-   | k == x    = (k,e):xys-   | otherwise = (x,y) : insertEntry k e xys----- Returns the list without the first element. If the list is empty, an--- empty list will be returned.-sureTail :: [a] -> [a]-sureTail []     = []-sureTail (_:xs) = xs----- Returns 'True', if a list contains exactly one element-oneElement :: [a] -> Bool-oneElement [_] = True-oneElement _   = False----- Applies 'f' on the first value in a tuple-applyFst :: (a -> c) -> (a,b) -> (c,b)-applyFst f (x,y) = (f x, y)-----------------------------------------------------------------------------------------------------------------------------------------------------------------
− src/GenFlatCurry.hs 
@@ -1,1153 +0,0 @@---------------------------------------------------------------------------------------------------------------------------------------------------------------------- GenFlatCurry - Generates FlatCurry program terms and FlatCurry interfaces---                (type 'FlatCurry.Prog')------ November 2005,--- Martin Engelke (men@informatik.uni-kiel.de)----module GenFlatCurry (genFlatCurry,-		     genFlatInterface) where---import Control.Monad.State-import Control.Monad-import Data.Maybe-import Data.List-import qualified Data.Map as Map---import Curry.Base.MessageMonad-import Curry.Base.Ident as Id--import qualified Curry.Syntax as CS--import Curry.ExtendedFlat.Type-import Curry.ExtendedFlat.TypeInference--import Curry.ExtendedFlat.EraseTypes--import Base--import qualified IL.Type as IL-import qualified IL.CurryToIL as IL--import TopEnv(topEnvMap)-import CurryEnv (CurryEnv)-import qualified CurryEnv-import ScopeEnv (ScopeEnv)-import qualified ScopeEnv-import Types-import CurryCompilerOpts-import PatchPrelude---import Debug.Trace-trace' _ x = x------------------------------------------------------------------------------------- transforms intermediate language code (IL) to FlatCurry code-genFlatCurry :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv -		-> ArityEnv -> IL.Module -> (Prog, [WarnMsg])-genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv mod-   = (prog', messages)- where (prog, messages) -           = run opts cEnv mEnv tyEnv tcEnv aEnv False (visitModule mod)-       prog' = -- eraseTypes $ -               adjustTypeInfo $ adjustTypeInfo $ patchPreludeFCY prog----- transforms intermediate language code (IL) to FlatCurry interfaces-genFlatInterface :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv-		 -> ArityEnv -> IL.Module -> (Prog, [WarnMsg])-genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv mod-   = (patchPreludeFCY intf, messages)- where (intf, messages) -	   = run opts cEnv mEnv tyEnv tcEnv aEnv True (visitModule mod)----------------------------------------------------------------------------------------------------------------------------------------------------------------------- The environment 'FlatEnv' is embedded in the monadic representation--- 'FlatState' which allows the usage of 'do' expressions.--type FlatState a = State FlatEnv a---- Data type for representing an environment which contains information needed--- for generating FlatCurry code.-data FlatEnv = FlatEnv{ moduleIdE     :: ModuleIdent,-			  functionIdE   :: (QualIdent, [(Ident, IL.Type)]),-			  compilerOptsE :: Options,-			  moduleEnvE    :: ModuleEnv,-			  arityEnvE     :: ArityEnv,-			  typeEnvE      :: ValueEnv,     -- types of defined values-			  tConsEnvE     :: TCEnv,-			  publicEnvE    :: Map.Map Ident IdentExport,-			  fixitiesE     :: [CS.IDecl],-			  typeSynonymsE :: [CS.IDecl],-			  importsE      :: [CS.IDecl],-			  exportsE      :: [CS.Export],-			  interfaceE    :: [CS.IDecl],-			  varIndexE     :: Int,-			  varIdsE       :: ScopeEnv Ident VarIndex,-			  tvarIndexE    :: Int,-			  messagesE     :: [WarnMsg],-			  genInterfaceE :: Bool,-                          localTypes    :: Map.Map QualIdent IL.Type,-                          constrTypes   :: Map.Map QualIdent IL.Type-			}--data IdentExport = NotConstr       -- function, type-constructor-                 | OnlyConstr      -- constructor-                 | NotOnlyConstr   -- constructor, function, type-constructor------- Runs a 'FlatState' action and returns the result-run :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv -> ArityEnv -    -> Bool -> FlatState a -> (a, [WarnMsg])-run opts cEnv mEnv tyEnv tcEnv aEnv genIntf f-   = (result, messagesE env)- where- (result, env) = runState f env0- env0 = FlatEnv{ moduleIdE     = CurryEnv.moduleId cEnv,-		 functionIdE   = (qualify (mkIdent ""), []),-		 compilerOptsE = opts,-		 moduleEnvE    = mEnv,-		 arityEnvE     = aEnv,-		 typeEnvE      = tyEnv,-		 tConsEnvE     = tcEnv,-		 publicEnvE    = genPubEnv (CurryEnv.moduleId cEnv)-		                 (CurryEnv.interface cEnv),-		 fixitiesE     = CurryEnv.infixDecls cEnv,-		 typeSynonymsE = CurryEnv.typeSynonyms cEnv,-		 importsE      = CurryEnv.imports cEnv,-		 exportsE      = CurryEnv.exports cEnv,-		 interfaceE    = CurryEnv.interface cEnv,-		 varIndexE     = 0,-		 varIdsE       = ScopeEnv.new,-		 tvarIndexE    =0,-		 messagesE      = [],-		 genInterfaceE = genIntf,-                 localTypes    = Map.empty,-                 constrTypes   = Map.fromList (getConstrTypes tcEnv)-	       }--getConstrTypes :: TCEnv -> [(QualIdent, IL.Type)]-getConstrTypes tcEnv = trace' (show tinfos) tinfos-    where tcList = Map.toList $ topEnvMap tcEnv-          tinfos = [ foo tqid conid argtypes targnum-                   | (_, (_, DataType tqid targnum dts):_) <- tcList-                   , Just (Data conid _ argtypes) <- dts]-          foo tqid conid argtypes targnum-              = let conname = QualIdent (qualidMod tqid) conid-                    resulttype = IL.TypeConstructor tqid (map IL.TypeVariable [0..targnum-1])-                    contype = foldr IL.TypeArrow resulttype (map ttrans argtypes)-                in (conname, contype)-              -----visitModule :: IL.Module -> FlatState Prog-visitModule (IL.Module mid imps decls) = do-  -- insert local decls into localDecls-  let ts = [ (qn, t) | IL.FunctionDecl qn _ t _ <- decls ]-  modify (\ s -> s {localTypes = Map.fromList ts})-  whenFlatCurry-       (do ops     <- genOpDecls-           datas   <- mapM visitDataDecl (filter isDataDecl decls)-	   types   <- genTypeSynonyms-	   records <- genRecordTypes-	   funcs   <- mapM visitFuncDecl (filter isFuncDecl decls)-	   mod     <- visitModuleIdent mid-	   imps'   <- imports-	   is      <- mapM visitModuleIdent -	                   (nub (imps ++ (map (\ (CS.IImportDecl _ mid) -					       -> mid) imps')))-           return (Prog mod is (records ++ types ++ datas) funcs ops))-       (do ops     <- genOpDecls-	   ds      <- filterM isPublicDataDecl decls-	   datas   <- mapM visitDataDecl ds-	   types   <- genTypeSynonyms-	   records <- genRecordTypes-	   fs      <- filterM isPublicFuncDecl decls-	   funcs   <- mapM visitFuncDecl fs-	   expimps <- getExportedImports-	   itypes  <- mapM visitTypeIDecl (filter isTypeIDecl expimps)-	   ifuncs  <- mapM visitFuncIDecl (filter isFuncIDecl expimps)-	   iops    <- mapM visitOpIDecl (filter isOpIDecl expimps)-	   mod     <- visitModuleIdent mid-	   imps'   <- imports-	   is      <- mapM visitModuleIdent -	                   (nub (imps ++ (map (\ (CS.IImportDecl _ mid) -					       -> mid) imps')))-	   return (Prog mod -		        is -		        (itypes ++ records ++ types ++ datas)-		        (ifuncs ++ funcs)-		        (iops ++ ops)))-----visitDataDecl :: IL.Decl -> FlatState TypeDecl-visitDataDecl (IL.DataDecl qident arity constrs)-   = do cdecls <- mapM visitConstrDecl constrs-	qname  <- visitQualTypeIdent qident-	vis    <- getVisibility False qident-	return (Type qname vis [0 .. (arity - 1)] (concat cdecls))-visitDataDecl _ = internalError "GenFlatCurry: no data declaration"-----visitConstrDecl :: IL.ConstrDecl [IL.Type] -> FlatState [ConsDecl]-visitConstrDecl (IL.ConstrDecl qident types)-   = do texprs <- mapM visitType types-	qname  <- visitQualIdent qident-	vis    <- getVisibility True qident-        genFint <- genInterface-        if genFint && vis == Private -          then return []-          else return [Cons qname (length types) vis texprs]-----visitType :: IL.Type -> FlatState TypeExpr-visitType (IL.TypeConstructor qident types)-   = do texprs <- mapM visitType types-	qname  <- visitQualTypeIdent qident-	if (qualName qident) == "Identity"-	   then return (head texprs)-	   else return (TCons qname texprs)-visitType (IL.TypeVariable index)-   = return (TVar (abs index))-visitType (IL.TypeArrow type1 type2)-   = do texpr1 <- visitType type1-	texpr2 <- visitType type2-	return (FuncType texpr1 texpr2)-----visitFuncDecl :: IL.Decl -> FlatState FuncDecl-visitFuncDecl (IL.FunctionDecl qident params typeexpr expression)-   = let argtypes = splitoffArgTypes typeexpr params -     in do setFunctionId (qident, argtypes)-           qname <- visitQualIdent qident-           whenFlatCurry (do is    <- mapM newVarIndex params-	                     texpr <- visitType typeexpr-	                     expr  <- visitExpression expression-	                     vis   <- getVisibility False qident-	                     clearVarIndices-	                     return (Func qname (length params) vis texpr (Rule is expr)))-                         (do texpr <- visitType typeexpr-	                     clearVarIndices-	                     return (Func qname (length params) Public texpr (Rule [] (Var $ mkIdx 0))))-visitFuncDecl (IL.ExternalDecl qident _ name typeexpr)-   = do setFunctionId (qident, [])-	texpr <- visitType typeexpr-	qname <- visitQualIdent qident-	vis   <- getVisibility False qident-	xname <- visitExternalName name-	return (Func qname (typeArity typeexpr) vis texpr (External xname))-visitFuncDecl (IL.NewtypeDecl _ _ _)-   = do mid <- moduleId -	error ("\"" ++ Id.moduleName mid -	       ++ "\": newtype declarations are not supported")-visitFuncDecl _ = internalError "GenFlatCurry: no function declaration"-----visitExpression :: IL.Expression -> FlatState Expr-visitExpression (IL.Literal literal)-   = liftM Lit (visitLiteral literal)-visitExpression (IL.Variable ident)-   = liftM Var (lookupVarIndex ident)-visitExpression (IL.Function qident _)-   = do arity_ <- lookupIdArity qident-        qname <- visitQualIdent qident-	maybe (internalError (funcArity qname))-	      (\arity -> genFuncCall qname arity [])-	      arity_-visitExpression (IL.Constructor qident arity)-   = do arity_ <- lookupIdArity qident-        qname <- visitQualIdent qident-	maybe (internalError (consArity qident))-	      (\arity -> genConsCall qname arity [])-	      arity_-visitExpression (IL.Apply e1 e2)-   = genFlatApplication e1 e2-visitExpression (IL.Case r evalannot expression alts)-   = do ea       <- visitEval evalannot-	expr     <- visitExpression expression-	branches <- mapM visitAlt alts-	return (Case r ea expr branches)-visitExpression (IL.Or expression1 expression2)-   = do expr1 <- visitExpression expression1-	expr2 <- visitExpression expression2-	checkOverlapping expr1 expr2-	return (Or expr1 expr2)-visitExpression (IL.Exist ident expression)-   = do index <- newVarIndex ident-	expr  <- visitExpression expression-	case expr of-	  Free is expr' -> return (Free (index:is) expr')-	  _             -> return (Free [index] expr)-visitExpression (IL.Let binding expression)-   = do beginScope-	newVarIndex (bindingIdent binding)-        bind <- visitBinding binding-	expr <- visitExpression expression-        -- is it correct that there is no endScope? (hsi)-        return (Let [bind] expr)-visitExpression (IL.Letrec bindings expression)-   = do beginScope-	mapM_ (newVarIndex . bindingIdent) bindings-	binds <- mapM visitBinding bindings-	expr  <- visitExpression expression-	endScope-	return (Let binds expr)------visitLiteral :: IL.Literal -> FlatState Literal-visitLiteral (IL.Char rs c)  = return (Charc rs c)-visitLiteral (IL.Int rs i)   = return (Intc rs i)-visitLiteral (IL.Float rs f) = return (Floatc rs f)-----visitAlt :: IL.Alt -> FlatState BranchExpr-visitAlt (IL.Alt cterm expression)-   = do patt <- visitConstrTerm cterm-	expr <- visitExpression expression-	return (Branch patt expr)-----visitConstrTerm :: IL.ConstrTerm -> FlatState Pattern-visitConstrTerm (IL.LiteralPattern literal)-   = do lit <- visitLiteral literal-	return (LPattern lit)-visitConstrTerm (IL.ConstructorPattern qident args)-   = do is    <- mapM newVarIndex args-	qname <- visitQualIdent qident-	return (Pattern qname is)-visitConstrTerm (IL.VariablePattern ident)-   = do mid <- moduleId-	error ("\"" ++ Id.moduleName mid -	       ++ "\": variable patterns are not supported")-----visitEval :: IL.Eval -> FlatState CaseType-visitEval IL.Rigid = return Rigid-visitEval IL.Flex  = return Flex-----visitBinding :: IL.Binding -> FlatState (VarIndex, Expr)-visitBinding (IL.Binding ident expression)-   = do index <- lookupVarIndex ident-	expr  <- visitExpression expression-	return (index, expr)---------------------------------------------------------------------------------------visitFuncIDecl :: CS.IDecl -> FlatState FuncDecl-visitFuncIDecl (CS.IFunctionDecl _ qident arity typeexpr)-   = do texpr <- visitType (fst (cs2ilType [] typeexpr))-	qname <- visitQualIdent qident-	return (Func qname arity Public texpr (Rule [] (Var $ mkIdx 0)))-visitFuncIDecl _ = internalError "GenFlatCurry: no function interface"-----visitTypeIDecl :: CS.IDecl -> FlatState TypeDecl-visitTypeIDecl (CS.IDataDecl _ qident params constrs_)-   = do let mid = fromMaybe (internalError "GenFlatCurry: no module name")-		            (qualidMod qident)-	    is  = [0 .. length params - 1]-	cdecls <- mapM (visitConstrIDecl mid (zip params is)) -		       (catMaybes constrs_)-	qname  <- visitQualTypeIdent qident-	return (Type qname Public is cdecls)-visitTypeIDecl (CS.ITypeDecl _ qident params typeexpr)-   = do let is = [0 .. (length params) - 1]-	texpr <- visitType (fst (cs2ilType (zip params is) typeexpr))-	qname <- visitQualTypeIdent qident-	return (TypeSyn qname Public is texpr)-visitTypeIDecl _ = internalError "GenFlatCurry: no type interface"-----visitConstrIDecl :: ModuleIdent -> [(Ident, Int)] -> CS.ConstrDecl -		    -> FlatState ConsDecl-visitConstrIDecl mid tis (CS.ConstrDecl _ _ ident typeexprs)-   = do texprs <- mapM (visitType . (fst . cs2ilType tis)) typeexprs-	qname  <- visitQualIdent (qualifyWith mid ident)-	return (Cons qname (length typeexprs) Public texprs)-visitConstrIDecl mid tis (CS.ConOpDecl pos ids type1 ident type2)-   = visitConstrIDecl mid tis (CS.ConstrDecl pos ids ident [type1,type2])-----visitOpIDecl :: CS.IDecl -> FlatState OpDecl-visitOpIDecl (CS.IInfixDecl _ fixity prec qident)-   = do let fix = case fixity of-	            CS.InfixL -> InfixlOp-		    CS.InfixR -> InfixrOp-		    _         -> InfixOp-        qname <- visitQualIdent qident-	return (Op qname fix prec)---------------------------------------------------------------------------------------visitModuleIdent :: ModuleIdent -> FlatState String-visitModuleIdent = return . Id.moduleName-----visitQualIdent :: QualIdent -> FlatState QName-visitQualIdent qident-   = do mid <- moduleId-	let (mmod, ident) = (qualidMod qident, qualidId qident)-	    mod | elem ident [listId, consId, nilId, unitId] || isTupleId ident-		  = Id.moduleName preludeMIdent-		| otherwise-		  = maybe (Id.moduleName mid) Id.moduleName mmod-        ftype <- lookupIdType qident-	return (QName Nothing ftype mod $ name ident)---- This variant of visitQualIdent does not look up the type of the identifier,--- which is wise when the identifier is bound to a type, because looking up--- the type of a type via lookupIdType will get stuck in an endless loop. (hsi)-visitQualTypeIdent :: QualIdent -> FlatState QName-visitQualTypeIdent qident-   = do mid <- moduleId-	let (mmod, ident) = (qualidMod qident, qualidId qident)-	    mod | elem ident [listId, consId, nilId, unitId] || isTupleId ident-		  = Id.moduleName preludeMIdent-		| otherwise-		  = maybe (Id.moduleName mid) Id.moduleName mmod-	return (QName Nothing Nothing mod $ name ident)-----visitExternalName :: String -> FlatState String-visitExternalName name -   = moduleId >>= \mid -> return (Id.moduleName mid ++ "." ++ name)-----------------------------------------------------------------------------------------------------------------------------------------------------------------------getVisibility :: Bool -> QualIdent -> FlatState Visibility-getVisibility isConstr qident-   = do public <- isPublic isConstr qident-	if public then return Public else return Private------getExportedImports :: FlatState [CS.IDecl]-getExportedImports-   = do mid  <- moduleId-	exps <- exports-	genExportedIDecls (Map.toList (getExpImports mid Map.empty exps))-----getExpImports :: ModuleIdent -> Map.Map ModuleIdent [CS.Export] -> [CS.Export]-		 -> Map.Map ModuleIdent [CS.Export]-getExpImports mident expenv [] = expenv-getExpImports mident expenv ((CS.Export qident):exps)-   = getExpImports mident -	           (bindExpImport mident qident (CS.Export qident) expenv) -		   exps-getExpImports mident expenv ((CS.ExportTypeWith qident idents):exps)-   = getExpImports mident -		   (bindExpImport mident -		                  qident -		                  (CS.ExportTypeWith qident idents) -		                  expenv)-		   exps-getExpImports mident expenv ((CS.ExportTypeAll qident):exps)-   = getExpImports mident -	 	   (bindExpImport mident qident (CS.ExportTypeAll qident) expenv) -		   exps-getExpImports mident expenv ((CS.ExportModule mident'):exps)-   = getExpImports mident (Map.insert mident' [] expenv) exps-----bindExpImport :: ModuleIdent -> QualIdent -> CS.Export -	         -> Map.Map ModuleIdent [CS.Export] -> Map.Map ModuleIdent [CS.Export]-bindExpImport mident qident export expenv-   | isJust (localIdent mident qident)-     = expenv-   | otherwise-     = let (Just mod) = qualidMod qident-       in  maybe (Map.insert mod [export] expenv)-	         (\es -> Map.insert mod (export:es) expenv) -		 (Map.lookup mod expenv)-----genExportedIDecls :: [(ModuleIdent,[CS.Export])] -> FlatState [CS.IDecl]-genExportedIDecls mes = genExpIDecls [] mes-----genExpIDecls :: [CS.IDecl] -> [(ModuleIdent,[CS.Export])] -> FlatState [CS.IDecl]-genExpIDecls idecls [] = return idecls-genExpIDecls idecls ((mid,exps):mes)-   = do intf_ <- lookupModuleIntf mid-	let idecls' = maybe idecls (p_genExpIDecls mid idecls exps) intf_-	genExpIDecls idecls' mes- where-   p_genExpIDecls mid idecls exps intf-      | null exps = (map (qualifyIDecl mid) intf) ++ idecls-      | otherwise = (filter (isExportedIDecl exps) -		            (map (qualifyIDecl mid) intf))-		    ++ idecls---- -isExportedIDecl :: [CS.Export] -> CS.IDecl -> Bool-isExportedIDecl exports (CS.IInfixDecl _ _ _ qident)-   = isExportedQualIdent qident exports-isExportedIDecl exports (CS.IDataDecl _ qident _ _)-   = isExportedQualIdent qident exports-isExportedIDecl exports (CS.ITypeDecl _ qident _ _)-   = isExportedQualIdent qident exports-isExportedIDecl exports (CS.IFunctionDecl _ qident _ _)-   = isExportedQualIdent qident exports-isExportedIDecl exports _-   = False-----isExportedQualIdent :: QualIdent -> [CS.Export] -> Bool-isExportedQualIdent qident [] = False-isExportedQualIdent qident ((CS.Export qident'):exps)-   = qident == qident' || isExportedQualIdent qident exps-isExportedQualIdent qident ((CS.ExportTypeWith qident' idents):exps)-   = qident == qident' || isExportedQualIdent qident exps-isExportedQualIdent qident ((CS.ExportTypeAll qident'):exps)-   = qident == qident' || isExportedQualIdent qident exps-isExportedQualIdent qident ((CS.ExportModule _):exps)-   = isExportedQualIdent qident exps-----qualifyIDecl :: ModuleIdent -> CS.IDecl -> CS.IDecl-qualifyIDecl mident (CS.IInfixDecl pos fix prec qident)-   = (CS.IInfixDecl pos fix prec (qualQualify mident qident))-qualifyIDecl mident (CS.IDataDecl pos qident idents cdecls)-   = (CS.IDataDecl pos (qualQualify mident qident) idents cdecls)-qualifyIDecl mident (CS.INewtypeDecl pos qident idents ncdecl)-   = (CS.INewtypeDecl pos (qualQualify mident qident) idents ncdecl)-qualifyIDecl mident (CS.ITypeDecl pos qident idents texpr)-   = (CS.ITypeDecl pos (qualQualify mident qident) idents texpr)-qualifyIDecl mident (CS.IFunctionDecl pos qident arity texpr)-   = (CS.IFunctionDecl pos (qualQualify mident qident) arity texpr)-qualifyIDecl _ idecl = idecl------typeArity :: IL.Type -> Int-typeArity (IL.TypeArrow _ t)       = 1 + (typeArity t)-typeArity (IL.TypeConstructor _ _) = 0-typeArity (IL.TypeVariable _)      = 0---------------------------------------------------------------------------------------genFlatApplication :: IL.Expression -> IL.Expression -> FlatState Expr-genFlatApplication e1 e2-   = genFlatApplic [e2] e1- where-   genFlatApplic args expression -      = case expression of-	  (IL.Apply expr1 expr2)    -	      -> genFlatApplic (expr2:args) expr1-	  (IL.Function qident _)-	      -> do arity_ <- lookupIdArity qident-                    qname <- visitQualIdent qident-		    maybe (internalError (funcArity qident))-			  (\arity -> genFuncCall qname arity args)-			  arity_-	  (IL.Constructor qident _)-	      -> do arity_ <- lookupIdArity qident-                    qname <- visitQualIdent qident-		    maybe (internalError (consArity qident))-			  (\arity -> genConsCall qname arity args)-			  arity_-	  _   -> do expr <- visitExpression expression-		    genApplicComb expr args-----genFuncCall :: QName -> Int -> [IL.Expression] -> FlatState Expr-genFuncCall qname arity args-   | arity > cnt -     = genComb qname args (FuncPartCall (arity - cnt))-   | arity < cnt -     = do let (funcargs, applicargs) = splitAt arity args-	  funccall <- genComb qname funcargs FuncCall-	  genApplicComb funccall applicargs-   | otherwise   -     = genComb qname args FuncCall- where cnt = length args-----genConsCall :: QName -> Int -> [IL.Expression] -> FlatState Expr-genConsCall qname arity args-   | arity > cnt -     = genComb qname args (ConsPartCall (arity - cnt))-   | arity < cnt-     = do let (funcargs, applicargs) = splitAt arity args-	  conscall <- genComb qname funcargs ConsCall-	  genApplicComb conscall applicargs-   | otherwise -     = genComb qname args ConsCall - where cnt = length args-----genComb :: QName -> [IL.Expression] -> CombType -> FlatState Expr-genComb qname args combtype-   = do exprs <- mapM visitExpression args-	return (Comb combtype qname exprs)-	 ----genApplicComb :: Expr -> [IL.Expression] -> FlatState Expr-genApplicComb expr [] = return expr-genApplicComb expr (e1:es)-   = do expr1 <- visitExpression e1-	qname <- visitQualIdent qidApply-	genApplicComb (Comb FuncCall qname [expr, expr1]) es- where- qidApply = qualifyWith preludeMIdent (mkIdent "apply")------genOpDecls :: FlatState [OpDecl]-genOpDecls = fixities >>= mapM genOpDecl-----genOpDecl :: CS.IDecl -> FlatState OpDecl-genOpDecl (CS.IInfixDecl _ fixity prec qident)-   = do qname <- visitQualIdent qident-	return (Op qname (p_genOpFixity fixity) prec)- where-   p_genOpFixity CS.InfixL = InfixlOp-   p_genOpFixity CS.InfixR = InfixrOp-   p_genOpFixity CS.Infix  = InfixOp-genOpDecl _ = internalError "GenFlatCurry: no infix interface"----- The intermediate language (IL) does not represent type synonyms--- (and also no record declarations). For this reason an interface--- representation of all type synonyms is generated (see "CurryEnv")--- from the abstract syntax representation of the Curry program.--- The function 'typeSynonyms' returns this list of type synonyms.-genTypeSynonyms ::  FlatState [TypeDecl]-genTypeSynonyms = typeSynonyms >>= mapM genTypeSynonym-----genTypeSynonym :: CS.IDecl -> FlatState TypeDecl-genTypeSynonym (CS.ITypeDecl _ qident params typeexpr)-   = do let is = [0 .. (length params) - 1]-        tyEnv <- gets typeEnvE-        tcEnv <- gets tConsEnvE-	let typeexpr' = elimRecordTypes tyEnv tcEnv typeexpr-	texpr <- visitType (fst (cs2ilType (zip params is) typeexpr'))-	qname <- visitQualTypeIdent qident-	vis   <- getVisibility False qident-	return (TypeSyn qname vis is texpr)-genTypeSynonym _ = internalError "GenFlatCurry: no type synonym interface"----- In order to provide an interface for record declarations, 'genRecordTypes'--- generates dummy data declarations representing records together--- with their typed labels. For the record declaration------      type Rec = {l_1 :: t_1,..., l_n :: t_n}------ the following data declaration will be generated:------      data Rec' = l_1' t_1 | ... | l_n' :: t_n------ Rec' and l_i' are unique idenfifiers which encode the original names--- Rec and l_i.--- When reading an interface file containing such declarations, it is--- now possible to reconstruct the original record declaration. Since--- usual FlatCurry code is used, these declaration should not have any--- effects on the behaviour of the Curry program. But to ensure correctness,--- these dummies should be generated for the interface file as well as for--- the corresponding FlatCurry file.-genRecordTypes :: FlatState [TypeDecl]-genRecordTypes = records >>= mapM genRecordType-----genRecordType :: CS.IDecl -> FlatState TypeDecl-genRecordType (CS.ITypeDecl _ qident params (CS.RecordType fields _))-   = do let is = [0 .. (length params) - 1]-	    (mod,ident) = (qualidMod qident, qualidId qident)-	qname <- visitQualIdent ((maybe qualify qualifyWith mod) -				 (recordExtId ident))-	labels <- mapM (genRecordLabel mod (zip params is)) fields-	return (Type qname Public is labels)-----genRecordLabel :: Maybe ModuleIdent -> [(Ident,Int)] -> ([Ident],CS.TypeExpr) -	       -> FlatState ConsDecl-genRecordLabel mod vis ([ident],typeexpr)-   = do tyEnv <- gets typeEnvE-        tcEnv <- gets tConsEnvE-	let typeexpr' = elimRecordTypes tyEnv tcEnv typeexpr-        texpr <- visitType (fst (cs2ilType vis typeexpr'))-	qname <- visitQualIdent ((maybe qualify qualifyWith mod) -				 (labelExtId ident))-	return (Cons qname 1 Public [texpr])-------------------------------------------------------------------------------------- FlatCurry provides no possibility of representing record types like--- {l_1::t_1, l_2::t_2, ..., l_n::t_n}. So they have to be transformed to--- to the corresponding type constructors which are defined in the record --- declarations. --- Unlike data declarations or function type annotations, type synonyms and--- record declarations are not generated from the intermediate language.--- So the transformation has only to be performed in these cases.-elimRecordTypes :: ValueEnv -> TCEnv -> CS.TypeExpr -> CS.TypeExpr-elimRecordTypes tyEnv tcEnv (CS.ConstructorType qid typeexprs)-   = CS.ConstructorType qid (map (elimRecordTypes tyEnv tcEnv) typeexprs)-elimRecordTypes tyEnv tcEnv (CS.VariableType id)-   = CS.VariableType id-elimRecordTypes tyEnv tcEnv (CS.TupleType typeexprs)-   = CS.TupleType (map (elimRecordTypes tyEnv tcEnv) typeexprs)-elimRecordTypes tyEnv tcEnv (CS.ListType typeexpr)-   = CS.ListType (elimRecordTypes tyEnv tcEnv typeexpr)-elimRecordTypes tyEnv tcEnv (CS.ArrowType typeexpr1 typeexpr2)-   = CS.ArrowType (elimRecordTypes tyEnv tcEnv typeexpr1)-                  (elimRecordTypes tyEnv tcEnv typeexpr2)-elimRecordTypes tyEnv tcEnv (CS.RecordType fss _)-   = let fs = flattenRecordTypeFields fss-     in  case (lookupValue (fst (head fs)) tyEnv) of-  	   [Label _ record _] ->-	     case (qualLookupTC record tcEnv) of-	       [AliasType _ n (TypeRecord fs' _)] ->-	         let ms = foldl (matchTypeVars fs) Map.empty fs'-		     types = map (\i -> maybe -			 	          (CS.VariableType -					     (mkIdent ("#tvar" ++ show i)))-				          (elimRecordTypes tyEnv tcEnv)-				          (Map.lookup i ms))-			         [0 .. n-1]-	         in  CS.ConstructorType record types-	       _ -> internalError ("GenFlatCurry.elimRecordTypes: "-		 		   ++ "no record type")-	   _ -> internalError ("GenFlatCurry.elimRecordTypes: "-			       ++ "no label")--matchTypeVars :: [(Ident,CS.TypeExpr)] -> Map.Map Int CS.TypeExpr-	      -> (Ident, Type) -> Map.Map Int CS.TypeExpr-matchTypeVars fs ms (l,ty)-   = maybe ms (match ms ty) (lookup l fs)-  where-  match ms (TypeVariable i) typeexpr = Map.insert i typeexpr ms-  match ms (TypeConstructor _ tys) (CS.ConstructorType _ typeexprs)-     = matchList ms tys typeexprs-  match ms (TypeConstructor _ tys) (CS.ListType typeexpr)-     = matchList ms tys [typeexpr]-  match ms (TypeConstructor _ tys) (CS.TupleType typeexprs)-     = matchList ms tys typeexprs-  match ms (TypeArrow ty1 ty2) (CS.ArrowType typeexpr1 typeexpr2)-     = matchList ms [ty1,ty2] [typeexpr1,typeexpr2]-  match ms (TypeRecord fs' _) (CS.RecordType fss _)-     = foldl (matchTypeVars (flattenRecordTypeFields fss)) ms fs'-  match ms ty typeexpr-     = internalError ("GenFlatCurry.matchTypeVars: "-		      ++ show ty ++ "\n" ++ show typeexpr)--  matchList ms tys-     = foldl (\ms' (ty,typeexpr) -> match ms' ty typeexpr) ms . zip tys---flattenRecordTypeFields :: [([Ident],CS.TypeExpr)] -> [(Ident,CS.TypeExpr)]-flattenRecordTypeFields-   = concatMap (\ (labels, typeexpr)-		-> map (\label -> (label,typeexpr)) labels)--------------------------------------------------------------------------------------checkOverlapping :: Expr -> Expr -> FlatState ()-checkOverlapping expr1 expr2-   = do opts <- compilerOpts-	unless (noOverlapWarn opts)-	       (checkOverlap expr1 expr2)- where- checkOverlap (Case _ _ _ _) _ -    = do qid <- functionId-	 genWarning (overlappingRules qid)- checkOverlap _ (Case _ _ _ _)-    = do qid <- functionId-	 genWarning (overlappingRules qid)- checkOverlap _ _ = return ()-------------------------------------------------------------------------------------- -cs2ilType :: [(Ident,Int)] -> CS.TypeExpr -> (IL.Type, [(Ident,Int)])-cs2ilType ids (CS.ConstructorType qident typeexprs)-   = let (ilTypeexprs, ids') = emap cs2ilType ids typeexprs-     in  (IL.TypeConstructor qident ilTypeexprs, ids')-cs2ilType ids (CS.VariableType ident)-   = let mid        = lookup ident ids-	 nid        | null ids  = 0-		    | otherwise = 1 + snd (head ids)-	 (id, ids') | isJust mid = (fromJust mid, ids)-		    | otherwise  = (nid, (ident, nid):ids)-     in  (IL.TypeVariable id, ids')-cs2ilType ids (CS.ArrowType type1 type2)-   = let (ilType1, ids')  = cs2ilType ids type1-	 (ilType2, ids'') = cs2ilType ids' type2-     in  (IL.TypeArrow ilType1 ilType2, ids'')-cs2ilType ids (CS.ListType typeexpr)-   = let (ilTypeexpr, ids') = cs2ilType ids typeexpr-     in  (IL.TypeConstructor (qualify listId) [ilTypeexpr], ids')-cs2ilType ids (CS.TupleType typeexprs)-   = case typeexprs of-       []  -> (IL.TypeConstructor qUnitId [], ids)-       [t] -> cs2ilType ids t-       _   -> let (ilTypeexprs, ids') = emap cs2ilType ids typeexprs-		  tuplen = length ilTypeexprs-	      in  (IL.TypeConstructor (qTupleId tuplen) ilTypeexprs,-		   ids')-cs2ilType _ typeexpr = internalError ("cs2ilType: " ++ show typeexpr)------------------------------------------------------------------------------------- Messages for internal errors and warnings--funcArity qid = "GenFlatCurry: missing arity for function \"" -		++ show qid ++ "\""--consArity qid = "GenFlatCurry: missing arity for constructor \""-		++ show qid ++ "\""--missingVarIndex id = "GenFlatCurry: missing index for \"" ++ show id ++ "\""---overlappingRules qid =  "function \""-		        ++ qualName qid -		        ++ "\" is non-deterministic due to non-trivial "-		        ++ "overlapping rules"-----------------------------------------------------------------------------------------------------------------------------------------------------------------------isDataDecl :: IL.Decl -> Bool-isDataDecl (IL.DataDecl _ _ _) = True-isDataDecl _                = False-----isFuncDecl :: IL.Decl -> Bool-isFuncDecl (IL.FunctionDecl _ _ _ _) = True-isFuncDecl (IL.ExternalDecl _ _ _ _) = True-isFuncDecl _                         = False-----isPublicDataDecl :: IL.Decl -> FlatState Bool-isPublicDataDecl (IL.DataDecl qident _ _ ) = isPublic False qident-isPublicDataDecl _                         = return False-----isPublicFuncDecl :: IL.Decl -> FlatState Bool-isPublicFuncDecl (IL.FunctionDecl qident _ _ _) = isPublic False qident-isPublicFuncDecl (IL.ExternalDecl qident _ _ _) = isPublic False qident-isPublicFuncDecl _                              = return False-----isTypeIDecl :: CS.IDecl -> Bool-isTypeIDecl (CS.IDataDecl _ _ _ _) = True-isTypeIDecl (CS.ITypeDecl _ _ _ _) = True-isTypeIDecl _                      = False-----isRecordIDecl :: CS.IDecl -> Bool-isRecordIDecl (CS.ITypeDecl _ _ _ (CS.RecordType (_:_) _)) = True-isRecordIDecl _                                            = False-----isFuncIDecl :: CS.IDecl -> Bool-isFuncIDecl (CS.IFunctionDecl _ _ _ _) = True-isFuncIDecl _                          = False-----isOpIDecl :: CS.IDecl -> Bool-isOpIDecl (CS.IInfixDecl _ _ _ _) = True-isOpIDecl _                       = False ------bindingIdent :: IL.Binding -> Ident-bindingIdent (IL.Binding ident _) = ident-------------------------------------------------------------------------------------------------------------------------------------------------------------------emap :: (e -> a -> (b,e)) -> e -> [a] -> ([b], e)-emap _ env []     = ([], env)-emap f env (x:xs) = let (x',env')    = f env x-			(xs', env'') = emap f env' xs-		    in  ((x':xs'), env'')----------------------------------------------------------------------------------------------------------------------------------------------------------------------moduleId :: FlatState ModuleIdent-moduleId = gets moduleIdE-----functionId :: FlatState QualIdent-functionId = gets (fst . functionIdE)-----setFunctionId :: (QualIdent, [(Ident, IL.Type)]) -> FlatState ()-setFunctionId qid = modify (\env -> env{ functionIdE = qid })-----compilerOpts :: FlatState Options-compilerOpts = gets compilerOptsE-----exports :: FlatState [CS.Export]-exports = gets exportsE-----imports :: FlatState [CS.IDecl]-imports = gets importsE-----records :: FlatState [CS.IDecl]-records = gets (filter isRecordIDecl . interfaceE)-----fixities :: FlatState [CS.IDecl]-fixities = gets fixitiesE-----typeSynonyms :: FlatState [CS.IDecl]-typeSynonyms = gets typeSynonymsE-----isPublic :: Bool -> QualIdent -> FlatState Bool-isPublic isConstr qid = gets (\env -> maybe False isP-                                      (Map.lookup (unqualify qid) -                                       (publicEnvE env)))-  where-    isP NotConstr = not isConstr-    isP OnlyConstr = isConstr-    isP NotOnlyConstr = True-----lookupModuleIntf :: ModuleIdent -> FlatState (Maybe [CS.IDecl])-lookupModuleIntf mid-   = gets (Map.lookup mid . moduleEnvE)-----lookupIdArity :: QualIdent -> FlatState (Maybe Int)-lookupIdArity qid-   = gets (lookupA qid . arityEnvE)- where- lookupA qid aEnv = case (qualLookupArity qid aEnv) of-		      [ArityInfo _ a]-		         -> Just a-		      [] -> case (lookupArity (unqualify qid) aEnv) of-			      [ArityInfo _ a] -> Just a-			      _               -> Nothing-		      _  -> Nothing----getTypeOf :: Ident -> FlatState (Maybe TypeExpr)-getTypeOf ident = do-    valEnv <- gets typeEnvE -    case lookupValue ident valEnv of -      Value _ (ForAll _ t) : _ -          -> do t <- visitType (ttrans t)-                trace' ("getTypeOf(" ++ show ident ++ ") = " ++ show t)$-                       return (Just t)-      DataConstructor _ (ForAllExist _ _ t):_ -          -> do t <- visitType (ttrans t)-                trace' ("getTypeOfDataCon(" ++ show ident ++ ") = " ++ show t)$-                       return (Just t)-      _   -> do (_,ats) <- gets functionIdE-                case lookup ident ats of-                  Just t -> liftM Just (visitType t)-                  Nothing -> trace' ("lookupValue did not return a value for index " ++ show ident)-                             (return Nothing)-ttrans :: Type -> IL.Type -ttrans (TypeConstructor i ts)-    = IL.TypeConstructor i (map ttrans ts)-ttrans (TypeVariable v)-    = IL.TypeVariable v-ttrans (TypeConstrained [] v)-    = IL.TypeVariable v-ttrans (TypeConstrained (v:_) i)-    = ttrans v-ttrans (TypeArrow f x) = IL.TypeArrow (ttrans f) (ttrans x)-ttrans s@(TypeSkolem _) = error $ "in ttrans: " ++ show s-ttrans s@(TypeRecord _ _) = error $ "in ttrans: " ++ show s------ Constructor (:) receives special treatment throughout the--- whole implementation. We won't depart from that for mere--- aesthetic reasons. (hsi)-lookupIdType :: QualIdent -> FlatState (Maybe TypeExpr)-lookupIdType (QualIdent Nothing (Ident _ "[]" _))-    = return (Just l0)-      where l0 = TCons (mkQName ("Prelude", "[]")) [TVar 0]-lookupIdType (QualIdent Nothing (Ident _ ":" _))-    = return (Just (FuncType (TVar 0) (FuncType (l0) (l0))))-      where l0 = TCons (mkQName ("Prelude", "[]")) [TVar 0]-lookupIdType (QualIdent Nothing (Ident _ "()" _))-    = return (Just l0)-      where l0 = TCons (mkQName ("Prelude", "()")) []-lookupIdType (QualIdent Nothing (Ident _ t@('(':',':r) _))-    = return (Just funtype)-      where tupleArity = length r + 1-            argTypes   = map TVar [1..tupleArity]-            contype    = TCons (mkQName ("Prelude", t)) argTypes-            funtype    = foldr FuncType contype argTypes-lookupIdType qid-   = do aEnv <- gets typeEnvE-        lt <- gets localTypes-        ct <- gets constrTypes-        case Map.lookup qid lt `mplus` Map.lookup qid ct of-          Just t -> trace' ("lookupIdType local " ++ show (qid, t)) $ liftM Just (visitType t)  -- local name or constructor-          Nothing -> case [ t | Value _ (ForAll _ t) <- qualLookupValue qid aEnv ] of -                       t : _ -> liftM Just (visitType (IL.translType t))  -- imported name-                       []    -> case qualidMod qid of-                                  Nothing -> trace' ("no type for "  ++ show qid) $ return Nothing  -- no known type-                                  Just _ -> lookupIdType qid {qualidMod = Nothing}--- ---- Generates a new index for a variable-newVarIndex :: Ident -> FlatState VarIndex-newVarIndex ident-   = do idx0 <- gets varIndexE-        ty <- getTypeOf ident-        let idx = idx0 + 1-            vid = VarIndex ty idx-        vids <- gets varIdsE-        modify (\env -> env{ varIndexE = idx,-			     varIdsE   = ScopeEnv.insert ident vid vids-			   })-        return vid-----lookupVarIndex :: Ident -> FlatState VarIndex-lookupVarIndex id-   = do index_ <- gets (ScopeEnv.lookup id . varIdsE)-        maybe (internalError (missingVarIndex id)) return index_-----clearVarIndices :: FlatState ()-clearVarIndices = modify (\env -> env { varIndexE = 0,-				        varIdsE = ScopeEnv.new -				      })-----genWarning :: String -> FlatState ()-genWarning msg-   = modify (\env -> env{ messagesE = warnMsg:(messagesE env) })-    where warnMsg = WarnMsg Nothing msg-----genInterface :: FlatState Bool-genInterface = gets genInterfaceE-----beginScope :: FlatState ()-beginScope = modify-	       (\env -> env { varIdsE  = ScopeEnv.beginScope (varIdsE env)-			    })-----endScope :: FlatState ()-endScope = modify-	     (\env -> env { varIdsE  = ScopeEnv.endScope (varIdsE env)-			  })-----whenFlatCurry :: FlatState a -> FlatState a -> FlatState a-whenFlatCurry genFlat genIntf -   = genInterface >>= (\intf -> if intf then genIntf else genFlat)-------------------------------------------------------------------------------------- Generates an evironment containing all public identifiers from the module--- Note: Currently the record functions (selection and update) for all public --- record labels are inserted into the environment, though they are not--- explicitly declared in the export specifications.-genPubEnv :: ModuleIdent -> [CS.IDecl] -> Map.Map Ident IdentExport-genPubEnv mid idecls = foldl (bindEnvIDecl mid) Map.empty idecls--bindIdentExport :: Ident -> Bool -> Map.Map Ident IdentExport -> Map.Map Ident IdentExport-bindIdentExport id isConstr env =-    maybe (Map.insert id (if isConstr then OnlyConstr else NotConstr) env)-          (\ ie -> Map.insert id (updateIdentExport ie isConstr) env)-          (Map.lookup id env)-  where-    updateIdentExport OnlyConstr True  = OnlyConstr-    updateIdentExport OnlyConstr False = NotOnlyConstr-    updateIdentExport NotConstr True   = NotOnlyConstr-    updateIdentExport NotConstr False  = NotConstr-    updateIdentExport NotOnlyConstr _  = NotOnlyConstr------bindEnvIDecl :: ModuleIdent -> Map.Map Ident IdentExport -> CS.IDecl -> Map.Map Ident IdentExport-bindEnvIDecl mid env (CS.IDataDecl _ qid _ mcdecls)-   = maybe env -           (\id -> foldl bindEnvConstrDecl-	                 (bindIdentExport id False env)-	                 (catMaybes mcdecls))-	   (localIdent mid qid)-bindEnvIDecl mid env (CS.INewtypeDecl _ qid _ ncdecl)-   = maybe env -           (\id -> bindEnvNewConstrDecl (bindIdentExport id False env) ncdecl)-	   (localIdent mid qid)-bindEnvIDecl mid env (CS.ITypeDecl _ qid _ texpr)-   = maybe env (\id -> bindEnvITypeDecl env id texpr) (localIdent mid qid)-bindEnvIDecl mid env (CS.IFunctionDecl _ qid _ _)-   = maybe env (\id -> bindIdentExport id False env) (localIdent mid qid)-bindEnvIDecl _ env _ = env-----bindEnvITypeDecl :: Map.Map Ident IdentExport -> Ident -> CS.TypeExpr-		    -> Map.Map Ident IdentExport-bindEnvITypeDecl env id (CS.RecordType fs _)-   = bindIdentExport id False (foldl (bindEnvRecordLabel id) env fs)-bindEnvITypeDecl env id texpr-   = bindIdentExport id False env-----bindEnvConstrDecl :: Map.Map Ident IdentExport -> CS.ConstrDecl -> Map.Map Ident IdentExport-bindEnvConstrDecl env (CS.ConstrDecl _ _ id _)  = bindIdentExport id True env-bindEnvConstrDecl env (CS.ConOpDecl _ _ _ id _) = bindIdentExport id True env-----bindEnvNewConstrDecl :: Map.Map Ident IdentExport -> CS.NewConstrDecl -> Map.Map Ident IdentExport-bindEnvNewConstrDecl env (CS.NewConstrDecl _ _ id _) = bindIdentExport id False env-----bindEnvRecordLabel :: Ident -> Map.Map Ident IdentExport -> ([Ident],CS.TypeExpr) -> Map.Map Ident IdentExport-bindEnvRecordLabel r env ([lab], _) = bindIdentExport (recSelectorId (qualify r) lab) False expo-    where -      expo = (bindIdentExport (recUpdateId (qualify r) lab) False env)---splitoffArgTypes :: IL.Type -> [Ident] -> [(Ident, IL.Type)]-splitoffArgTypes (IL.TypeArrow l r) (i:is) = (i, l):splitoffArgTypes r is-splitoffArgTypes _ [] = []-splitoffArgTypes _ _  = error "internal error in splitoffArgTypes"--
+ src/Generators.hs view
@@ -0,0 +1,59 @@+{- |+    Module      :  $Header$+    Description :  Code generators+    Copyright   :  (c) 2011        Björn Peemöller+                       2017        Finn Teegen+                       2018        Kai-Oliver Prott+    License     :  BSD-3-clause++    Maintainer  :  fte@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module subsumes the different code generators.+-}+module Generators where++import qualified Curry.AbstractCurry            as AC   (CurryProg)+import qualified Curry.FlatCurry.Type           as FC   (Prog, TypeExpr)+import qualified Curry.FlatCurry.Annotated.Type as AFC  (AProg)+import qualified Curry.FlatCurry.Typed.Type     as TFC  (TProg)+import qualified Curry.Syntax                   as CS   (Module)++import qualified Generators.GenAbstractCurry    as GAC  (genAbstractCurry)+import qualified Generators.GenFlatCurry        as GFC  ( genFlatCurry+                                                        , genFlatInterface+                                                        )+import qualified Generators.GenAnnotatedFlatCurry+                                                as GAFC (genAnnotatedFlatCurry)+import qualified Generators.GenTypedFlatCurry   as GTFC (genTypedFlatCurry)++import           Base.Types                             (Type, PredType)++import           CompilerEnv                            (CompilerEnv (..))+import qualified IL                                     (Module)++-- |Generate typed AbstractCurry+genTypedAbstractCurry :: CompilerEnv -> CS.Module PredType -> AC.CurryProg+genTypedAbstractCurry = GAC.genAbstractCurry False++-- |Generate untyped AbstractCurry+genUntypedAbstractCurry :: CompilerEnv -> CS.Module PredType -> AC.CurryProg+genUntypedAbstractCurry = GAC.genAbstractCurry True++-- |Generate typed FlatCurry+genTypedFlatCurry :: AFC.AProg FC.TypeExpr -> TFC.TProg+genTypedFlatCurry = GTFC.genTypedFlatCurry++-- |Generate type-annotated FlatCurry+genAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module+                      -> AFC.AProg FC.TypeExpr+genAnnotatedFlatCurry = GAFC.genAnnotatedFlatCurry++-- |Generate FlatCurry+genFlatCurry :: AFC.AProg FC.TypeExpr -> FC.Prog+genFlatCurry = GFC.genFlatCurry++-- |Generate a FlatCurry interface+genFlatInterface :: FC.Prog -> FC.Prog+genFlatInterface = GFC.genFlatInterface
+ src/Generators/GenAbstractCurry.hs view
@@ -0,0 +1,541 @@+{- |+    Module      :  $Header$+    Description :  Generation of AbstractCurry program terms+    Copyright   :  (c) 2005        Martin Engelke+                       2011 - 2015 Björn Peemöller+                       2015        Jan Tikovsky+                       2016        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module contains the generation of an 'AbstractCurry' program term+    for a given 'Curry' module.+-}+{-# LANGUAGE CPP #-}+module Generators.GenAbstractCurry (genAbstractCurry) where++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative          ((<$>), (<*>), pure)+#endif+import           Control.Monad.Extra+import qualified Control.Monad.State as S     (State, evalState, get, gets+                                              , modify, put, when)+import qualified Data.Map            as Map   (Map, empty, fromList, lookup+                                              , union)+import qualified Data.Maybe          as Maybe (fromJust, fromMaybe, listToMaybe)+import qualified Data.Set            as Set   (Set, empty, insert, member)+import qualified Data.Traversable    as T     (forM)++import Curry.AbstractCurry+import Curry.Base.Ident+import Curry.Base.SpanInfo+import Curry.Syntax++import Base.CurryTypes (fromPredType, toType, toPredType)+import Base.Expr       (bv)+import Base.Messages   (internalError)+import Base.NestEnv+import Base.Types      (arrowArity, PredType, unpredType, TypeScheme (..))+import Base.TypeSubst++import Env.Value       (ValueEnv, ValueInfo (..), qualLookupValue)+import Env.OpPrec      (mkPrec)++import CompilerEnv++type GAC a = S.State AbstractEnv a++-- ---------------------------------------------------------------------------+-- Interface+-- ---------------------------------------------------------------------------++-- |Generate an AbstractCurry program term from the syntax tree+--  when uacy flag is set untype AbstractCurry is generated+genAbstractCurry :: Bool -> CompilerEnv -> Module PredType -> CurryProg+genAbstractCurry uacy env mdl+  = S.evalState (trModule mdl) (abstractEnv uacy env mdl)++-- ---------------------------------------------------------------------------+-- Conversion from Curry to AbstractCurry+-- ---------------------------------------------------------------------------++trModule :: Module PredType -> GAC CurryProg+trModule (Module _ _ _ mid _ is ds) =+  CurryProg mid' is' <$> dflt' <*> cds' <*> ids' <*> ts' <*> fs' <*> os'+  where+  mid'  = moduleName mid+  is'   = map cvImportDecl is+  dflt' = Maybe.listToMaybe <$> concatMapM (withLocalEnv . trDefaultDecl) ds+  cds'  = concatMapM (withLocalEnv . trClassDecl) ds+  ids'  = concatMapM (withLocalEnv . trInstanceDecl) ds+  ts'   = concatMapM (withLocalEnv . trTypeDecl) ds+  fs'   = concatMapM (withLocalEnv . trFuncDecl True) ds+  os'   = concatMapM (withLocalEnv . trInfixDecl) ds++cvImportDecl :: ImportDecl -> String+cvImportDecl (ImportDecl _ mid _ _ _) = moduleName mid++trDefaultDecl :: Decl a -> GAC [CDefaultDecl]+trDefaultDecl (DefaultDecl _ tys) = (\tys' -> [CDefaultDecl tys'])+  <$> mapM trTypeExpr tys+trDefaultDecl _                   = return []++trClassDecl :: Decl PredType -> GAC [CClassDecl]+trClassDecl (ClassDecl _ _ cx cls tv ds) =+  (\cls' v' cx' tv' ds' -> [CClass cls' v' cx' tv' ds'])+    <$> trGlobalIdent cls <*> getTypeVisibility cls <*> trContext cx+    <*> getTVarIndex tv <*> concatMapM (trClassMethodDecl sigs fs) ds+  where fs = [f | FunctionDecl _ _ f _ <- ds]+        sigs = signatures ds+trClassDecl _ = return []++-- We ignore type signatures for class methods with a given default+-- implementation as declarations for those are generated anyway.+-- For function declarations we use the equation's arity instead of+-- the one from the value environment or 0.+trClassMethodDecl :: [(Ident, QualTypeExpr)] -> [Ident] -> Decl PredType+                  -> GAC [CFuncDecl]+trClassMethodDecl sigs fs (TypeSig p [f] _) | f `notElem` fs =+  trClassMethodDecl sigs fs $ FunctionDecl p undefined f []+trClassMethodDecl sigs fs (TypeSig p (f:f':fs') qty) =+  liftM2 (++) (trClassMethodDecl sigs fs $ TypeSig p [f] qty)+              (trClassMethodDecl sigs fs $ TypeSig p (f':fs') qty)+trClassMethodDecl sigs _ (FunctionDecl _ _ f eqs) =+  (\f' a v ty rs -> [CFunc f' a v ty rs]) <$> trGlobalIdent f+  <*> pure (maybe 0 eqnArity $ Maybe.listToMaybe eqs)+  <*> getVisibility (unRenameIdent f)+  <*> trQualTypeExpr (Maybe.fromJust $ lookup f sigs) <*> mapM trEquation eqs+trClassMethodDecl _ _ _ = return []++trInstanceDecl :: Decl PredType -> GAC [CInstanceDecl]+trInstanceDecl (InstanceDecl _ _ cx qcls ty ds) =+  (\qcls' cx' ty' ds' -> [CInstance qcls' cx' ty' ds']) <$> trQual qcls+  <*> trContext cx <*> trTypeExpr ty <*> mapM (trInstanceMethodDecl qcls ty) ds+trInstanceDecl _ = return []++-- Again, we use the equation's arity for function declarations instead of+-- the one from the value.+trInstanceMethodDecl :: QualIdent -> TypeExpr -> Decl PredType -> GAC CFuncDecl+trInstanceMethodDecl qcls ty (FunctionDecl _ _ f eqs) = do+  uacy <- S.gets untypedAcy+  qty <- if uacy+           then return $ QualTypeExpr NoSpanInfo [] $+                           ConstructorType NoSpanInfo prelUntyped+           else getQualType' (qualifyLike qcls $ unRenameIdent f)+  CFunc <$> trLocalIdent f <*> pure (eqnArity $ head eqs) <*> pure Public+        <*> trInstanceMethodType ty qty <*> mapM trEquation eqs+trInstanceMethodDecl _ _ _ = internalError "GenAbstractCurry.trInstanceMethodDecl"++-- Transforms a class method type into an instance method's type by replacing+-- the class variable with the given instance type. The implicit class context+-- is dropped in doing so.+trInstanceMethodType :: TypeExpr -> QualTypeExpr -> GAC CQualTypeExpr+trInstanceMethodType ity (QualTypeExpr _ cx ty) =+  trQualTypeExpr $ fromPredType identSupply $+    subst (bindSubst 0 (toType [] ity) idSubst) $+      toPredType (take 1 identSupply) $ QualTypeExpr NoSpanInfo (drop 1 cx) ty++trTypeDecl :: Decl a -> GAC [CTypeDecl]+trTypeDecl (DataDecl    _ t vs cs clss) =+  (\t' v vs' cs' clss' -> [CType t' v vs' cs' clss'])+  <$> trGlobalIdent t <*> getTypeVisibility t+  <*> mapM genTVarIndex vs <*> mapM trConsDecl cs+  <*> mapM trQual clss+trTypeDecl (TypeDecl    _ t vs ty) = (\t' v vs' ty' -> [CTypeSyn t' v vs' ty'])+  <$> trGlobalIdent t <*> getTypeVisibility t+  <*> mapM genTVarIndex vs <*> trTypeExpr ty+trTypeDecl (NewtypeDecl _ t vs nc clss) =+  (\t' v vs' nc' clss' -> [CNewType t' v vs' nc' clss'])+  <$> trGlobalIdent t <*> getTypeVisibility t+  <*> mapM genTVarIndex vs <*> trNewConsDecl nc+  <*> mapM trQual clss+trTypeDecl (ExternalDataDecl _ t vs) =+  (\t' v vs' -> [CType t' v vs' [] []])+  <$> trGlobalIdent t <*> getTypeVisibility t <*> mapM genTVarIndex vs+trTypeDecl _                       = return []++trConsDecl :: ConstrDecl -> GAC CConsDecl+trConsDecl (ConstrDecl  _ c tys) = inNestedTScope $ CCons+  <$> trGlobalIdent c <*> getVisibility c <*> mapM trTypeExpr tys+trConsDecl (ConOpDecl p ty1 op ty2) = inNestedTScope $ trConsDecl $+  ConstrDecl p op [ty1, ty2]+trConsDecl (RecordDecl   _ c fs) = inNestedTScope $ CRecord+  <$> trGlobalIdent c <*> getVisibility c <*> concatMapM trFieldDecl fs++trFieldDecl :: FieldDecl -> GAC [CFieldDecl]+trFieldDecl (FieldDecl _ ls ty) = T.forM ls $ \l ->+  CField <$> trGlobalIdent l <*> getVisibility l <*> trTypeExpr ty++trNewConsDecl :: NewConstrDecl -> GAC CConsDecl+trNewConsDecl (NewConstrDecl _ nc      ty) = CCons+  <$> trGlobalIdent nc <*> getVisibility nc <*> ((:[]) <$> trTypeExpr ty)+trNewConsDecl (NewRecordDecl p nc (l, ty)) = CRecord+  <$> trGlobalIdent nc <*> getVisibility nc <*> trFieldDecl (FieldDecl p [l] ty)++trTypeExpr :: TypeExpr -> GAC CTypeExpr+trTypeExpr (ConstructorType _ q) = CTCons <$> trQual q+trTypeExpr (ApplyType _ ty1 ty2) = CTApply <$> trTypeExpr ty1 <*> trTypeExpr ty2+trTypeExpr (VariableType    _ v) = CTVar  <$> getTVarIndex v+trTypeExpr (TupleType     _ tys) =+  trTypeExpr $ foldl (ApplyType NoSpanInfo)+                     (ConstructorType NoSpanInfo $ qTupleId $ length tys) tys+trTypeExpr (ListType       _ ty) =+  trTypeExpr $ ApplyType NoSpanInfo (ConstructorType NoSpanInfo qListId) ty+trTypeExpr (ArrowType _ ty1 ty2) = CFuncType <$> trTypeExpr ty1 <*> trTypeExpr ty2+trTypeExpr (ParenType      _ ty) = trTypeExpr ty+trTypeExpr (ForallType    _ _ _) = internalError "GenAbstractCurry.trTypeExpr"++trConstraint :: Constraint -> GAC CConstraint+trConstraint (Constraint _ q ty) = (,) <$> trQual q <*> trTypeExpr ty++trContext :: Context -> GAC CContext+trContext cx = CContext <$> mapM trConstraint cx++trQualTypeExpr :: QualTypeExpr -> GAC CQualTypeExpr+trQualTypeExpr (QualTypeExpr _ cx ty) =+  CQualType <$> trContext cx <*> trTypeExpr ty++trInfixDecl :: Decl a -> GAC [COpDecl]+trInfixDecl (InfixDecl _ fix mprec ops) = mapM trInfix (reverse ops)+  where+  trInfix op = COp <$> trGlobalIdent op <*> return (cvFixity fix)+                   <*> return (fromInteger (mkPrec mprec))+  cvFixity InfixL = CInfixlOp+  cvFixity InfixR = CInfixrOp+  cvFixity Infix  = CInfixOp+trInfixDecl _ = return []++trFuncDecl :: Bool -> Decl PredType -> GAC [CFuncDecl]+trFuncDecl global (FunctionDecl  _ pty f eqs)+  =   (\f' a v ty rs -> [CFunc f' a v ty rs])+  <$> trFuncName global f <*> pure (eqnArity $ head eqs) <*> getVisibility f+  <*> getQualType f pty <*> mapM trEquation eqs+trFuncDecl global (ExternalDecl         _ vs)+  =   T.forM vs $ \(Var pty f) -> CFunc+  <$> trFuncName global f <*> pure (arrowArity $ unpredType pty)+  <*> getVisibility f <*> getQualType f pty <*> return []+trFuncDecl _      _                           = return []++trFuncName :: Bool -> Ident -> GAC QName+trFuncName global = if global then trGlobalIdent else trLocalIdent++trEquation :: Equation PredType -> GAC CRule+trEquation (Equation _ lhs rhs) = inNestedScope+                                $ CRule <$> trLhs lhs <*> trRhs rhs++trLhs :: Lhs a -> GAC [CPattern]+trLhs = mapM trPat . snd . flatLhs++trRhs :: Rhs PredType -> GAC CRhs+trRhs (SimpleRhs _ _ e ds) = inNestedScope $ do+  mapM_ insertDeclLhs ds+  CSimpleRhs <$> trExpr e <*> concatMapM trLocalDecl ds+trRhs (GuardedRhs _ _ gs ds) = inNestedScope $ do+  mapM_ insertDeclLhs ds+  CGuardedRhs <$> mapM trCondExpr gs <*> concatMapM trLocalDecl ds++trCondExpr :: CondExpr PredType -> GAC (CExpr, CExpr)+trCondExpr (CondExpr _ g e) = (,) <$> trExpr g <*> trExpr e++trLocalDecls :: [Decl PredType] -> GAC [CLocalDecl]+trLocalDecls ds = do+  mapM_ insertDeclLhs ds+  concatMapM trLocalDecl ds++-- Insert all variables declared in local declarations+insertDeclLhs :: Decl a -> GAC ()+insertDeclLhs   (PatternDecl      _ p _) = mapM_ genVarIndex (bv p)+insertDeclLhs   (FreeDecl          _ vs) = mapM_ genVarIndex (map varIdent vs)+insertDeclLhs s@(TypeSig          _ _ _) = do+  uacy <- S.gets untypedAcy+  S.when uacy (insertSig s)+insertDeclLhs _                          = return ()++trLocalDecl :: Decl PredType -> GAC [CLocalDecl]+trLocalDecl f@(FunctionDecl    _ _ _ _) = map CLocalFunc <$> trFuncDecl False f+trLocalDecl f@(ExternalDecl        _ _) = map CLocalFunc <$> trFuncDecl False f+trLocalDecl (PatternDecl       _ p rhs) = (\p' rhs' -> [CLocalPat p' rhs'])+                                          <$> trPat p <*> trRhs rhs+trLocalDecl (FreeDecl             _ vs) = (\vs' -> [CLocalVars vs'])+                                          <$> mapM getVarIndex (map varIdent vs)+trLocalDecl _                           = return [] -- can not occur (types etc.)++insertSig :: Decl a -> GAC ()+insertSig (TypeSig _ fs qty) = do+  sigs <- S.gets typeSigs+  let lsigs = Map.fromList [(f, qty) | f <- fs]+  S.modify $ \env -> env { typeSigs = sigs `Map.union` lsigs }+insertSig _                 = return ()++trExpr :: Expression PredType -> GAC CExpr+trExpr (Literal       _ _ l) = return (CLit $ cvLiteral l)+trExpr (Variable      _ _ v)+  | isQualified v = CSymbol <$> trQual v+  | otherwise     = lookupVarIndex (unqualify v) >>= \mvi -> case mvi of+    Just vi -> return (CVar vi)+    _       -> CSymbol <$> trQual v+trExpr (Constructor   _ _ c) = CSymbol <$> trQual c+trExpr (Paren           _ e) = trExpr e+trExpr (Typed       _ e qty) = CTyped <$> trExpr e <*> trQualTypeExpr qty+trExpr (Record     _ _ c fs) = CRecConstr <$> trQual c+                                          <*> mapM (trField trExpr) fs+trExpr (RecordUpdate _ e fs) = CRecUpdate <$> trExpr e+                                          <*> mapM (trField trExpr) fs+trExpr (Tuple          _ es) =+  trExpr $ apply (Variable NoSpanInfo undefined $ qTupleId $ length es) es+trExpr (List         _ _ es) =+  trExpr $ foldr (Apply NoSpanInfo . Apply NoSpanInfo+                   (Constructor NoSpanInfo undefined qConsId))+                 (Constructor NoSpanInfo undefined qNilId)+                 es+trExpr (ListCompr    _ e ds) = inNestedScope $ flip CListComp+                               <$> mapM trStatement ds <*> trExpr e+trExpr (EnumFrom              _ e) =+  trExpr $ apply (Variable NoSpanInfo undefined qEnumFromId) [e]+trExpr (EnumFromThen      _ e1 e2) =+  trExpr $ apply (Variable NoSpanInfo undefined qEnumFromThenId) [e1, e2]+trExpr (EnumFromTo        _ e1 e2) =+  trExpr $ apply (Variable NoSpanInfo undefined qEnumFromToId) [e1, e2]+trExpr (EnumFromThenTo _ e1 e2 e3) =+  trExpr $ apply (Variable NoSpanInfo undefined qEnumFromThenToId) [e1, e2, e3]+trExpr (UnaryMinus            _ e) =+  trExpr $ apply (Variable NoSpanInfo undefined qNegateId) [e]+trExpr (Apply             _ e1 e2) = CApply <$> trExpr e1 <*> trExpr e2+trExpr (InfixApply     _ e1 op e2) = trExpr $ apply (infixOp op) [e1, e2]+trExpr (LeftSection        _ e op) = trExpr $ apply (infixOp op) [e]+trExpr (RightSection       _ op e) =+  trExpr $ apply (Variable NoSpanInfo undefined qFlip) [infixOp op, e]+trExpr (Lambda             _ ps e) = inNestedScope $+                                     CLambda <$> mapM trPat ps <*> trExpr e+trExpr (Let              _ _ ds e) = inNestedScope $+                                     CLetDecl <$> trLocalDecls ds <*> trExpr e+trExpr (Do               _ _ ss e) = inNestedScope $+                                     (\ss' e' -> CDoExpr (ss' ++ [CSExpr e']))+                                     <$> mapM trStatement ss <*> trExpr e+trExpr (IfThenElse     _ e1 e2 e3) =+  trExpr $ apply (Variable NoSpanInfo undefined qIfThenElseId) [e1, e2, e3]+trExpr (Case          _ _ ct e bs) = CCase (cvCaseType ct)+                                     <$> trExpr e <*> mapM trAlt bs++cvCaseType :: CaseType -> CCaseType+cvCaseType Flex  = CFlex+cvCaseType Rigid = CRigid++trStatement :: Statement PredType -> GAC CStatement+trStatement (StmtExpr _   e)  = CSExpr     <$> trExpr e+trStatement (StmtDecl _ _ ds) = CSLet      <$> trLocalDecls ds+trStatement (StmtBind _ p e)  = flip CSPat <$> trExpr e <*> trPat p++trAlt :: Alt PredType -> GAC (CPattern, CRhs)+trAlt (Alt _ p rhs) = inNestedScope $ (,) <$> trPat p <*> trRhs rhs++trPat :: Pattern a -> GAC CPattern+trPat (LiteralPattern         _ _ l) = return (CPLit $ cvLiteral l)+trPat (VariablePattern        _ _ v) = CPVar <$> getVarIndex v+trPat (ConstructorPattern  _ _ c ps) = CPComb <$> trQual c <*> mapM trPat ps+trPat (InfixPattern    _ a p1 op p2) =+  trPat $ ConstructorPattern NoSpanInfo a op [p1, p2]+trPat (ParenPattern             _ p) = trPat p+trPat (RecordPattern       _ _ c fs) = CPRecord <$> trQual c+                                              <*> mapM (trField trPat) fs+trPat (TuplePattern            _ ps) =+  trPat $ ConstructorPattern NoSpanInfo undefined (qTupleId $ length ps) ps+trPat (ListPattern           _ _ ps) = trPat $+  foldr (\x1 x2 -> ConstructorPattern NoSpanInfo undefined qConsId [x1, x2])+        (ConstructorPattern NoSpanInfo undefined qNilId [])+        ps+trPat (NegativePattern        _ a l) =+  trPat $ LiteralPattern NoSpanInfo a $ negateLiteral l+trPat (AsPattern              _ v p) = CPAs <$> getVarIndex v<*> trPat p+trPat (LazyPattern              _ p) = CPLazy <$> trPat p+trPat (FunctionPattern     _ _ f ps) = CPFuncComb <$> trQual f <*> mapM trPat ps+trPat (InfixFuncPattern _ a p1 f p2) =+  trPat (FunctionPattern NoSpanInfo a f [p1, p2])++trField :: (a -> GAC b) -> Field a -> GAC (CField b)+trField act (Field _ l x) = (,) <$> trQual l <*> act x++negateLiteral :: Literal -> Literal+negateLiteral (Int    i) = Int   (-i)+negateLiteral (Float  f) = Float (-f)+negateLiteral _          = internalError "GenAbstractCurry.negateLiteral"++cvLiteral :: Literal -> CLiteral+cvLiteral (Char   c) = CCharc   c+cvLiteral (Int    i) = CIntc    i+cvLiteral (Float  f) = CFloatc  f+cvLiteral (String s) = CStringc s++trQual :: QualIdent -> GAC QName+trQual qid+  | n `elem` [unitId, listId, nilId, consId] = return ("Prelude", idName n)+  | isTupleId n                              = return ("Prelude", idName n)+  | otherwise+  = return (maybe "" moduleName (qidModule qid), idName n)+  where n = qidIdent qid++trGlobalIdent :: Ident -> GAC QName+trGlobalIdent i = S.gets moduleId >>= \m -> return (moduleName m, idName i)++trLocalIdent :: Ident -> GAC QName+trLocalIdent i = return ("", idName i)++qFlip :: QualIdent+qFlip = qualifyWith preludeMIdent (mkIdent "flip")++qNegateId :: QualIdent+qNegateId = qualifyWith preludeMIdent (mkIdent "negate")++qIfThenElseId :: QualIdent+qIfThenElseId = qualifyWith preludeMIdent (mkIdent "ifThenElse")++prelUntyped :: QualIdent+prelUntyped = qualifyWith preludeMIdent $ mkIdent "untyped"++-------------------------------------------------------------------------------+-- This part defines an environment containing all necessary information+-- for generating the AbstractCurry representation of a CurrySyntax term.++-- |Data type for representing an AbstractCurry generator environment+data AbstractEnv = AbstractEnv+  { moduleId   :: ModuleIdent                -- ^name of the module+  , typeEnv    :: ValueEnv                   -- ^known values+  , tyExports  :: Set.Set Ident              -- ^exported type symbols+  , valExports :: Set.Set Ident              -- ^exported value symbols+  , varIndex   :: Int                        -- ^counter for variable indices+  , tvarIndex  :: Int                        -- ^counter for type variable indices+  , varEnv     :: NestEnv Int                -- ^stack of variable tables+  , tvarEnv    :: NestEnv Int                -- ^stack of type variable tables+  , untypedAcy :: Bool                       -- ^flag to indicate whether untyped+                                             --  AbstractCurry is generated+  , typeSigs   :: Map.Map Ident QualTypeExpr -- ^map of user defined type signatures+  } deriving Show++-- |Initialize the AbstractCurry generator environment+abstractEnv :: Bool -> CompilerEnv -> Module a -> AbstractEnv+abstractEnv uacy env (Module _ _ _ mid es _ ds) = AbstractEnv+  { moduleId   = mid+  , typeEnv    = valueEnv env+  , tyExports  = foldr (buildTypeExports  mid) Set.empty es'+  , valExports = foldr (buildValueExports mid) Set.empty es'+  , varIndex   = 0+  , tvarIndex  = 0+  , varEnv     = globalEnv emptyTopEnv+  , tvarEnv    = globalEnv emptyTopEnv+  , untypedAcy = uacy+  , typeSigs   = if uacy+                  then Map.fromList $ signatures ds+                  else Map.empty+  }+  where es' = case es of+          Just (Exporting _ e) -> e+          _                    -> internalError "GenAbstractCurry.abstractEnv"++-- Builds a table containing all exported identifiers from a module.+buildTypeExports :: ModuleIdent -> Export -> Set.Set Ident -> Set.Set Ident+buildTypeExports mid (ExportTypeWith _ tc _)+  | isLocalIdent mid tc = Set.insert (unqualify tc)+buildTypeExports _   _  = id++-- Builds a table containing all exported identifiers from a module.+buildValueExports :: ModuleIdent -> Export -> Set.Set Ident -> Set.Set Ident+buildValueExports mid (Export             _ q)+  | isLocalIdent mid q  = Set.insert (unqualify q)+buildValueExports mid (ExportTypeWith _ tc cs)+  | isLocalIdent mid tc = flip (foldr Set.insert) cs+buildValueExports _   _  = id++-- Looks up the unique index for the variable 'ident' in the+-- variable table of the current scope.+lookupVarIndex :: Ident -> GAC (Maybe CVarIName)+lookupVarIndex i = S.gets $ \env -> case lookupNestEnv i $ varEnv env of+  [v] -> Just (v, idName i)+  _   -> Nothing++getVarIndex :: Ident -> GAC CVarIName+getVarIndex i = S.get >>= \env -> case lookupNestEnv i $ varEnv env of+  [v] -> return (v, idName i)+  _   -> genVarIndex i++-- Generates an unique index for the  variable 'ident' and inserts it+-- into the  variable table of the current scope.+genVarIndex :: Ident -> GAC CVarIName+genVarIndex i = do+  env <- S.get+  let idx = varIndex env+  S.put $ env { varIndex = idx + 1, varEnv = bindNestEnv i idx (varEnv env) }+  return (idx, idName i)++-- Looks up the unique index for the type variable 'ident' in the type+-- variable table of the current scope.+getTVarIndex :: Ident -> GAC CTVarIName+getTVarIndex i = S.get >>= \env -> case lookupNestEnv i $ tvarEnv env of+  [v] -> return (v, idName i)+  _   -> genTVarIndex i++-- Generates an unique index for the type variable 'ident' and inserts it+-- into the type variable table of the current scope.+genTVarIndex :: Ident -> GAC CTVarIName+genTVarIndex i = do+  env <- S.get+  let idx = tvarIndex env+  S.put $ env { tvarIndex = idx + 1, tvarEnv = bindNestEnv i idx (tvarEnv env) }+  return (idx, idName i)++withLocalEnv :: GAC a -> GAC a+withLocalEnv act = do+  old <- S.get+  res <- act+  S.put old+  return res++inNestedScope :: GAC a -> GAC a+inNestedScope act = do+  (vo, to) <- S.gets $ \e -> (varEnv e, tvarEnv e)+  S.modify $ \e -> e { varEnv = nestEnv $ vo, tvarEnv = globalEnv emptyTopEnv }+  res <- act+  S.modify $ \e -> e { varEnv = vo, tvarEnv = to }+  return res++inNestedTScope :: GAC a -> GAC a+inNestedTScope act = do+  (vo, to) <- S.gets $ \e -> (varEnv e, tvarEnv e)+  S.modify $ \e -> e { varEnv = globalEnv emptyTopEnv, tvarEnv = nestEnv $ to }+  res <- act+  S.modify $ \e -> e { varEnv = vo, tvarEnv = to }+  return res++getQualType :: Ident -> PredType -> GAC CQualTypeExpr+getQualType f pty = do+  uacy <- S.gets untypedAcy+  sigs <- S.gets typeSigs+  trQualTypeExpr $ case uacy of+    True  -> Maybe.fromMaybe (QualTypeExpr NoSpanInfo [] $+                               ConstructorType NoSpanInfo prelUntyped)+                             (Map.lookup f sigs)+    False -> fromPredType identSupply pty++getQualType' :: QualIdent -> GAC QualTypeExpr+getQualType' f = do+  m     <- S.gets moduleId+  tyEnv <- S.gets typeEnv+  return $ case qualLookupValue f tyEnv of+    [Value _ _ _ (ForAll _ pty)] -> fromPredType identSupply pty+    _                          -> case qualLookupValue (qualQualify m f) tyEnv of+      [Value _ _ _ (ForAll _ pty)] -> fromPredType identSupply pty+      _                          ->+        internalError $ "GenAbstractCurry.getQualType': " ++ show f++getTypeVisibility :: Ident -> GAC CVisibility+getTypeVisibility i = S.gets $ \env ->+  if Set.member i (tyExports env) then Public else Private++getVisibility :: Ident -> GAC CVisibility+getVisibility i = S.gets $ \env ->+  if Set.member i (valExports env) then Public else Private++signatures :: [Decl a] -> [(Ident, QualTypeExpr)]+signatures ds = [(f, qty) | TypeSig _ fs qty <- ds, f <- fs]
+ src/Generators/GenAnnotatedFlatCurry.hs view
@@ -0,0 +1,488 @@+{- |+    Module      :  $Header$+    Description :  Generation of typed FlatCurry program terms+    Copyright   :  (c) 2017        Finn Teegen+                       2018        Kai-Oliver Prott+    License     :  BSD-3-clause++    Maintainer  :  fte@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module contains the generation of a type-annotated 'FlatCurry'+    program term for a given module in the intermediate language.+-}+{-# LANGUAGE CPP #-}+module Generators.GenAnnotatedFlatCurry (genAnnotatedFlatCurry) where++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative        ((<$>), (<*>))+#endif+import           Control.Monad              ((<=<))+import           Control.Monad.Extra        (concatMapM)+import qualified Control.Monad.State as S   ( State, evalState, get, gets+                                            , modify, put )+import           Data.Function              (on)+import           Data.List                  (nub, sortBy)+import           Data.Maybe                 (fromMaybe)+import qualified Data.Map            as Map (Map, empty, insert, lookup)+import qualified Data.Set            as Set (Set, empty, insert, member)++import           Curry.Base.Ident+import           Curry.FlatCurry.Annotated.Goodies (typeName)+import           Curry.FlatCurry.Annotated.Type+import qualified Curry.Syntax as CS++import Base.Messages       (internalError)+import Base.NestEnv        ( NestEnv, emptyEnv, bindNestEnv, lookupNestEnv+                           , nestEnv, unnestEnv )+import Base.Types++import CompilerEnv+import Env.TypeConstructor (TCEnv)++import qualified IL++-- transforms intermediate language code (IL) to type-annotated FlatCurry code+genAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module+                  -> AProg TypeExpr+genAnnotatedFlatCurry env mdl il = patchPrelude $ run env mdl (trModule il)++-- -----------------------------------------------------------------------------+-- Addition of primitive types for lists and tuples to the Prelude+-- -----------------------------------------------------------------------------++patchPrelude :: AProg a -> AProg a+patchPrelude p@(AProg n _ ts fs os)+  | n == prelude = AProg n [] ts' fs os+  | otherwise    = p+  where ts' = sortBy (compare `on` typeName) pts+        pts = primTypes ++ ts++primTypes :: [TypeDecl]+primTypes =+  [ Type arrow Public [(0, KStar), (1, KStar)] []+  , Type unit Public [] [(Cons unit 0 Public [])]+  , Type nil Public [(0, KStar)] [ Cons nil  0 Public []+                                 , Cons cons 2 Public [TVar 0, TCons nil [TVar 0]]+                                 ]+  ] ++ map mkTupleType [2 .. maxTupleArity]+  where arrow = mkPreludeQName "(->)"+        unit  = mkPreludeQName "()"+        nil   = mkPreludeQName "[]"+        cons  = mkPreludeQName ":"++mkTupleType :: Int -> TypeDecl+mkTupleType arity = Type tuple Public [(i, KStar) | i <- [0 .. arity - 1]]+  [Cons tuple arity Public $ map TVar [0 .. arity - 1]]+  where tuple = mkPreludeQName $ '(' : replicate (arity - 1) ',' ++ ")"++mkPreludeQName :: String -> QName+mkPreludeQName n = (prelude, n)++prelude :: String+prelude = "Prelude"++-- |Maximal arity of tuples+maxTupleArity :: Int+maxTupleArity = 15++-- -----------------------------------------------------------------------------++-- The environment 'FlatEnv' is embedded in the monadic representation+-- 'FlatState' which allows the usage of 'do' expressions.+type FlatState a = S.State FlatEnv a++-- Data type for representing an environment which contains information needed+-- for generating FlatCurry code.+data FlatEnv = FlatEnv+  { modIdent     :: ModuleIdent      -- current module+  -- for visibility calculation+  , tyExports    :: Set.Set Ident    -- exported types+  , valExports   :: Set.Set Ident    -- exported values (functions + constructors)+  , tcEnv        :: TCEnv            -- type constructor environment+  , typeSynonyms :: [CS.Decl Type]   -- type synonyms+  , imports      :: [ModuleIdent]    -- module imports+  -- state for mapping identifiers to indexes+  , nextVar      :: Int              -- fresh variable index counter+  , varMap       :: NestEnv VarIndex -- map of identifier to variable index+  }++-- Runs a 'FlatState' action and returns the result+run :: CompilerEnv -> CS.Module Type -> FlatState a -> a+run env (CS.Module _ _ _ mid es is ds) act = S.evalState act env0+  where+  es'  = case es of Just (CS.Exporting _ e) -> e+                    _                       -> []+  env0 = FlatEnv+    { modIdent     = mid+     -- for visibility calculation+    , tyExports  = foldr (buildTypeExports  mid) Set.empty es'+    , valExports = foldr (buildValueExports mid) Set.empty es'+    -- This includes *all* imports, even unused ones+    , imports      = nub [ m | CS.ImportDecl _ m _ _ _ <- is ]+    -- Environment to retrieve the type of identifiers+    , tcEnv        = tyConsEnv env+    -- Type synonyms in the module+    , typeSynonyms = [ d | d@CS.TypeDecl{} <- ds ]+    , nextVar      = 0+    , varMap       = emptyEnv+    }++-- Builds a table containing all exported identifiers from a module.+buildTypeExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident+buildTypeExports mid (CS.ExportTypeWith _ tc _)+  | isLocalIdent mid tc = Set.insert (unqualify tc)+buildTypeExports _   _  = id++-- Builds a table containing all exported identifiers from a module.+buildValueExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident+buildValueExports mid (CS.Export         _     q)+  | isLocalIdent mid q  = Set.insert (unqualify q)+buildValueExports mid (CS.ExportTypeWith _ tc cs)+  | isLocalIdent mid tc = flip (foldr Set.insert) cs+buildValueExports _   _  = id++getModuleIdent :: FlatState ModuleIdent+getModuleIdent = S.gets modIdent++-- Retrieve imports+getImports :: [ModuleIdent] -> FlatState [String]+getImports imps = (nub . map moduleName . (imps ++)) <$> S.gets imports++-- -----------------------------------------------------------------------------+-- Stateful part, used for translation of rules and expressions+-- -----------------------------------------------------------------------------++-- resets var index and environment+withFreshEnv :: FlatState a -> FlatState a+withFreshEnv act = S.modify (\ s -> s { nextVar = 0, varMap = emptyEnv }) >> act++-- Execute an action in a nested variable mapping+inNestedEnv :: FlatState a -> FlatState a+inNestedEnv act = do+  S.modify $ \ s -> s { varMap = nestEnv   $ varMap s }+  res <- act+  S.modify $ \ s -> s { varMap = unnestEnv $ varMap s }+  return res++-- Generates a new variable index for an identifier+newVar :: IL.Type -> Ident -> FlatState (VarIndex, TypeExpr)+newVar ty i = do+  idx <- (+1) <$> S.gets nextVar+  S.modify $ \ s -> s { nextVar = idx, varMap = bindNestEnv i idx (varMap s) }+  ty' <- trType ty+  return (idx, ty')++-- Retrieve the variable index assigned to an identifier+getVarIndex :: Ident -> FlatState VarIndex+getVarIndex i = S.gets varMap >>= \ varEnv -> case lookupNestEnv i varEnv of+  [v] -> return v+  _   -> internalError $ "GenTypeAnnotatedFlatCurry.getVarIndex: " ++ escName i++-- -----------------------------------------------------------------------------+-- Translation of a module+-- -----------------------------------------------------------------------------++trModule :: IL.Module -> FlatState (AProg TypeExpr)+trModule (IL.Module mid is ds) = do+  is' <- getImports is+  tds <- concatMapM trTypeDecl ds+  fds <- concatMapM (return . map runNormalization <=< trAFuncDecl) ds+  return $ AProg (moduleName mid) is' tds fds []++-- Translate a data declaration+-- For empty data declarations, an additional constructor is generated. This+-- is due to the fact that external data declarations are translated into data+-- declarations with zero constructors and without the additional constructor+-- empty data declarations could not be distinguished from external ones.+trTypeDecl :: IL.Decl -> FlatState [TypeDecl]+trTypeDecl (IL.DataDecl      qid ks []) = do+  q'  <- trQualIdent qid+  vis <- getTypeVisibility qid+  c   <- trQualIdent $ qualify (mkIdent $ "_Constr#" ++ idName (unqualify qid))+  let ks' = trKind <$> ks+      tvs = zip [0..] ks'+  return [Type q' vis tvs [Cons c 1 Private [TCons q' $ TVar <$> fst <$> tvs]]]+trTypeDecl (IL.DataDecl      qid ks cs) = do+  q'  <- trQualIdent qid+  vis <- getTypeVisibility qid+  cs' <- mapM trConstrDecl cs+  let ks' = trKind <$> ks+      tvs = zip [0..] ks'+  return [Type q' vis tvs cs']+trTypeDecl (IL.NewtypeDecl   qid ks nc) = do+  q'  <- trQualIdent qid+  vis <- getTypeVisibility qid+  nc' <- trNewConstrDecl nc+  let ks' = trKind <$> ks+      tvs = zip [0..] ks'+  return [TypeNew q' vis tvs nc']+trTypeDecl (IL.ExternalDataDecl qid ks) = do+  q'  <- trQualIdent qid+  vis <- getTypeVisibility qid+  let ks' = trKind <$> ks+      tvs = zip [0..] ks'+  return [Type q' vis tvs []]+trTypeDecl _                           = return []++-- Translate a constructor declaration+trConstrDecl :: IL.ConstrDecl -> FlatState ConsDecl+trConstrDecl (IL.ConstrDecl qid tys) = flip Cons (length tys)+  <$> trQualIdent qid+  <*> getVisibility qid+  <*> mapM trType tys++-- Translate a constructor declaration for newtypes+trNewConstrDecl :: IL.NewConstrDecl -> FlatState NewConsDecl+trNewConstrDecl (IL.NewConstrDecl qid ty) = NewCons+  <$> trQualIdent qid+  <*> getVisibility qid+  <*> trType ty++-- Translate a type expression+trType :: IL.Type -> FlatState TypeExpr+trType (IL.TypeConstructor t tys) = TCons <$> trQualIdent t <*> mapM trType tys+trType (IL.TypeVariable      idx) = return $ TVar $ abs idx+trType (IL.TypeArrow     ty1 ty2) = FuncType <$> trType ty1 <*> trType ty2+trType (IL.TypeForall    idxs ty) = ForallType (map trTVarWithKind idxs) <$> trType ty++-- Translates a type variable with kind.+trTVarWithKind :: (Int, IL.Kind) -> (Int, Kind)+trTVarWithKind (i, k) = (abs i, trKind k)++-- Translate a kind+trKind :: IL.Kind -> Kind+trKind IL.KindStar          = KStar+trKind (IL.KindVariable  _) = KStar+trKind (IL.KindArrow k1 k2) = KArrow (trKind k1) (trKind k2)++-- -----------------------------------------------------------------------------+-- Function declarations+-- -----------------------------------------------------------------------------++-- Translate a function declaration+trAFuncDecl :: IL.Decl -> FlatState [AFuncDecl TypeExpr]+trAFuncDecl (IL.FunctionDecl f vs ty e) = do+  f'  <- trQualIdent f+  vis <- getVisibility f+  ty' <- trType ty+  r'  <- trARule ty vs e+  return [AFunc f' (length vs) vis ty' r']+trAFuncDecl (IL.ExternalDecl    f a ty) = do+  f'   <- trQualIdent f+  vis  <- getVisibility f+  ty'  <- trType ty+  r'   <- trAExternal ty f --TODO: get arity from type?+  return [AFunc f' a vis ty' r']+trAFuncDecl _                           = return []++-- Translate a function rule.+-- Resets variable index so that for every rule variables start with index 1+trARule :: IL.Type -> [(IL.Type, Ident)] -> IL.Expression+        -> FlatState (ARule TypeExpr)+trARule ty vs e = withFreshEnv $ ARule <$> trType ty+                                    <*> mapM (uncurry newVar) vs+                                    <*> trAExpr e++trAExternal :: IL.Type -> QualIdent -> FlatState (ARule TypeExpr)+trAExternal ty f = flip AExternal (qualName f) <$> trType ty++-- Translate an expression+trAExpr :: IL.Expression -> FlatState (AExpr TypeExpr)+trAExpr (IL.Literal       ty l) = ALit <$> trType ty <*> trLiteral l+trAExpr (IL.Variable      ty v) = AVar <$> trType ty <*> getVarIndex v+trAExpr (IL.Function    ty f a) = genCall Fun ty f a []+trAExpr (IL.Constructor ty c a) = genCall Con ty c a []+trAExpr (IL.Apply        e1 e2) = trApply e1 e2+trAExpr c@(IL.Case      t e bs) = flip ACase (cvEval t) <$> trType (IL.typeOf c) <*> trAExpr e+                                  <*> mapM (inNestedEnv . trAlt) bs+trAExpr (IL.Or           e1 e2) = AOr <$> trType (IL.typeOf e1) <*> trAExpr e1 <*> trAExpr e2+trAExpr (IL.Exist       v ty e) = inNestedEnv $ do+  v' <- newVar ty v+  e' <- trAExpr e+  ty' <- trType (IL.typeOf e)+  return $ case e' of AFree ty'' vs e'' -> AFree ty'' (v' : vs) e''+                      _                 -> AFree ty'  (v' : []) e'+trAExpr (IL.Let (IL.Binding v b) e) = inNestedEnv $ do+  v' <- newVar (IL.typeOf b) v+  b' <- trAExpr b+  e' <- trAExpr e+  ty' <- trType $ IL.typeOf e+  return $ case e' of ALet ty'' bs e'' -> ALet ty'' ((v', b'):bs) e''+                      _                -> ALet ty'  ((v', b'):[]) e'+trAExpr (IL.Letrec   bs e) = inNestedEnv $ do+  let (vs, es) = unzip [ ((IL.typeOf b, v), b) | IL.Binding v b <- bs]+  ALet <$> trType (IL.typeOf e)+       <*> (zip <$> mapM (uncurry newVar) vs <*> mapM trAExpr es)+       <*> trAExpr e+trAExpr (IL.Typed e ty) = ATyped <$> ty' <*> trAExpr e <*> ty'+  where ty' = trType $ ty++-- Translate a literal+trLiteral :: IL.Literal -> FlatState Literal+trLiteral (IL.Char  c) = return $ Charc  c+trLiteral (IL.Int   i) = return $ Intc   i+trLiteral (IL.Float f) = return $ Floatc f++-- Translate a higher-order application+trApply :: IL.Expression -> IL.Expression -> FlatState (AExpr TypeExpr)+trApply e1 e2 = genFlatApplic e1 [e2]+  where+  genFlatApplic e es = case e of+    IL.Apply        ea eb -> genFlatApplic ea (eb:es)+    IL.Function    ty f a -> genCall Fun ty f a es+    IL.Constructor ty c a -> genCall Con ty c a es+    _ -> do+      expr <- trAExpr e+      genApply expr es++-- Translate an alternative+trAlt :: IL.Alt -> FlatState (ABranchExpr TypeExpr)+trAlt (IL.Alt p e) = ABranch <$> trPat p <*> trAExpr e++-- Translate a pattern+trPat :: IL.ConstrTerm -> FlatState (APattern TypeExpr)+trPat (IL.LiteralPattern        ty l) = ALPattern <$> trType ty <*> trLiteral l+trPat (IL.ConstructorPattern ty c vs) = do+  qty <- trType $ foldr IL.TypeArrow ty $ map fst vs+  APattern  <$> trType ty <*> ((\q -> (q, qty)) <$> trQualIdent c) <*> mapM (uncurry newVar) vs+trPat (IL.VariablePattern        _ _) = internalError "GenTypeAnnotatedFlatCurry.trPat"++-- Convert a case type+cvEval :: IL.Eval -> CaseType+cvEval IL.Rigid = Rigid+cvEval IL.Flex  = Flex++data Call = Fun | Con++-- Generate a function or constructor call+genCall :: Call -> IL.Type -> QualIdent -> Int -> [IL.Expression]+        -> FlatState (AExpr TypeExpr)+genCall call ty f arity es = do+  f'    <- trQualIdent f+  case compare supplied arity of+    LT -> genAComb ty f' es (part call (arity - supplied))+    EQ -> genAComb ty f' es (full call)+    GT -> do+      let (es1, es2) = splitAt arity es+      funccall <- genAComb ty f' es1 (full call)+      genApply funccall es2+  where+  supplied = length es+  full Fun = FuncCall+  full Con = ConsCall+  part Fun = FuncPartCall+  part Con = ConsPartCall++genAComb :: IL.Type -> QName -> [IL.Expression] -> CombType -> FlatState (AExpr TypeExpr)+genAComb ty qid es ct = do+  ty' <- trType ty+  let ty'' = defunc ty' (length es)+  AComb ty'' ct (qid, ty') <$> mapM trAExpr es+  where+  defunc t               0 = t+  defunc (FuncType _ t2) n = defunc t2 (n - 1)+  defunc _               _ = internalError "GenTypeAnnotatedFlatCurry.genAComb.defunc"++genApply :: AExpr TypeExpr -> [IL.Expression] -> FlatState (AExpr TypeExpr)+genApply e es = do+  ap  <- trQualIdent $ qApplyId+  es' <- mapM trAExpr es+  return $ foldl (\e1 e2 -> let FuncType ty1 ty2 = typeOf e1 in AComb ty2 FuncCall (ap, FuncType (FuncType ty1 ty2) (FuncType ty1 ty2)) [e1, e2]) e es'++-- -----------------------------------------------------------------------------+-- Normalization+-- -----------------------------------------------------------------------------++runNormalization :: Normalize a => a -> a+runNormalization x = S.evalState (normalize x) (0, Map.empty)++type NormState a = S.State (Int, Map.Map Int Int) a++class Normalize a where+  normalize :: a -> NormState a++instance Normalize a => Normalize [a] where+  normalize = mapM normalize++instance Normalize Int where+  normalize i = do+    (n, m) <- S.get+    case Map.lookup i m of+      Nothing -> do+        S.put (n + 1, Map.insert i n m)+        return n+      Just n' -> return n'++instance Normalize TypeExpr where+  normalize (TVar           i) = TVar <$> normalize i+  normalize (TCons      q tys) = TCons q <$> normalize tys+  normalize (FuncType ty1 ty2) = FuncType <$> normalize ty1 <*> normalize ty2+  normalize (ForallType is ty) = ForallType <$> mapM normalizeTypeVar is+                                            <*> normalize ty+    where normalizeTypeVar (tv, k) = (,) <$> normalize tv <*> pure k++instance Normalize a => Normalize (AFuncDecl a) where+  normalize (AFunc f a v ty r) = AFunc f a v <$> normalize ty <*> normalize r++instance Normalize a => Normalize (ARule a) where+  normalize (ARule     ty vs e) = ARule <$> normalize ty+                                        <*> mapM normalizeTuple vs+                                        <*> normalize e+  normalize (AExternal ty    s) = flip AExternal s <$> normalize ty++normalizeTuple :: Normalize b => (a, b) -> NormState (a, b)+normalizeTuple (a, b) = (,) <$> pure a <*> normalize b  ++instance Normalize a => Normalize (AExpr a) where+  normalize (AVar  ty       v) = flip AVar  v  <$> normalize ty+  normalize (ALit  ty       l) = flip ALit  l  <$> normalize ty+  normalize (AComb ty ct f es) = flip AComb ct <$> normalize ty+                                               <*> normalizeTuple f+                                               <*> normalize es+  normalize (ALet  ty    ds e) = ALet <$> normalize ty+                                      <*> mapM normalizeBinding ds+                                      <*> normalize e+    where normalizeBinding (v, b) = (,) <$> normalizeTuple v <*> normalize b+  normalize (AOr   ty     a b) = AOr <$> normalize ty <*> normalize a+                                     <*> normalize b+  normalize (ACase ty ct e bs) = flip ACase ct <$> normalize ty <*> normalize e+                                               <*> normalize bs+  normalize (AFree  ty   vs e) = AFree <$> normalize ty+                                       <*> mapM normalizeTuple vs+                                       <*> normalize e+  normalize (ATyped ty  e ty') = ATyped <$> normalize ty <*> normalize e+                                        <*> normalize ty'++instance Normalize a => Normalize (ABranchExpr a) where+  normalize (ABranch p e) = ABranch <$> normalize p <*> normalize e++instance Normalize a => Normalize (APattern a) where+  normalize (APattern  ty c vs) = APattern <$> normalize ty+                                           <*> normalizeTuple c+                                           <*> mapM normalizeTuple vs+  normalize (ALPattern ty    l) = flip ALPattern l <$> normalize ty++-- -----------------------------------------------------------------------------+-- Helper functions+-- -----------------------------------------------------------------------------++trQualIdent :: QualIdent -> FlatState QName+trQualIdent qid = do+  mid <- getModuleIdent+  return $ (moduleName $ fromMaybe mid mid', idName i)+  where+  mid' | i `elem` [listId, consId, nilId, unitId] || isTupleId i+       = Just preludeMIdent+       | otherwise+       = qidModule qid+  i = qidIdent qid++getTypeVisibility :: QualIdent -> FlatState Visibility+getTypeVisibility i = S.gets $ \s ->+  if Set.member (unqualify i) (tyExports s) then Public else Private++getVisibility :: QualIdent -> FlatState Visibility+getVisibility i = S.gets $ \s ->+  if Set.member (unqualify i) (valExports s) then Public else Private
+ src/Generators/GenFlatCurry.hs view
@@ -0,0 +1,56 @@+{- |+    Module      :  $Header$+    Description :  Generation of FlatCurry program and interface terms+    Copyright   :  (c) 2017        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module contains the generation of a 'FlatCurry' program term or+    a 'FlatCurry' interface out of an 'Annotated FlatCurry' module.+-}+module Generators.GenFlatCurry (genFlatCurry, genFlatInterface) where++import Curry.FlatCurry.Goodies+import Curry.FlatCurry.Type+import Curry.FlatCurry.Annotated.Goodies+import Curry.FlatCurry.Annotated.Type++-- transforms annotated FlatCurry code to FlatCurry code+genFlatCurry :: AProg TypeExpr -> Prog+genFlatCurry = trAProg+  (\name imps types funcs ops ->+    Prog name imps types (map genFlatFuncDecl funcs) ops)++genFlatFuncDecl :: AFuncDecl TypeExpr -> FuncDecl+genFlatFuncDecl = trAFunc+  (\name arity vis ty rule -> Func name arity vis ty $ genFlatRule rule)++genFlatRule :: ARule TypeExpr -> Rule+genFlatRule = trARule+  (\_ args e -> Rule (map fst args) $ genFlatExpr e)+  (const External)++genFlatExpr :: AExpr TypeExpr -> Expr+genFlatExpr = trAExpr+  (const Var)+  (const Lit)+  (\_ ct (name, _) args -> Comb ct name args)+  (const $ Let . map (\(v, e') -> (fst v, e')))+  (const $ Free . map fst)+  (const Or)+  (const Case)+  (Branch . genFlatPattern)+  (const Typed)++genFlatPattern :: APattern TypeExpr -> Pattern+genFlatPattern = trAPattern+  (\_ (name, _) args -> Pattern name $ map fst args)+  (const LPattern)++-- transforms a FlatCurry module to a FlatCurry interface+genFlatInterface :: Prog -> Prog+genFlatInterface =+  updProgFuncs $ map $ updFuncRule $ const $ Rule [] $ Var 0
+ src/Generators/GenTypedFlatCurry.hs view
@@ -0,0 +1,53 @@+{- |+    Module      :  $Header$+    Description :  Generation of typed FlatCurry program terms+    Copyright   :  (c) 2017        Finn Teegen+                       2018        Kai-Oliver Prott+    License     :  BSD-3-clause++    Maintainer  :  fte@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module contains the generation of a typed 'FlatCurry' program term+    for a given module in the intermediate language.+-}+{-# LANGUAGE CPP #-}+module Generators.GenTypedFlatCurry (genTypedFlatCurry) where++import Curry.FlatCurry.Annotated.Type+import Curry.FlatCurry.Annotated.Goodies+import Curry.FlatCurry.Typed.Type++-- transforms annotated FlatCurry code to typed FlatCurry code+genTypedFlatCurry :: AProg TypeExpr -> TProg+genTypedFlatCurry = trAProg+  (\name imps types funcs ops ->+    TProg name imps types (map genTypedFuncDecl funcs) ops)++genTypedFuncDecl :: AFuncDecl TypeExpr -> TFuncDecl+genTypedFuncDecl = trAFunc+  (\name arity vis ty rule -> TFunc name arity vis ty $ genTypedRule rule)++genTypedRule :: ARule TypeExpr -> TRule+genTypedRule = trARule+  (\_ args e -> TRule args $ genTypedExpr e)+  TExternal++genTypedExpr :: AExpr TypeExpr -> TExpr+genTypedExpr = trAExpr+  TVarE+  TLit+  (\ty ct (name, _) args -> TComb ty ct name args)+  (const TLet)+  (const TFree)+  (const TOr)+  (const TCase)+  (TBranch . genTypedPattern)+  (const TTyped)++genTypedPattern :: APattern TypeExpr -> TPattern+genTypedPattern = trAPattern+  (\ty (name, _) args -> TPattern ty name args)+  TLPattern+
+ src/Html/CurryHtml.hs view
@@ -0,0 +1,185 @@+{- |+    Module      :  $Header$+    Description :  Generating HTML documentation+    Copyright   :  (c) 2011 - 2016, Björn Peemöller+                       2016       , Jan Tikovsky+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module defines a function for generating HTML documentation pages+    for Curry source modules.+-}+{-# LANGUAGE TemplateHaskell   #-}+module Html.CurryHtml (source2html) where++import Prelude         as P+import Control.Monad.Writer+import Data.List             (mapAccumL)+import Data.Maybe            (fromMaybe, isJust)+import Data.ByteString as BS (ByteString, writeFile)+import Data.FileEmbed+import Network.URI           (escapeURIString, isUnreserved)+import System.FilePath       ((</>))++import Curry.Base.Ident      ( ModuleIdent (..), Ident (..), QualIdent (..)+                             , unqualify, moduleName)+import Curry.Base.Monad      (CYIO)+import Curry.Base.Position   (Position)+import Curry.Files.Filenames (htmlName)+import Curry.Syntax          (Module (..), Token)++import Html.SyntaxColoring+++import CompilerOpts          (Options (..))++-- |Read file via TemplateHaskell at compile time+cssContent :: ByteString+cssContent = $(makeRelativeToProject "data/currysource.css" >>= embedFile)++-- | Name of the css file+-- NOTE: The relative path is given above+cssFileName :: String+cssFileName = "currysource.css"++-- |Translate source file into HTML file with syntaxcoloring+source2html :: Options -> ModuleIdent -> [(Position, Token)] -> Module a+            -> CYIO ()+source2html opts mid toks mdl = do+  liftIO $ P.writeFile (outDir </> htmlName mid) doc+  updateCSSFile outDir+  where+  doc    = program2html mid (genProgram mdl toks)+  outDir = fromMaybe "." (optHtmlDir opts)++-- |Update the CSS file+updateCSSFile :: FilePath -> CYIO ()+updateCSSFile dir = do+  let target = dir </> cssFileName+  liftIO $ BS.writeFile target cssContent++-- generates htmlcode with syntax highlighting+-- @param modulname+-- @param a program+-- @return HTMLcode+program2html :: ModuleIdent -> [Code] -> String+program2html m codes = unlines+  [ "<!DOCTYPE html>"+  , "<html lang=\"en\">"+  , "<head>"+  , "<meta charset=\"utf-8\">"+  , "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1.0\">"+  , "<title>" ++ titleHtml ++ "</title>"+  , "<link rel=\"stylesheet\" href=\"" ++ cssFileName ++ "\">"+  , "</head>"+  , "<body>"+  , "<table><tbody><tr>"+  , "<td class=\"line-numbers\"><pre>" ++ lineHtml ++ "</pre></td>"+  , "<td class=\"source-code\"><pre>" ++ codeHtml ++ "</pre></td>"+  , "</tr></tbody></table>"+  , "</body>"+  , "</html>"+  ]+  where+  titleHtml = "Module " ++ moduleName m+  lineHtml  = unlines $ map show [1 .. length (lines codeHtml)]+  codeHtml  = concat $ snd $ mapAccumL (code2html m) [] codes++code2html :: ModuleIdent -> [QualIdent] -> Code -> ([QualIdent], String)+code2html m defs c+  | isCall c  = (defs, maybe tag (addEntityLink m tag) (getQualIdent c))+  | isDecl c  = case getQualIdent c of+      Just i | i `notElem` defs+        -> (i:defs, spanTag (code2class c) (escIdent i) (escCode c))+      _ -> (defs, tag)+  | otherwise = case c of+      ModuleName m' -> (defs, addModuleLink m m' tag)+      _             -> (defs, tag)+  where tag = spanTag (code2class c) "" (escCode c)++escCode :: Code -> String+escCode = htmlQuote . code2string++escIdent :: QualIdent -> String+escIdent = htmlQuote . idName . unqualify++spanTag :: String -> String -> String -> String+spanTag clV idV str+  | null clV && null idV = str+  | otherwise            = "<span" ++ codeclass ++ idValue ++ ">"+                           ++ str ++ "</span>"+  where+  codeclass = if null clV then "" else " class=\"" ++ clV ++ "\""+  idValue   = if null idV then "" else " id=\"" ++ idV ++ "\""++-- which code has which css class+-- @param code+-- @return css class of the code+code2class :: Code -> String+code2class (Space          _) = ""+code2class NewLine            = ""+code2class (Keyword        _) = "keyword"+code2class (Pragma         _) = "pragma"+code2class (Symbol         _) = "symbol"+code2class (TypeCons   _ _ _) = "type"+code2class (DataCons   _ _ _) = "cons"+code2class (Function   _ _ _) = "func"+code2class (Identifier _ _ _) = "ident"+code2class (ModuleName     _) = "module"+code2class (Commentary     _) = "comment"+code2class (NumberCode     _) = "number"+code2class (StringCode     _) = "string"+code2class (CharCode       _) = "char"++addModuleLink :: ModuleIdent -> ModuleIdent -> String -> String+addModuleLink m m' str+  = "<a href=\"" ++ makeRelativePath m m' ++ "\">" ++ str ++ "</a>"++addEntityLink :: ModuleIdent -> String -> QualIdent -> String+addEntityLink m str qid =+  "<a href=\"" ++ modPath ++ "#" ++ fragment  ++ "\">" ++ str ++ "</a>"+  where+  modPath       = maybe "" (makeRelativePath m) mmid+  fragment      = string2urlencoded (idName ident)+  (mmid, ident) = (qidModule qid, qidIdent qid)++makeRelativePath :: ModuleIdent -> ModuleIdent -> String+makeRelativePath cur new  | cur == new = ""+                          | otherwise  = htmlName new++isCall :: Code -> Bool+isCall (TypeCons   TypeExport _ _) = True+isCall (TypeCons   TypeImport _ _) = True+isCall (TypeCons   TypeRefer  _ _) = True+isCall (TypeCons   _          _ _) = False+isCall (Identifier _          _ _) = False+isCall c                       = not (isDecl c) && isJust (getQualIdent c)++isDecl :: Code -> Bool+isDecl (DataCons ConsDeclare _ _) = True+isDecl (Function FuncDeclare _ _) = True+isDecl (TypeCons TypeDeclare _ _) = True+isDecl _                          = False++-- Translates arbitrary strings into equivalent urlencoded string.+string2urlencoded :: String -> String+string2urlencoded = escapeURIString isUnreserved++htmlQuote :: String -> String+htmlQuote [] = []+htmlQuote (c : cs)+  | c == '<'  = "&lt;"    ++ htmlQuote cs+  | c == '>'  = "&gt;"    ++ htmlQuote cs+  | c == '&'  = "&amp;"   ++ htmlQuote cs+  | c == '"'  = "&quot;"  ++ htmlQuote cs+  | c == 'ä'  = "&auml;"  ++ htmlQuote cs+  | c == 'ö'  = "&ouml;"  ++ htmlQuote cs+  | c == 'ü'  = "&uuml;"  ++ htmlQuote cs+  | c == 'Ä'  = "&Auml;"  ++ htmlQuote cs+  | c == 'Ö'  = "&Ouml;"  ++ htmlQuote cs+  | c == 'Ü'  = "&Uuml;"  ++ htmlQuote cs+  | c == 'ß'  = "&szlig;" ++ htmlQuote cs+  | otherwise = c : htmlQuote cs
+ src/Html/SyntaxColoring.hs view
@@ -0,0 +1,564 @@+{- |+    Module      :  $Header$+    Description :  Split module into code fragments+    Copyright   :  (c) 2014 - 2016 Björn Peemöller+                       2016        Jan Tikovsky+                       2016 - 2017 Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module arranges the tokens of the module into different code+    categories for HTML presentation. The parsed and qualified module+    is used to establish links between used identifiers and their definitions.++    The fully qualified module is traversed to generate a list of code elements.+    Code elements representing identifiers are distinguished by their kind+    (type constructor, data constructor, function, (type) variable).+    They include information about their usage (i.e., declaration, call etc.)+    and whether the identifier occurs fully qualified in+    the source code or not. Initially, all identifier codes are fully qualified.++    In a next step, the token stream of the given program and the code list are+    traversed sequentially (see `encodeToks`). The information in the token+    stream is used to:++      * add code elements for newlines, spaces and pragmas+      * update the qualification information of identifiers in the code list.+-}++module Html.SyntaxColoring+  ( Code (..), TypeUsage (..), ConsUsage (..)+  , IdentUsage (..), FuncUsage (..)+  , genProgram, code2string, getQualIdent+  ) where++import Data.Function (on)+import Data.List     (sortBy)++import Curry.Base.Ident+import Curry.Base.Position+import Curry.Base.SpanInfo ()+import Curry.Syntax++import Base.Messages++-- |Type of codes which are distinguished for HTML output+-- the boolean flags indicate whether the corresponding identifier+-- occurs qualified in the source module+data Code+  = Keyword     String+  | Space       Int+  | NewLine+  | Pragma      String+  | TypeCons    TypeUsage  Bool QualIdent+  | DataCons    ConsUsage  Bool QualIdent+  | Function    FuncUsage  Bool QualIdent+  | Identifier  IdentUsage Bool QualIdent+  | ModuleName  ModuleIdent+  | Commentary  String+  | NumberCode  String+  | StringCode  String+  | CharCode    String+  | Symbol      String+    deriving Show++data TypeUsage+  = TypeDeclare+  | TypeRefer+  | TypeExport+  | TypeImport+    deriving Show++data ConsUsage+  = ConsDeclare+  | ConsPattern+  | ConsCall+  | ConsInfix+  | ConsExport+  | ConsImport+    deriving Show++data FuncUsage+  = FuncDeclare+  | FuncTypeSig+  | FuncCall+  | FuncInfix+  | FuncExport+  | FuncImport+    deriving Show++data IdentUsage+  = IdDeclare -- declare a (type) variable+  | IdRefer   -- refer to a (type) variable+  | IdUnknown -- unknown usage+    deriving Show++-- @param fully qualified module+-- @param lex-Result+-- @return code list+genProgram :: Module a -> [(Position, Token)] -> [Code]+genProgram m pts = encodeToks (first "") (filter validCode (idsModule m)) pts++-- predicate to remove identifier codes for primitives+-- because they do not form valid link targets+validCode :: Code -> Bool+validCode (TypeCons   _ _ t) = t `notElem` [qUnitId, qListId]         && not (isQTupleId t)+validCode (DataCons   _ _ c) = c `notElem` [qUnitId, qNilId, qConsId] && not (isQTupleId c)+validCode (Identifier _ _ i) = not $ isAnonId $ unqualify i+validCode _                  = True++-- @param code+-- @return qid if available+getQualIdent :: Code -> Maybe QualIdent+getQualIdent (DataCons   _ _ qid) = Just qid+getQualIdent (Function   _ _ qid) = Just qid+getQualIdent (Identifier _ _ qid) = Just qid+getQualIdent (TypeCons   _ _ qid) = Just qid+getQualIdent _                    = Nothing++encodeToks :: Position -> [Code] -> [(Position, Token)] -> [Code]+encodeToks _   _   []                     = []+encodeToks cur ids toks@((pos, tok) : ts)+  -- advance line+  | line cur   < line   pos = NewLine : encodeToks (nl cur) ids toks+  -- advance column+  | column cur < column pos = let d = column pos - column cur+                              in  Space d : encodeToks (incr cur d) ids toks+  -- pragma token+  | isPragmaToken tok       = let (ps, (end:rest)) = break (isPragmaEnd . snd) toks+                                  s = unwords $ map (showToken . snd) (ps ++ [end])+                              in  Pragma s : encodeToks (incr cur (length s)) ids rest+  -- identifier token+  | isIdentTok tok          = case ids of+    []     -> encodeTok tok : encodeToks newPos [] ts+    (i:is)+      | tokenStr == code2string i' -> i' : encodeToks newPos is ts+  -- the 'otherwise' case should never occur if the token stream and+  -- the qualified AST which was used to generate the code list correspond to+  -- the same module+      | otherwise                  -> encodeToks cur is toks+      where i' = setQualified (isQualIdentTok tok) i+  -- other token+  | otherwise               = encodeTok tok : encodeToks newPos ids ts+  where+  tokenStr = showToken tok+  newPos   = incr cur (length tokenStr)++setQualified :: Bool -> Code -> Code+setQualified b (DataCons   u _ c) = DataCons u b c+setQualified b (Function   u _ f) = Function u b f+setQualified b (Identifier u _ i) = Identifier u b i+setQualified b (TypeCons   u _ t) = TypeCons u b t+setQualified _ m@(ModuleName   _) = m+setQualified _ s@(Symbol       _) = s+setQualified _ c                  = internalError $ "Html.SyntaxColoring.setQualified: " ++ show c++code2string :: Code -> String+code2string (Keyword           s) = s+code2string (Space             i) = replicate i ' '+code2string NewLine               = "\n"+code2string (Pragma            s) = s+code2string (DataCons    _ b qid) = ident2string b qid+code2string (TypeCons    _ b qid) = ident2string b qid+code2string (Function    _ b qid) = ident2string b qid+code2string (Identifier  _ b qid) = ident2string b qid+code2string (ModuleName      mid) = moduleName mid+code2string (Commentary        s) = s+code2string (NumberCode        s) = s+code2string (StringCode        s) = s+code2string (CharCode          s) = s+code2string (Symbol            s) = s++ident2string :: Bool -> QualIdent -> String+ident2string False q = idName $ unqualify q+ident2string True  q = qualName q++encodeTok :: Token -> Code+encodeTok tok@(Token c _)+  | c `elem` numCategories          = NumberCode (showToken tok)+  | c == CharTok                    = CharCode   (showToken tok)+  | c == StringTok                  = StringCode (showToken tok)+  | c `elem` keywordCategories      = Keyword    (showToken tok)+  | c `elem` specialIdentCategories = Keyword    (showToken tok)+  | c `elem` punctuationCategories  = Symbol     (showToken tok)+  | c `elem` reservedOpsCategories  = Symbol     (showToken tok)+  | c `elem` commentCategories      = Commentary (showToken tok)+  | c `elem` identCategories        = Identifier IdUnknown False $ qualify $ mkIdent+                                      $ showToken tok+  | c `elem` whiteSpaceCategories   = Space 0+  | c `elem` pragmaCategories       = Pragma     (showToken tok)+  | otherwise                       = internalError $+    "SyntaxColoring.encodeTok: Unknown token " ++ showToken tok++numCategories :: [Category]+numCategories = [IntTok, FloatTok]++keywordCategories :: [Category]+keywordCategories =+  [ KW_case, KW_class, KW_data, KW_default, KW_deriving, KW_do, KW_else+  , KW_external, KW_fcase, KW_free, KW_if, KW_import, KW_in+  , KW_infix, KW_infixl, KW_infixr, KW_instance, KW_let, KW_module, KW_newtype+  , KW_of, KW_then, KW_type, KW_where+  ]++specialIdentCategories :: [Category]+specialIdentCategories =+  [ Id_as, Id_ccall, Id_forall, Id_hiding+  , Id_interface, Id_primitive, Id_qualified ]++punctuationCategories :: [Category]+punctuationCategories =+  [ LeftParen, RightParen, Semicolon, LeftBrace, RightBrace+  , LeftBracket, RightBracket, Comma, Underscore, Backquote ]++reservedOpsCategories :: [Category]+reservedOpsCategories =+  [ At, Colon, DotDot, DoubleArrow, DoubleColon, Equals, Backslash, Bar+  , LeftArrow, RightArrow, Tilde ]++commentCategories :: [Category]+commentCategories = [LineComment, NestedComment]++identCategories :: [Category]+identCategories = [Id, QId, Sym, QSym, SymDot, SymMinus, SymStar]++isPragmaToken :: Token -> Bool+isPragmaToken (Token c _) = c `elem` pragmaCategories++isPragmaEnd :: Token -> Bool+isPragmaEnd (Token c _) = c == PragmaEnd++isIdentTok :: Token -> Bool+isIdentTok (Token c _) = c `elem` identCategories++isQualIdentTok :: Token -> Bool+isQualIdentTok (Token c _) = c `elem` [QId, QSym]++whiteSpaceCategories :: [Category]+whiteSpaceCategories = [EOF, VSemicolon, VRightBrace]++pragmaCategories :: [Category]+pragmaCategories = [PragmaLanguage, PragmaOptions, PragmaEnd]++cmpDecl :: Decl a -> Decl a -> Ordering+cmpDecl = compare `on` getPosition++cmpImportDecl :: ImportDecl -> ImportDecl -> Ordering+cmpImportDecl = compare `on` getPosition++-- -----------------------------------------------------------------------------+-- Extract all identifiers mentioned in the source code as a Code entity+-- in the order of their occurrence. The extracted information is then used+-- to enrich the identifier tokens with additional information, e.g., for+-- link generation.+-- -----------------------------------------------------------------------------++idsModule :: Module a -> [Code]+idsModule (Module _ _ _ mid es is ds) =+  let hdrCodes = ModuleName mid : idsExportSpec es+      impCodes = concatMap idsImportDecl (sortBy cmpImportDecl is)+      dclCodes = concatMap idsDecl       (sortBy cmpDecl ds)+  in  hdrCodes ++ impCodes ++ dclCodes++-- Exports++idsExportSpec ::  Maybe ExportSpec -> [Code]+idsExportSpec Nothing                 = []+idsExportSpec (Just (Exporting _ es)) = concatMap idsExport es++idsExport :: Export -> [Code]+idsExport (Export            _ qid) = [Function FuncExport False qid]+idsExport (ExportTypeWith _ qid cs) = TypeCons TypeExport False qid :+  map (DataCons ConsExport False . qualify) cs+idsExport (ExportTypeAll     _ qid) = [TypeCons TypeExport False qid]+idsExport (ExportModule      _ mid) = [ModuleName mid]++-- Imports++idsImportDecl :: ImportDecl -> [Code]+idsImportDecl (ImportDecl _ mid _ mAlias spec)+  = ModuleName mid : aliasCode ++ maybe [] (idsImportSpec mid) spec+  where aliasCode = maybe [] ((:[]) . ModuleName) mAlias++idsImportSpec :: ModuleIdent -> ImportSpec -> [Code]+idsImportSpec mid (Importing _ is) = concatMap (idsImport mid) is+idsImportSpec mid (Hiding    _ is) = concatMap (idsImport mid) is++idsImport :: ModuleIdent -> Import -> [Code]+idsImport mid (Import            _ i) =+  [Function FuncImport False $ qualifyWith mid i]+idsImport mid (ImportTypeWith _ t cs) =+  TypeCons TypeImport False (qualifyWith mid t) :+    map (DataCons ConsImport False . qualifyWith mid) cs+idsImport mid (ImportTypeAll     _ t) =+  [TypeCons TypeImport False $ qualifyWith mid t]++-- Declarations++idsDecl :: Decl a -> [Code]+idsDecl (InfixDecl         _ _ _ ops) =+  map (Function FuncInfix False . qualify) ops+idsDecl (DataDecl    _ d vs cds clss) =+  TypeCons TypeDeclare False (qualify d) :+    map (Identifier IdDeclare False . qualify) vs +++      concatMap idsConstrDecl cds ++ map (TypeCons TypeRefer False) clss+idsDecl (ExternalDataDecl     _ d vs) =+  TypeCons TypeDeclare False (qualify d) :+    map (Identifier IdDeclare False . qualify) vs+idsDecl (NewtypeDecl  _ t vs nc clss) =+  TypeCons TypeDeclare False (qualify t) :+    map (Identifier IdDeclare False . qualify) vs ++ idsNewConstrDecl nc +++      map (TypeCons TypeRefer False) clss+idsDecl (TypeDecl          _ t vs ty) =+  TypeCons TypeDeclare False (qualify t) :+    map (Identifier IdDeclare False . qualify) vs ++ idsTypeExpr ty+idsDecl (TypeSig            _ fs qty) =+  map (Function FuncTypeSig False . qualify) fs ++ idsQualTypeExpr qty+idsDecl (FunctionDecl      _ _ _ eqs) = concatMap idsEquation eqs+idsDecl (ExternalDecl           _ fs) =+  map (Function FuncDeclare False . qualify . varIdent) fs+idsDecl (PatternDecl         _ p rhs) = idsPat p ++ idsRhs rhs+idsDecl (FreeDecl               _ vs) =+  map (Identifier IdDeclare False . qualify . varIdent) vs+idsDecl (DefaultDecl           _ tys) = concatMap idsTypeExpr tys+idsDecl (ClassDecl     _ _ cx c v ds) =+  idsContext cx ++ TypeCons TypeDeclare False (qualify c) :+    Identifier IdDeclare False (qualify v) : concatMap idsClassDecl ds+idsDecl (InstanceDecl _ _ cx c ty ds) = idsContext cx +++  TypeCons TypeRefer False c : idsTypeExpr ty ++ concatMap idsInstanceDecl ds++idsConstrDecl :: ConstrDecl -> [Code]+idsConstrDecl (ConstrDecl     _ c tys) =+  DataCons ConsDeclare False (qualify c) : concatMap idsTypeExpr tys+idsConstrDecl (ConOpDecl _ ty1 op ty2) =+  idsTypeExpr ty1 ++ (DataCons ConsDeclare False $ qualify op) : idsTypeExpr ty2+idsConstrDecl (RecordDecl      _ c fs) =+  DataCons ConsDeclare False (qualify c) : concatMap idsFieldDecl fs++idsNewConstrDecl :: NewConstrDecl -> [Code]+idsNewConstrDecl (NewConstrDecl _ c     ty) =+  DataCons ConsDeclare False (qualify c) : idsTypeExpr ty+idsNewConstrDecl (NewRecordDecl _ c (l,ty)) =+  DataCons ConsDeclare False (qualify c) :+    (Function FuncDeclare False $ qualify l) : idsTypeExpr ty++idsClassDecl :: Decl a -> [Code]+idsClassDecl (TypeSig       _ fs qty) =+  map (Function FuncDeclare False . qualify) fs ++ idsQualTypeExpr qty+idsClassDecl (FunctionDecl _ _ _ eqs) = concatMap idsEquation eqs+idsClassDecl _                        =+  internalError "SyntaxColoring.idsClassDecl"++idsInstanceDecl :: Decl a -> [Code]+idsInstanceDecl (FunctionDecl _ _ _ eqs) = concatMap idsEquation eqs+idsInstanceDecl _                        =+  internalError "SyntaxColoring.idsInstanceDecl"++idsQualTypeExpr :: QualTypeExpr -> [Code]+idsQualTypeExpr (QualTypeExpr _ cx ty) = idsContext cx ++ idsTypeExpr ty++idsContext :: Context -> [Code]+idsContext = concatMap idsConstraint++idsConstraint :: Constraint -> [Code]+idsConstraint (Constraint _ qcls ty) =+  TypeCons TypeRefer False qcls : idsTypeExpr ty++idsTypeExpr :: TypeExpr -> [Code]+idsTypeExpr (ConstructorType _ qid) = [TypeCons TypeRefer False qid]+idsTypeExpr (ApplyType   _ ty1 ty2) = concatMap idsTypeExpr [ty1, ty2]+idsTypeExpr (VariableType      _ v) = [Identifier IdRefer False (qualify v)]+idsTypeExpr (TupleType       _ tys) = concatMap idsTypeExpr tys+idsTypeExpr (ListType         _ ty) = idsTypeExpr ty+idsTypeExpr (ArrowType   _ ty1 ty2) = concatMap idsTypeExpr [ty1, ty2]+idsTypeExpr (ParenType        _ ty) = idsTypeExpr ty+idsTypeExpr (ForallType    _ vs ty) =+  map (Identifier IdDeclare False . qualify) vs ++ Symbol "." : idsTypeExpr ty++idsFieldDecl :: FieldDecl -> [Code]+idsFieldDecl (FieldDecl _ ls ty) =+  map (Function FuncDeclare False . qualify . unRenameIdent) ls ++ idsTypeExpr ty++idsEquation :: Equation a -> [Code]+idsEquation (Equation _ lhs rhs) = idsLhs lhs ++ idsRhs rhs++idsLhs :: Lhs a -> [Code]+idsLhs (FunLhs    _ f ps) =+  Function FuncDeclare False (qualify f) : concatMap idsPat ps+idsLhs (OpLhs _ p1 op p2) =+  idsPat p1 ++ [Function FuncDeclare False $ qualify op] ++ idsPat p2+idsLhs (ApLhs   _ lhs ps) = idsLhs lhs ++ concatMap idsPat ps++idsRhs :: Rhs a -> [Code]+idsRhs (SimpleRhs  _ _ e  ds) = idsExpr e ++ concatMap idsDecl ds+idsRhs (GuardedRhs _ _ ce ds) = concatMap idsCondExpr ce ++ concatMap idsDecl ds++idsCondExpr :: CondExpr a -> [Code]+idsCondExpr (CondExpr _ e1 e2) = idsExpr e1 ++ idsExpr e2++idsPat :: Pattern a -> [Code]+idsPat (LiteralPattern          _ _ _) = []+idsPat (NegativePattern         _ _ _) = []+idsPat (VariablePattern         _ _ v) = [Identifier IdDeclare False (qualify v)]+idsPat (ConstructorPattern _ _ qid ps) =+  DataCons ConsPattern False qid : concatMap idsPat ps+idsPat (InfixPattern    _ _ p1 qid p2) =+  idsPat p1 ++ DataCons ConsPattern False qid : idsPat p2+idsPat (ParenPattern              _ p) = idsPat p+idsPat (RecordPattern      _ _ qid fs) =+  DataCons ConsPattern False qid : concatMap (idsField idsPat) fs+idsPat (TuplePattern            _ ps) = concatMap idsPat ps+idsPat (ListPattern            _ _ ps) = concatMap idsPat ps+idsPat (AsPattern               _ v p) =+  Identifier IdDeclare False (qualify v) : idsPat p+idsPat (LazyPattern               _ p) = idsPat p+idsPat (FunctionPattern    _ _ qid ps) =+  Function FuncCall False qid : concatMap idsPat ps+idsPat (InfixFuncPattern  _ _ p1 f p2) =+  idsPat p1 ++ Function FuncInfix False f : idsPat p2++idsExpr :: Expression a -> [Code]+idsExpr (Literal              _ _ _) = []+idsExpr (Variable           _ _ qid)+  | isQualified qid                = [Function FuncCall False qid]+  | hasGlobalScope (unqualify qid) = [Function FuncCall False qid]+  | otherwise                      = [Identifier IdRefer False qid]+idsExpr (Constructor        _ _ qid) = [DataCons ConsCall False qid]+idsExpr (Paren                  _ e) = idsExpr e+idsExpr (Typed              _ e qty) = idsExpr e ++ idsQualTypeExpr qty+idsExpr (Record          _ _ qid fs) =+  DataCons ConsCall False qid : concatMap (idsField idsExpr) fs+idsExpr (RecordUpdate        _ e fs) =+  idsExpr e ++ concatMap (idsField idsExpr) fs+idsExpr (Tuple                 _ es) = concatMap idsExpr es+idsExpr (List                _ _ es) = concatMap idsExpr es+idsExpr (ListCompr        _ e stmts) = idsExpr e ++ concatMap idsStmt stmts+idsExpr (EnumFrom               _ e) = idsExpr e+idsExpr (EnumFromThen       _ e1 e2) = concatMap idsExpr [e1, e2]+idsExpr (EnumFromTo         _ e1 e2) = concatMap idsExpr [e1, e2]+idsExpr (EnumFromThenTo  _ e1 e2 e3) = concatMap idsExpr [e1, e2, e3]+idsExpr (UnaryMinus             _ e) = Symbol "-" : idsExpr e+idsExpr (Apply              _ e1 e2) = idsExpr e1 ++ idsExpr e2+idsExpr (InfixApply      _ e1 op e2) = idsExpr e1 ++ idsInfix op ++ idsExpr e2+idsExpr (LeftSection         _ e op) = idsExpr e ++ idsInfix op+idsExpr (RightSection        _ op e) = idsInfix op ++ idsExpr e+idsExpr (Lambda              _ ps e) = concatMap idsPat ps ++ idsExpr e+idsExpr (Let               _ _ ds e) = concatMap idsDecl ds ++ idsExpr e+idsExpr (Do             _ _ stmts e) = concatMap idsStmt stmts ++ idsExpr e+idsExpr (IfThenElse      _ e1 e2 e3) = concatMap idsExpr [e1, e2, e3]+idsExpr (Case          _ _ _ e alts) = idsExpr e ++ concatMap idsAlt alts++idsField :: (a -> [Code]) -> Field a -> [Code]+idsField f (Field _ l x) = Function FuncCall False l : f x++idsInfix :: InfixOp a -> [Code]+idsInfix (InfixOp     _ qid) = [Function FuncInfix False qid]+idsInfix (InfixConstr _ qid) = [DataCons ConsInfix False qid]++idsStmt :: Statement a -> [Code]+idsStmt (StmtExpr   _ e)  = idsExpr e+idsStmt (StmtDecl _ _ ds) = concatMap idsDecl ds+idsStmt (StmtBind _ p e)  = idsPat p ++ idsExpr e++idsAlt :: Alt a -> [Code]+idsAlt (Alt _ p rhs) = idsPat p ++ idsRhs rhs++-- -----------------------------------------------------------------------------+-- Conversion from a token to a string+-- -----------------------------------------------------------------------------++showToken :: Token -> String+showToken (Token Id                 a) = showAttr a+showToken (Token QId                a) = showAttr a+showToken (Token Sym                a) = showAttr a+showToken (Token QSym               a) = showAttr a+showToken (Token IntTok             a) = showAttr a+showToken (Token FloatTok           a) = showAttr a+showToken (Token CharTok            a) = showAttr a+showToken (Token StringTok          a) = showAttr a+showToken (Token LeftParen          _) = "("+showToken (Token RightParen         _) = ")"+showToken (Token Semicolon          _) = ";"+showToken (Token LeftBrace          _) = "{"+showToken (Token RightBrace         _) = "}"+showToken (Token LeftBracket        _) = "["+showToken (Token RightBracket       _) = "]"+showToken (Token Comma              _) = ","+showToken (Token Underscore         _) = "_"+showToken (Token Backquote          _) = "`"+showToken (Token VSemicolon         _) = ""+showToken (Token VRightBrace        _) = ""+showToken (Token At                 _) = "@"+showToken (Token Colon              _) = ":"+showToken (Token DotDot             _) = ".."+showToken (Token DoubleArrow        _) = "=>"+showToken (Token DoubleColon        _) = "::"+showToken (Token Equals             _) = "="+showToken (Token Backslash          _) = "\\"+showToken (Token Bar                _) = "|"+showToken (Token LeftArrow          _) = "<-"+showToken (Token RightArrow         _) = "->"+showToken (Token Tilde              _) = "~"+showToken (Token SymDot             _) = "."+showToken (Token SymMinus           _) = "-"+showToken (Token SymStar            _) = "*"+showToken (Token KW_case            _) = "case"+showToken (Token KW_class           _) = "class"+showToken (Token KW_data            _) = "data"+showToken (Token KW_default         _) = "default"+showToken (Token KW_deriving        _) = "deriving"+showToken (Token KW_do              _) = "do"+showToken (Token KW_else            _) = "else"+showToken (Token KW_external        _) = "external"+showToken (Token KW_fcase           _) = "fcase"+showToken (Token KW_free            _) = "free"+showToken (Token KW_if              _) = "if"+showToken (Token KW_import          _) = "import"+showToken (Token KW_in              _) = "in"+showToken (Token KW_infix           _) = "infix"+showToken (Token KW_infixl          _) = "infixl"+showToken (Token KW_infixr          _) = "infixr"+showToken (Token KW_instance        _) = "instance"+showToken (Token KW_let             _) = "let"+showToken (Token KW_module          _) = "module"+showToken (Token KW_newtype         _) = "newtype"+showToken (Token KW_of              _) = "of"+showToken (Token KW_then            _) = "then"+showToken (Token KW_type            _) = "type"+showToken (Token KW_where           _) = "where"+showToken (Token Id_as              _) = "as"+showToken (Token Id_ccall           _) = "ccall"+showToken (Token Id_forall          _) = "forall"+showToken (Token Id_hiding          _) = "hiding"+showToken (Token Id_interface       _) = "interface"+showToken (Token Id_primitive       _) = "primitive"+showToken (Token Id_qualified       _) = "qualified"+showToken (Token EOF                _) = ""+showToken (Token PragmaHiding       _) = "{-# HIDING"+showToken (Token PragmaLanguage     _) = "{-# LANGUAGE"+showToken (Token PragmaOptions      a) = "{-# OPTIONS" ++ showAttr a+showToken (Token PragmaMethod       _) = "{-# METHOD"+showToken (Token PragmaModule       _) = "{-# MODULE"+showToken (Token PragmaEnd          _) = "#-}"+showToken (Token LineComment   (StringAttributes s _)) = s+showToken (Token LineComment   a                     ) = showAttr a+showToken (Token NestedComment (StringAttributes s _)) = s+showToken (Token NestedComment                      a) = showAttr a++showAttr :: Attributes -> [Char]+showAttr NoAttributes             = ""+showAttr (CharAttributes     c _) = show c+showAttr (IntAttributes      i _) = show i+showAttr (FloatAttributes    f _) = show f+showAttr (StringAttributes   s _) = show s+showAttr (IdentAttributes    m i)+  | null m    = idName   $                          (mkIdent i)+  | otherwise = qualName $ qualifyWith (mkMIdent m) (mkIdent i)+showAttr (OptionsAttributes mt s) = showTool mt ++ ' ' : s++showTool :: Maybe String -> String+showTool Nothing  = ""+showTool (Just t) = '_' : t
+ src/IL.hs view
@@ -0,0 +1,19 @@+{- |+    Module      :  $Header$+    Description :  Intermediate language+    Copyright   :  (c) 2014, Björn Peemöller+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module is a simple re-export of the definition of the AST of IL+    and the pretty-printing of IL modules.+-}+module IL ( module IL.Type, module IL.Typing, ppModule, showModule ) where++import IL.Pretty     (ppModule)+import IL.ShowModule (showModule)+import IL.Type+import IL.Typing
− src/IL/CurryToIL.lhs 
@@ -1,598 +0,0 @@--% $Id: ILTrans.lhs,v 1.86 2004/02/13 19:23:58 wlux Exp $-%-% Copyright (c) 1999-2003, Wolfgang Lux-% See LICENSE for the full license.-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-%-\nwfilename{ILTrans.lhs}-\section{Translating Curry into the Intermediate Language}-After desugaring and lifting have been performed, the source code is-translated into the intermediate language. Besides translating from-source terms and expressions into intermediate language terms and-expressions this phase in particular has to implement the pattern-matching algorithm for equations and case expressions.--Because of name conflicts between the source and intermediate language-data structures, we can use only a qualified import for the-\texttt{IL} module.-\begin{verbatim}--> module IL.CurryToIL(ilTrans,ilTransIntf, translType) where--> import Data.Maybe-> import Data.List-> import qualified Data.Set as Set-> import qualified Data.Map as Map--> import Curry.Base.Position-> import Curry.Base.Ident-> import Curry.Syntax-> import Curry.Syntax.Utils--> import Types-> import Base-> import qualified IL.Type as IL-> import Utils----\end{verbatim}-\paragraph{Modules}-At the top-level, the compiler has to translate data type, newtype,-function, and external declarations. When translating a data type or-newtype declaration, we ignore the types in the declaration and lookup-the types of the constructors in the type environment instead because-these types are already fully expanded, i.e., they do not include any-alias types.-\begin{verbatim}--> ilTrans :: Bool -> ValueEnv -> TCEnv -> EvalEnv -> Module -> IL.Module-> ilTrans flat tyEnv tcEnv evEnv (Module m _ ds) = ->   IL.Module m (imports m ds') ds'->   where ds' = concatMap (translGlobalDecl flat m tyEnv tcEnv evEnv) ds--> translGlobalDecl :: Bool -> ModuleIdent -> ValueEnv -> TCEnv -> EvalEnv->                  -> Decl -> [IL.Decl]-> translGlobalDecl _ m tyEnv tcEnv _ (DataDecl _ tc tvs cs) =->   [translData m tyEnv tcEnv tc tvs cs]-> translGlobalDecl _ m tyEnv tcEnv _ (NewtypeDecl _ tc tvs nc) =->   [translNewtype m tyEnv tcEnv tc tvs nc]-> translGlobalDecl flat m tyEnv tcEnv evEnv (FunctionDecl pos f eqs) =->   [translFunction pos flat m tyEnv tcEnv evEnv f eqs]-> translGlobalDecl _ m tyEnv tcEnv _ (ExternalDecl _ cc ie f _) =->   [translExternal m tyEnv tcEnv f cc (fromJust ie)]-> translGlobalDecl _ _ _ _ _ _ = []--> translData :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> [Ident] -> [ConstrDecl]->            -> IL.Decl-> translData m tyEnv tcEnv tc tvs cs =->   IL.DataDecl (qualifyWith m tc) (length tvs)->               (map (translConstrDecl m tyEnv tcEnv) cs)--> translNewtype :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> [Ident] ->	        -> NewConstrDecl -> IL.Decl-> translNewtype m tyEnv tcEnv tc tvs (NewConstrDecl _ _ c _) =->   IL.NewtypeDecl (qualifyWith m tc) (length tvs)->                  (IL.ConstrDecl c' (translType' m tyEnv tcEnv ty))->                  -- (IL.ConstrDecl c' (translType ty))->   where c' = qualifyWith m c->         TypeArrow ty _ = constrType tyEnv c'--> translConstrDecl :: ModuleIdent -> ValueEnv -> TCEnv -> ConstrDecl->                  -> IL.ConstrDecl [IL.Type]-> translConstrDecl m tyEnv tcEnv d =->   IL.ConstrDecl c' (map (translType' m tyEnv tcEnv)->	                  (arrowArgs (constrType tyEnv c')))->   -- IL.ConstrDecl c' (map translType (arrowArgs (constrType tyEnv c')))->   where c' = qualifyWith m (constr d)->         constr (ConstrDecl _ _ c _) = c->         constr (ConOpDecl _ _ _ op _) = op--> translExternal :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> CallConv->                -> String -> IL.Decl-> translExternal m tyEnv tcEnv f cc ie =->   IL.ExternalDecl f' (callConv cc) ie ->                   (translType' m tyEnv tcEnv (varType tyEnv f'))->   -- IL.ExternalDecl f' (callConv cc) ie (translType (varType tyEnv f'))->   where f' = qualifyWith m f->         callConv CallConvPrimitive = IL.Primitive->         callConv CallConvCCall = IL.CCall--\end{verbatim}-\paragraph{Interfaces}-In order to generate code, the compiler also needs to know the tags-and arities of all imported data constructors. For that reason we-compile the data type declarations of all interfaces into the-intermediate language, too. In this case we do not lookup the-types in the environment because the types in the interfaces are-already fully expanded. Note that we do not translate data types-which are imported into the interface from some other module.-\begin{verbatim}--> ilTransIntf :: ValueEnv -> TCEnv -> Interface -> [IL.Decl]-> ilTransIntf tyEnv tcEnv (Interface m ds) = ->   foldr (translIntfDecl m tyEnv tcEnv) [] ds--> translIntfDecl :: ModuleIdent -> ValueEnv -> TCEnv -> IDecl -> [IL.Decl] ->	         -> [IL.Decl]-> translIntfDecl m tyEnv tcEnv (IDataDecl _ tc tvs cs) ds->   | not (isQualified tc) = ->     translIntfData m tyEnv tcEnv (unqualify tc) tvs cs : ds-> translIntfDecl _ _ _ _ ds = ds--> translIntfData :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> [Ident] ->	         -> [Maybe ConstrDecl] -> IL.Decl-> translIntfData m tyEnv tcEnv tc tvs cs =->   IL.DataDecl (qualifyWith m tc) (length tvs)->               (map (maybe hiddenConstr ->	                    (translIntfConstrDecl m tyEnv tcEnv tvs)) cs)->   where hiddenConstr = IL.ConstrDecl qAnonId []->         qAnonId = qualify anonId--> translIntfConstrDecl :: ModuleIdent -> ValueEnv -> TCEnv -> [Ident] ->                      -> ConstrDecl -> IL.ConstrDecl [IL.Type]-> translIntfConstrDecl m tyEnv tcEnv tvs (ConstrDecl _ _ c tys) =->   IL.ConstrDecl (qualifyWith m c) (map (translType' m tyEnv tcEnv)->			                 (toQualTypes m tvs tys))->   -- IL.ConstrDecl (qualifyWith m c) (map translType (toQualTypes m tvs tys))-> translIntfConstrDecl m tyEnv tcEnv tvs (ConOpDecl _ _ ty1 op ty2) =->   IL.ConstrDecl (qualifyWith m op)->                 (map (translType' m tyEnv tcEnv)->	               (toQualTypes m tvs [ty1,ty2]))->   -- IL.ConstrDecl (qualifyWith m op)->   --              (map translType (toQualTypes m tvs [ty1,ty2]))--\end{verbatim}-\paragraph{Types}-The type representation in the intermediate language is the same as-the internal representation except that it does not support-constrained type variables and skolem types. The former are fixed and-the later are replaced by fresh type constructors.--Due to possible occurrence of record types, it is necessary to transform-them back into their corresponding type constructors.-\begin{verbatim}--> translType' :: ModuleIdent -> ValueEnv -> TCEnv -> Type -> IL.Type-> translType' m tyEnv tcEnv ty =->   translType (elimRecordTypes m tyEnv tcEnv (maximum (0:(typeVars ty))) ty)--> translType :: Type -> IL.Type-> translType (TypeConstructor tc tys) =->   IL.TypeConstructor tc (map translType tys)-> translType (TypeVariable tv) = IL.TypeVariable tv-> translType (TypeConstrained tys _) = translType (head tys)-> translType (TypeArrow ty1 ty2) =->   IL.TypeArrow (translType ty1) (translType ty2)-> translType (TypeSkolem k) =->   IL.TypeConstructor (qualify (mkIdent ("_" ++ show k))) []--> elimRecordTypes :: ModuleIdent -> ValueEnv -> TCEnv -> Int -> Type -> Type-> elimRecordTypes m tyEnv tcEnv n (TypeConstructor t tys) =->   TypeConstructor t (map (elimRecordTypes m tyEnv tcEnv n) tys)-> elimRecordTypes m tyEnv tcEnv n (TypeVariable v) =->   TypeVariable v-> elimRecordTypes m tyEnv tcEnv n (TypeConstrained tys v) =->   TypeConstrained (map (elimRecordTypes m tyEnv tcEnv n) tys) v-> elimRecordTypes m tyEnv tcEnv n (TypeArrow t1 t2) =->   TypeArrow (elimRecordTypes m tyEnv tcEnv n t1)->             (elimRecordTypes m tyEnv tcEnv n t2)-> elimRecordTypes m tyEnv tcEnv n (TypeSkolem v) =->   TypeSkolem v-> elimRecordTypes m tyEnv tcEnv n (TypeRecord fs _)->   | null fs = internalError "elimRecordTypes: empty record type"->   | otherwise =->     case (lookupValue (fst (head fs)) tyEnv) of->       [Label _ r _] ->->         case (qualLookupTC r tcEnv) of->           [AliasType _ n' (TypeRecord fs' _)] ->->	      let is = [0 .. n'-1]->                 vs = foldl (matchTypeVars fs)->			     Map.empty->			     fs'->		  tys = map (\i -> maybe (TypeVariable (i+n))->			                 (elimRecordTypes m tyEnv tcEnv n)->		                         (Map.lookup i vs))->		            is ->	      in  TypeConstructor r tys->	    _ -> internalError "elimRecordTypes: no record type"->       _ -> internalError "elimRecordTypes: no label"--> matchTypeVars :: [(Ident,Type)] -> Map.Map Int Type -> (Ident,Type) ->	           -> Map.Map Int Type-> matchTypeVars fs vs (l,ty) =->   maybe vs (match vs ty) (lookup l fs)->   where->   match vs (TypeVariable i) ty' = Map.insert i ty' vs->   match vs (TypeConstructor _ tys) (TypeConstructor _ tys') =->     matchList vs tys tys'->   match vs (TypeConstrained tys _) (TypeConstrained tys' _) =->     matchList vs tys tys'->   match vs (TypeArrow ty1 ty2) (TypeArrow ty1' ty2') =->     matchList vs [ty1,ty2] [ty1',ty2']->   match vs (TypeSkolem _) (TypeSkolem _) = vs->   match vs (TypeRecord fs _) (TypeRecord fs' _) =->     foldl (matchTypeVars fs') vs fs->   match vs ty ty' = ->     internalError ("matchTypeVars: " ++ show ty ++ "\n" ++ show ty')->->   matchList vs tys tys' = ->     foldl (\vs' (ty,ty') -> match vs' ty ty') vs (zip tys tys')--\end{verbatim}-\paragraph{Functions}-Each function in the program is translated into a function of the-intermediate language. The arguments of the function are renamed such-that all variables occurring in the same position (in different-equations) have the same name. This is necessary in order to-facilitate the translation of pattern matching into a \texttt{case}-expression. We use the following simple convention here: The top-level-arguments of the function are named from left to right \texttt{\_1},-\texttt{\_2}, and so on. The names of nested arguments are constructed-by appending \texttt{\_1}, \texttt{\_2}, etc. from left to right to-the name that were assigned to a variable occurring at the position of-the constructor term.--Some special care is needed for the selector functions introduced by-the compiler in place of pattern bindings. In order to generate the-code for updating all pattern variables, the equality of names between-the pattern variables in the first argument of the selector function-and their repeated occurrences in the remaining arguments must be-preserved. This means that the second and following arguments of a-selector function have to be renamed according to the name mapping-computed for its first argument.--If an evaluation annotation is available for a function, it determines-the evaluation mode of the case expression. Otherwise, the function-uses flexible matching.-\begin{verbatim}--> type RenameEnv = Map.Map Ident Ident--> translFunction :: Position -> Bool -> ModuleIdent -> ValueEnv -> TCEnv->       -> EvalEnv -> Ident -> [Equation] -> IL.Decl-> translFunction pos flat m tyEnv tcEnv evEnv f eqs =->   -- - | f == mkIdent "fun" = error (show (translType' m tyEnv tcEnv ty))->   -- - | otherwise = ->     IL.FunctionDecl f' vs (translType' m tyEnv tcEnv ty) expr->    -- = IL.FunctionDecl f' vs (translType ty)->    --                  (match ev vs (map (translEquation tyEnv vs vs'') eqs))->   where f'  = qualifyWith m f->         ty  = varType tyEnv f'->         -- ty' = elimRecordType m tyEnv tcEnv (maximum (0:(typeVars ty))) ty->         ev' = Map.lookup f evEnv->         ev  = maybe (defaultMode ty) evalMode ev'->         vs  = if not flat && isFpSelectorId f then translArgs eqs vs' else vs'->         (vs',vs'') = splitAt (equationArity (head eqs)) ->                              (argNames (mkIdent ""))->         expr | ev' == Just EvalChoice->                = IL.Apply ->                    (IL.Function ->                       (qualifyWith preludeMIdent (mkIdent "commit"))->                       1)->                    (match (srcRefOf pos) IL.Rigid vs ->                       (map (translEquation tyEnv vs vs'') eqs))->              | otherwise->                =  match (srcRefOf pos) ev vs (map (translEquation tyEnv vs vs'') eqs)->         ---->         -- (vs',vs'') = splitAt (arrowArity ty) (argNames (mkIdent ""))--> evalMode :: EvalAnnotation -> IL.Eval-> evalMode EvalRigid = IL.Rigid-> evalMode EvalChoice = error "eval choice is not yet supported"--> defaultMode :: Type -> IL.Eval-> defaultMode _ = IL.Flex->-> --defaultMode ty = if isIO (arrowBase ty) then IL.Rigid else IL.Flex-> --  where TypeConstructor qIOId _ = ioType undefined-> --        isIO (TypeConstructor tc [_]) = tc == qIOId-> --        isIO _ = False--> translArgs :: [Equation] -> [Ident] -> [Ident]-> translArgs [Equation _ (FunLhs _ (t:ts)) _] (v:_) =->   v : map (translArg (bindRenameEnv v t Map.empty)) ts->   where translArg env (VariablePattern v) = fromJust (Map.lookup v env)--> translEquation :: ValueEnv -> [Ident] -> [Ident] -> Equation->                -> ([NestedTerm],IL.Expression)-> translEquation tyEnv vs vs' (Equation _ (FunLhs _ ts) rhs) =->   (zipWith translTerm vs ts,->    translRhs tyEnv vs' (foldr2 bindRenameEnv Map.empty vs ts) rhs)--> translRhs :: ValueEnv -> [Ident] -> RenameEnv -> Rhs -> IL.Expression-> translRhs tyEnv vs env (SimpleRhs _ e _) = translExpr tyEnv vs env e---> equationArity :: Equation -> Int-> equationArity (Equation _ lhs _) = p_equArity lhs->  where->    p_equArity (FunLhs _ ts) = length ts->    p_equArity (OpLhs _ _ _) = 2->    p_equArity _             = error "ILTrans - illegal equation"---\end{verbatim}-\paragraph{Pattern Matching}-The pattern matching code searches for the left-most inductive-argument position in the left hand sides of all rules defining an-equation. An inductive position is a position where all rules have a-constructor rooted term. If such a position is found, a \texttt{case}-expression is generated for the argument at that position. The-matching code is then computed recursively for all of the alternatives-independently. If no inductive position is found, the algorithm looks-for the left-most demanded argument position, i.e., a position where-at least one of the rules has a constructor rooted term. If such a-position is found, an \texttt{or} expression is generated with those-cases that have a variable at the argument position in one branch and-all other rules in the other branch. If there is no demanded position,-the pattern matching is finished and the compiler translates the right-hand sides of the remaining rules, eventually combining them using-\texttt{or} expressions.--Actually, the algorithm below combines the search for inductive and-demanded positions. The function \texttt{match} scans the argument-lists for the left-most demanded position. If this turns out to be-also an inductive position, the function \texttt{matchInductive} is-called in order to generate a \texttt{case} expression. Otherwise, the-function \texttt{optMatch} is called that tries to find an inductive-position in the remaining arguments. If one is found,-\texttt{matchInductive} is called, otherwise the function-\texttt{optMatch} uses the demanded argument position found by-\texttt{match}.-\begin{verbatim}--> data NestedTerm = NestedTerm IL.ConstrTerm [NestedTerm] deriving Show--> pattern (NestedTerm t _) = t-> arguments (NestedTerm _ ts) = ts--> translLiteral :: Literal -> IL.Literal-> translLiteral (Char p c) = IL.Char p c-> translLiteral (Int id i) = IL.Int (srcRefOf (positionOfIdent id)) i-> translLiteral (Float p f) = IL.Float p f-> translLiteral _ = internalError "translLiteral"--> translTerm :: Ident -> ConstrTerm -> NestedTerm-> translTerm _ (LiteralPattern l) =->   NestedTerm (IL.LiteralPattern (translLiteral l)) []-> translTerm v (VariablePattern _) = NestedTerm (IL.VariablePattern v) []-> translTerm v (ConstructorPattern c ts) =->   NestedTerm (IL.ConstructorPattern c (take (length ts) vs))->              (zipWith translTerm vs ts)->   where vs = argNames v-> translTerm v (AsPattern _ t) = translTerm v t-> translTerm _ _ = internalError "translTerm"--> bindRenameEnv :: Ident -> ConstrTerm -> RenameEnv -> RenameEnv-> bindRenameEnv _ (LiteralPattern _) env = env-> bindRenameEnv v (VariablePattern v') env = Map.insert v' v env-> bindRenameEnv v (ConstructorPattern _ ts) env =->   foldr2 bindRenameEnv env (argNames v) ts-> bindRenameEnv v (AsPattern v' t) env = Map.insert v' v (bindRenameEnv v t env)-> bindRenameEnv _ _ env = internalError "bindRenameEnv"--> argNames :: Ident -> [Ident]-> argNames v = [mkIdent (prefix ++ show i) | i <- [1..]]->   where prefix = name v ++ "_"--> type Match = ([NestedTerm],IL.Expression)-> type Match' = ([NestedTerm] -> [NestedTerm],[NestedTerm],IL.Expression)--> isDefaultPattern :: IL.ConstrTerm -> Bool-> isDefaultPattern (IL.VariablePattern _) = True-> isDefaultPattern _ = False--> isDefaultMatch :: (IL.ConstrTerm,a) -> Bool-> isDefaultMatch = isDefaultPattern . fst--> match :: SrcRef -> IL.Eval -> [Ident] -> [Match] -> IL.Expression-> match _   ev [] alts = foldl1 IL.Or (map snd alts)-> match pos ev (v:vs) alts->   | null vars = e1->   | null nonVars = e2->   | otherwise = optMatch pos ev (IL.Or e1 e2) (v:) vs (map skipArg alts)->   where (vars,nonVars) = partition isDefaultMatch (map tagAlt alts)->         e1 = matchInductive pos ev id v vs nonVars->         e2 = match pos ev vs (map snd vars)->         tagAlt (t:ts,e) = (pattern t,(arguments t ++ ts,e))->         skipArg (t:ts,e) = ((t:),ts,e)--> optMatch :: SrcRef -> IL.Eval -> IL.Expression -> ([Ident] -> [Ident]) ->    -> [Ident] ->[Match'] -> IL.Expression-> optMatch _ ev e prefix [] alts = e-> optMatch pos ev e prefix (v:vs) alts->   | null vars = matchInductive pos ev prefix v vs nonVars->   | otherwise = optMatch pos ev e (prefix . (v:)) vs (map skipArg alts)->   where (vars,nonVars) = partition isDefaultMatch (map tagAlt alts)->         tagAlt (prefix,t:ts,e) = (pattern t,(prefix (arguments t ++ ts),e))->         skipArg (prefix,t:ts,e) = (prefix . (t:),ts,e)--> matchInductive :: SrcRef -> IL.Eval -> ([Ident] -> [Ident]) -> Ident ->    -> [Ident] ->[(IL.ConstrTerm,Match)] -> IL.Expression-> matchInductive pos ev prefix v vs alts =->   IL.Case pos ev (IL.Variable v) (matchAlts ev prefix vs alts)--> matchAlts :: IL.Eval -> ([Ident] -> [Ident]) -> [Ident] ->->     [(IL.ConstrTerm,Match)] -> [IL.Alt]-> matchAlts ev prefix vs [] = []-> matchAlts ev prefix vs ((t,alt):alts) =->   IL.Alt t (match (srcRefOf t) ->                   ev (prefix (vars t ++ vs)) (alt : map snd same)) :->   matchAlts ev prefix vs others->   where (same,others) = partition ((t ==) . fst) alts ->         vars (IL.ConstructorPattern _ vs) = vs->         vars _ = []--\end{verbatim}-Matching in a \texttt{case}-expression works a little bit differently.-In this case, the alternatives are matched from the first to the last-alternative and the first matching alternative is chosen. All-remaining alternatives are discarded.--\ToDo{The case matching algorithm should use type information in order-to detect total matches and immediately discard all alternatives which-cannot be reached.}-\begin{verbatim}--> caseMatch :: SrcRef -> ([Ident] -> [Ident]) -> [Ident] -> [Match'] ->    -> IL.Expression-> caseMatch _ prefix [] alts = thd3 (head alts)-> caseMatch r prefix (v:vs) alts->   | isDefaultMatch (head alts') =->       caseMatch r (prefix . (v:)) vs (map skipArg alts)->   | otherwise =->       IL.Case r IL.Rigid (IL.Variable v) (caseMatchAlts prefix vs alts')->   where alts' = map tagAlt alts->         tagAlt (prefix,t:ts,e) = (pattern t,(prefix,arguments t ++ ts,e))->         skipArg (prefix,t:ts,e) = (prefix . (t:),ts,e)--> caseMatchAlts ::->     ([Ident] -> [Ident]) -> [Ident] -> [(IL.ConstrTerm,Match')] -> [IL.Alt]-> caseMatchAlts prefix vs alts = map caseAlt (ts ++ ts')->   where (ts',ts) = partition isDefaultPattern (nub (map fst alts))->         caseAlt t =->           IL.Alt t (caseMatch (srcRefOf t) id (prefix (vars t ++ vs))->                               (matchingCases t alts))->         matchingCases t =->           map (joinArgs (vars t)) . filter (matches t . fst)->         matches t t' = t == t' || isDefaultPattern t'->         joinArgs vs (IL.VariablePattern _,(prefix,ts,e)) =->            (id,prefix (map varPattern vs ++ ts),e)->         joinArgs _ (_,(prefix,ts,e)) = (id,prefix ts,e)->         varPattern v = NestedTerm (IL.VariablePattern v) []->         vars (IL.ConstructorPattern _ vs) = vs->         vars _ = []--\end{verbatim}-\paragraph{Expressions}-Note that the case matching algorithm assumes that the matched-expression is accessible through a variable. The translation of case-expressions therefore introduces a let binding for the scrutinized-expression and immediately throws it away after the matching -- except-if the matching algorithm has decided to use that variable in the-right hand sides of the case expression. This may happen, for-instance, if one of the alternatives contains an \texttt{@}-pattern.-\begin{verbatim}--> translExpr :: ValueEnv -> [Ident] -> RenameEnv -> Expression -> IL.Expression-> translExpr _ _ _ (Literal l) = IL.Literal (translLiteral l)-> translExpr tyEnv _ env (Variable v) =->   case lookupVar v env of->     Just v' -> IL.Variable v'->     Nothing -> IL.Function v (arrowArity (varType tyEnv v))->   where lookupVar v env->           | isQualified v = Nothing->           | otherwise = Map.lookup (unqualify v) env-> translExpr tyEnv _ _ (Constructor c) =->   IL.Constructor c (arrowArity (constrType tyEnv c))-> translExpr tyEnv vs env (Apply e1 e2) =->   IL.Apply (translExpr tyEnv vs env e1) (translExpr tyEnv vs env e2)-> translExpr tyEnv vs env (Let ds e) =->   case ds of->     [ExtraVariables _ vs] -> foldr IL.Exist e' vs->     [d] | all (`notElem` bv d) (qfv emptyMIdent d) ->->       IL.Let (translBinding env' d) e'->     _ -> IL.Letrec (map (translBinding env') ds) e'->   where e' = translExpr tyEnv vs env' e->         env' = foldr2 Map.insert env bvs bvs->         bvs = bv ds->         translBinding env (PatternDecl _ (VariablePattern v) rhs) =->           IL.Binding v (translRhs tyEnv vs env rhs)->         translBinding env p = error $ "unexpected binding: "++show p-> translExpr tyEnv ~(v:vs) env (Case r e alts) =->   case caseMatch r id [v] (map (translAlt v) alts) of->     IL.Case r mode (IL.Variable v') alts'->       | v == v' && v `notElem` fv alts' -> IL.Case r mode e' alts'->     e''->       | v `elem` fv e'' -> IL.Let (IL.Binding v e') e''->       | otherwise -> e''->   where e' = translExpr tyEnv vs env e->         translAlt v (Alt _ t rhs) =->           (id,->            [translTerm v t],->            translRhs tyEnv vs (bindRenameEnv v t env) rhs)-> translExpr _ _ _ _ = internalError "translExpr"--> instance Expr IL.Expression where->   fv (IL.Variable v) = [v]->   fv (IL.Apply e1 e2) = fv e1 ++ fv e2->   fv (IL.Case _ _ e alts) = fv e ++ fv alts->   fv (IL.Or e1 e2) = fv e1 ++ fv e2->   fv (IL.Exist v e) = filter (/= v) (fv e)->   fv (IL.Let (IL.Binding v e1) e2) = fv e1 ++ filter (/= v) (fv e2)->   fv (IL.Letrec bds e) = filter (`notElem` vs) (fv es ++ fv e)->     where (vs,es) = unzip [(v,e) | IL.Binding v e <- bds]->   fv _ = []--> instance Expr IL.Alt where->   fv (IL.Alt (IL.ConstructorPattern _ vs) e) = filter (`notElem` vs) (fv e)->   fv (IL.Alt (IL.VariablePattern v) e) = filter (v /=) (fv e)->   fv (IL.Alt _ e) = fv e--\end{verbatim}-\paragraph{Auxiliary Definitions}-The functions \texttt{varType} and \texttt{constrType} return the type-of variables and constructors, respectively. The quantifiers are-stripped from the types.-\begin{verbatim}--> varType :: ValueEnv -> QualIdent -> Type-> varType tyEnv f =->   case qualLookupValue f tyEnv of->     [Value _ (ForAll _ ty)] -> ty->     _ -> internalError ("varType: " ++ show f)--> constrType :: ValueEnv -> QualIdent -> Type-> constrType tyEnv c =->   case qualLookupValue c tyEnv of->     [DataConstructor _ (ForAllExist _ _ ty)] -> ty->     [NewtypeConstructor _ (ForAllExist _ _ ty)] -> ty->     _ -> internalError ("constrType: " ++ show c)--\end{verbatim}-The list of import declarations in the intermediate language code is-determined by collecting all module qualifiers used in the current-module.-\begin{verbatim}--> imports :: ModuleIdent -> [IL.Decl] -> [ModuleIdent]-> imports m = Set.toList . Set.delete m . Set.fromList . foldr modulesDecl []--> modulesDecl :: IL.Decl -> [ModuleIdent] -> [ModuleIdent]-> modulesDecl (IL.DataDecl _ _ cs) ms = foldr modulesConstrDecl ms cs->   where modulesConstrDecl (IL.ConstrDecl _ tys) ms = foldr modulesType ms tys-> modulesDecl (IL.NewtypeDecl _ _ (IL.ConstrDecl _ ty)) ms = modulesType ty ms-> modulesDecl (IL.FunctionDecl _ _ ty e) ms = modulesType ty (modulesExpr e ms)-> modulesDecl (IL.ExternalDecl _ _ _ ty) ms = modulesType ty ms--> modulesType :: IL.Type -> [ModuleIdent] -> [ModuleIdent]-> modulesType (IL.TypeConstructor tc tys) ms =->   modules tc (foldr modulesType ms tys)-> modulesType (IL.TypeVariable _) ms = ms-> modulesType (IL.TypeArrow ty1 ty2) ms = modulesType ty1 (modulesType ty2 ms)--> modulesExpr :: IL.Expression -> [ModuleIdent] -> [ModuleIdent]-> modulesExpr (IL.Function f _) ms = modules f ms-> modulesExpr (IL.Constructor c _) ms = modules c ms-> modulesExpr (IL.Apply e1 e2) ms = modulesExpr e1 (modulesExpr e2 ms)-> modulesExpr (IL.Case _ _ e as) ms = modulesExpr e (foldr modulesAlt ms as)->   where modulesAlt (IL.Alt t e) ms = modulesConstrTerm t (modulesExpr e ms)->         modulesConstrTerm (IL.ConstructorPattern c _) ms = modules c ms->         modulesConstrTerm _ ms = ms-> modulesExpr (IL.Or e1 e2) ms = modulesExpr e1 (modulesExpr e2 ms)-> modulesExpr (IL.Exist _ e) ms = modulesExpr e ms-> modulesExpr (IL.Let b e) ms = modulesBinding b (modulesExpr e ms)-> modulesExpr (IL.Letrec bs e) ms = foldr modulesBinding (modulesExpr e ms) bs-> modulesExpr _ ms = ms--> modulesBinding :: IL.Binding -> [ModuleIdent] -> [ModuleIdent]-> modulesBinding (IL.Binding _ e) = modulesExpr e--> modules :: QualIdent -> [ModuleIdent] -> [ModuleIdent]-> modules x ms = maybe ms (: ms) (qualidMod x)--\end{verbatim}-
+ src/IL/Pretty.hs view
@@ -0,0 +1,189 @@+{- |+    Module      :  $Header$+    Description :  Pretty printer for IL+    Copyright   :  (c) 1999 - 2003 Wolfgang Lux+                                   Martin Engelke+                       2011 - 2015 Björn Peemöller+                       2017        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++   This module implements just another pretty printer, this time for the+   intermediate language. It was mainly adapted from the Curry pretty+   printer which, in turn, is based on Simon Marlow's pretty printer+   for Haskell.+-}+{-# LANGUAGE CPP #-}+module IL.Pretty (ppModule) where++#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif++import Curry.Base.Ident+import Curry.Base.Pretty+import IL.Type++dataIndent :: Int+dataIndent = 2++bodyIndent :: Int+bodyIndent = 2++exprIndent :: Int+exprIndent = 2++caseIndent :: Int+caseIndent = 2++altIndent :: Int+altIndent = 2++orIndent :: Int+orIndent = 2++ppModule :: Module -> Doc+ppModule (Module m is ds) = sepByBlankLine+  [ppHeader m, vcat (map ppImport is), sepByBlankLine (map ppDecl ds)]++ppHeader :: ModuleIdent -> Doc+ppHeader m = text "module" <+> text (moduleName m) <+> text "where"++ppImport :: ModuleIdent -> Doc+ppImport m = text "import" <+> text (moduleName m)++ppDecl :: Decl -> Doc+ppDecl (DataDecl                   tc ks cs) = sep $+  text "data" <+> ppTypeLhs tc (length ks) :+  map (nest dataIndent)+      (zipWith (<+>) (equals : repeat (char '|')) (map ppConstr cs))+ppDecl (NewtypeDecl                tc ks nc) = sep $+  text "newtype" <+> ppTypeLhs tc (length ks) :+  [nest dataIndent (equals <+> ppNewConstr nc)]+ppDecl (ExternalDataDecl              tc ks) =+  text "external data" <+> ppTypeLhs tc (length ks)+ppDecl (FunctionDecl             f vs ty e) = ppTypeSig f ty $$ sep+  [ ppQIdent f <+> hsep (map (ppIdent . snd) vs) <+> equals+  , nest bodyIndent (ppExpr 0 e)]+ppDecl (ExternalDecl f _ ty) = text "external" <+> ppTypeSig f ty++ppTypeLhs :: QualIdent -> Int -> Doc+ppTypeLhs tc n = ppQIdent tc <+> hsep (map text (take n typeVars))++ppConstr :: ConstrDecl -> Doc+ppConstr (ConstrDecl c tys) = ppQIdent c <+> fsep (map (ppType 2) tys)++ppNewConstr :: NewConstrDecl -> Doc+ppNewConstr (NewConstrDecl c ty) = ppQIdent c <+> fsep [ppType 2 ty]++ppTypeSig :: QualIdent -> Type -> Doc+ppTypeSig f ty = ppQIdent f <+> text "::" <+> ppType 0 ty++ppType :: Int -> Type -> Doc+ppType p (TypeConstructor tc tys)+  | isQTupleId tc                    = parens+    (fsep (punctuate comma (map (ppType 0) tys)))+  | tc == qListId && length tys == 1 = brackets (ppType 0 (head tys))+  | otherwise                        = parenIf (p > 1 && not (null tys))+    (ppQIdent tc <+> fsep (map (ppType 2) tys))+ppType _ (TypeVariable      n) = ppTypeVar n+ppType p (TypeArrow   ty1 ty2) = parenIf (p > 0)+                                 (fsep (ppArrow (TypeArrow ty1 ty2)))+  where+  ppArrow (TypeArrow ty1' ty2') = ppType 1 ty1' <+> text "->" : ppArrow ty2'+  ppArrow ty                    = [ppType 0 ty]+ppType p (TypeForall ns ty)+  | null ns   = ppType p ty+  | otherwise = parenIf (p > 0) $ ppQuantifiedTypeVars ns <+> ppType 0 ty++ppTypeVar :: Int -> Doc+ppTypeVar n+  | n >= 0    = text (typeVars !! n)+  | otherwise = text ('_':show (-n))++ppQuantifiedTypeVars :: [(Int, Kind)] -> Doc+ppQuantifiedTypeVars ns+  | null ns = empty+  | otherwise = text "forall" <+> hsep (map (ppTypeVar . fst) ns) <> char '.'++ppBinding :: Binding -> Doc+ppBinding (Binding v expr) = sep+  [ppIdent v <+> equals, nest bodyIndent (ppExpr 0 expr)]++ppAlt :: Alt -> Doc+ppAlt (Alt pat expr) = sep+  [ppConstrTerm pat <+> text "->", nest altIndent (ppExpr 0 expr)]++ppLiteral :: Literal -> Doc+ppLiteral (Char  c) = text (show c)+ppLiteral (Int   i) = integer i+ppLiteral (Float f) = double f++ppConstrTerm :: ConstrTerm -> Doc+ppConstrTerm (LiteralPattern     _                    l) = ppLiteral l+ppConstrTerm (ConstructorPattern _ c [(_, v1), (_, v2)])+  | isQInfixOp c = ppIdent v1 <+> ppQInfixOp c <+> ppIdent v2+ppConstrTerm (ConstructorPattern _ c                 vs)+  | isQTupleId c = parens $ fsep (punctuate comma $ map (ppIdent . snd) vs)+  | otherwise    = ppQIdent c <+> fsep (map (ppIdent . snd) vs)+ppConstrTerm (VariablePattern    _                    v) = ppIdent v++ppExpr :: Int -> Expression -> Doc+ppExpr _ (Literal       _ l) = ppLiteral l+ppExpr _ (Variable      _ v) = ppIdent v+ppExpr _ (Function    _ f _) = ppQIdent f+ppExpr _ (Constructor _ c _) = ppQIdent c+ppExpr p (Apply (Apply (Function    _ f _) e1) e2)+  | isQInfixOp f = ppInfixApp p e1 f e2+ppExpr p (Apply (Apply (Constructor _ c _) e1) e2)+  | isQInfixOp c = ppInfixApp p e1 c e2+ppExpr p (Apply       e1 e2) = parenIf (p > 2) $ sep+  [ppExpr 2 e1, nest exprIndent (ppExpr 3 e2)]+ppExpr p (Case    ev e alts) = parenIf (p > 0) $+  text "case" <+> ppEval ev <+> ppExpr 0 e <+> text "of"+  $$ nest caseIndent (vcat $ map ppAlt alts)+  where ppEval Rigid = text "rigid"+        ppEval Flex  = text "flex"+ppExpr p (Or          e1 e2) = parenIf (p > 0) $ sep+  [nest orIndent (ppExpr 0 e1), char '|', nest orIndent (ppExpr 0 e2)]+ppExpr p (Exist       v _ e) = parenIf (p > 0) $ sep+  [text "let" <+> ppIdent v <+> text "free" <+> text "in", ppExpr 0 e]+ppExpr p (Let           b e) = parenIf (p > 0) $ sep+  [text "let" <+> ppBinding b <+> text "in",ppExpr 0 e]+ppExpr p (Letrec       bs e) = parenIf (p > 0) $ sep+  [text "letrec" <+> vcat (map ppBinding bs) <+> text "in", ppExpr 0 e]+ppExpr p (Typed        e ty) = parenIf (p > 0) $ sep+  [ppExpr 0 e, text "::", ppType 0 ty]++ppInfixApp :: Int -> Expression -> QualIdent -> Expression -> Doc+ppInfixApp p e1 op e2 = parenIf (p > 1) $ sep+  [ppExpr 2 e1 <+> ppQInfixOp op, nest exprIndent (ppExpr 2 e2)]++ppIdent :: Ident -> Doc+ppIdent ident+  | isInfixOp ident = parens (ppName ident)+  | otherwise       = ppName ident++ppQIdent :: QualIdent -> Doc+ppQIdent ident+  | isQInfixOp ident = parens (ppQual ident)+  | otherwise        = ppQual ident++ppQInfixOp :: QualIdent -> Doc+ppQInfixOp op+  | isQInfixOp op = ppQual op+  | otherwise     = char '`' <> ppQual op <> char '`'++ppName :: Ident -> Doc+ppName x = text (idName x)++ppQual :: QualIdent -> Doc+ppQual x = text (qualName x)++typeVars :: [String]+typeVars = [mkTypeVar c i | i <- [0 .. ], c <- ['a' .. 'z']] where+  mkTypeVar :: Char -> Int -> String+  mkTypeVar c i = c : if i == 0 then [] else show i
− src/IL/Pretty.lhs 
@@ -1,167 +0,0 @@-% $Id: ILPP.lhs,v 1.22 2003/10/28 05:43:43 wlux Exp $-%-% Copyright (c) 1999-2003 Wolfgang Lux-% See LICENSE for the full license.-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-%-\nwfilename{ILPP.lhs}-\section{A pretty printer for the intermediate language}-This module implements just another pretty printer, this time for the-intermediate language. It was mainly adapted from the Curry pretty-printer (see sect.~\ref{sec:CurryPP}) which, in turn, is based on Simon-Marlow's pretty printer for Haskell.-\begin{verbatim}--> module IL.Pretty(ppModule)  where-> -> import Text.PrettyPrint.HughesPJ--> import Curry.Base.Ident-> import IL.Type--> default(Int,Double)--> dataIndent = 2-> bodyIndent = 2-> exprIndent = 2-> caseIndent = 2-> altIndent = 2--> ppModule :: Module -> Doc-> ppModule (Module m is ds) =->   vcat (text "module" <+> text (show m) <+> text "where" :->         map ppImport is ++ map ppDecl ds)--> ppImport :: ModuleIdent -> Doc-> ppImport m = text "import" <+> text (show m)--> ppDecl :: Decl -> Doc-> ppDecl (DataDecl tc n cs) =->   sep (text "data" <+> ppTypeLhs tc n :->        map (nest dataIndent)->            (zipWith (<+>) (equals : repeat (char '|')) (map ppConstr cs)))-> ppDecl (NewtypeDecl tc n (ConstrDecl c ty)) =->   sep [text "newtype" <+> ppTypeLhs tc n <+> equals,->        nest dataIndent (ppConstr (ConstrDecl c [ty]))]-> ppDecl (FunctionDecl f vs ty exp) =->   ppTypeSig f ty $$->   sep [ppQIdent f <+> hsep (map ppIdent vs) <+> equals,->        nest bodyIndent (ppExpr 0 exp)]-> ppDecl (ExternalDecl f cc ie ty) =->   sep [text "external" <+> ppCallConv cc <+> text (show ie),->        nest bodyIndent (ppTypeSig f ty)]->   where ppCallConv Primitive = text "primitive"->         ppCallConv CCall = text "ccall"--> ppTypeLhs :: QualIdent -> Int -> Doc-> ppTypeLhs tc n = ppQIdent tc <+> hsep (map text (take n typeVars))--> ppConstr :: ConstrDecl [Type] -> Doc-> ppConstr (ConstrDecl c tys) = ppQIdent c <+> fsep (map (ppType 2) tys)--> ppTypeSig :: QualIdent -> Type -> Doc-> ppTypeSig f ty = ppQIdent f <+> text "::" <+> ppType 0 ty--> ppType :: Int -> Type -> Doc-> ppType p (TypeConstructor tc tys)->   | isQTupleId tc = parens (fsep (punctuate comma (map (ppType 0) tys)))->   | unqualify tc == nilId = brackets (ppType 0 (head tys))->   | otherwise =->       ppParen (p > 1 && not (null tys))->               (ppQIdent tc <+> fsep (map (ppType 2) tys))-> ppType _ (TypeVariable n)->   | n >= 0 = text (typeVars !! n)->   | otherwise = text ('_':show (-n))-> ppType p (TypeArrow ty1 ty2) =->   ppParen (p > 0) (fsep (ppArrow (TypeArrow ty1 ty2)))->   where ppArrow (TypeArrow ty1 ty2) =->           ppType 1 ty1 <+> text "->" : ppArrow ty2->         ppArrow ty = [ppType 0 ty]--> ppBinding :: Binding -> Doc-> ppBinding (Binding v exp) =->   sep [ppIdent v <+> equals,nest bodyIndent (ppExpr 0 exp)]--> ppAlt :: Alt -> Doc-> ppAlt (Alt pat exp) =->   sep [ppConstrTerm pat <+> text "->",nest altIndent (ppExpr 0 exp)]--> ppLiteral :: Literal -> Doc-> ppLiteral (Char _ c) = text (show c)-> ppLiteral (Int _ i) = integer i-> ppLiteral (Float _ f) = double f--> ppConstrTerm :: ConstrTerm -> Doc-> ppConstrTerm (LiteralPattern l) = ppLiteral l-> ppConstrTerm (ConstructorPattern c [v1,v2])->   | isQInfixOp c = ppIdent v1 <+> ppQInfixOp c <+> ppIdent v2-> ppConstrTerm (ConstructorPattern c vs)->   | isQTupleId c = parens (fsep (punctuate comma (map ppIdent vs)))->   | otherwise = ppQIdent c <+> fsep (map ppIdent vs)-> ppConstrTerm (VariablePattern v) = ppIdent v--> ppExpr :: Int -> Expression -> Doc-> ppExpr p (Literal l) = ppLiteral l-> ppExpr p (Variable v) = ppIdent v-> ppExpr p (Function f _) = ppQIdent f-> ppExpr p (Constructor c _) = ppQIdent c-> ppExpr p (Apply (Apply (Function f _) e1) e2)->   | isQInfixOp f = ppInfixApp p e1 f e2-> ppExpr p (Apply (Apply (Constructor c _) e1) e2)->   | isQInfixOp c = ppInfixApp p e1 c e2-> ppExpr p (Apply e1 e2) =->   ppParen (p > 2) (sep [ppExpr 2 e1,nest exprIndent (ppExpr 3 e2)])-> ppExpr p (Case _ ev e alts) =->   ppParen (p > 0)->           (text "case" <+> ppEval ev <+> ppExpr 0 e <+> text "of" $$->            nest caseIndent (vcat (map ppAlt alts)))->   where ppEval Rigid = text "rigid"->         ppEval Flex = text "flex"-> ppExpr p (Or e1 e2) =->   ppParen (p > 0) (sep [ppExpr 0 e1,char '|' <+> ppExpr 0 e2])-> ppExpr p (Exist v e) =->   ppParen (p > 0)->           (sep [text "let" <+> ppIdent v <+> text "free" <+> text "in",->                 ppExpr 0 e])-> ppExpr p (Let b e) =->   ppParen (p > 0) (sep [text "let" <+> ppBinding b <+> text "in",ppExpr 0 e])-> ppExpr p (Letrec bs e) =->   ppParen (p > 0)->           (sep [text "letrec" <+> vcat (map ppBinding bs) <+> text "in",->                 ppExpr 0 e])--> ppInfixApp :: Int -> Expression -> QualIdent -> Expression -> Doc-> ppInfixApp p e1 op e2 =->   ppParen (p > 1)->           (sep [ppExpr 2 e1 <+> ppQInfixOp op,nest exprIndent (ppExpr 2 e2)])--> ppIdent :: Ident -> Doc-> ppIdent ident->   | isInfixOp ident = parens (ppName ident)->   | otherwise = ppName ident--> ppQIdent :: QualIdent -> Doc-> ppQIdent ident->   | isQInfixOp ident = parens (ppQual ident)->   | otherwise = ppQual ident--> ppQInfixOp :: QualIdent -> Doc-> ppQInfixOp op->   | isQInfixOp op = ppQual op->   | otherwise = char '`' <> ppQual op <> char '`'--> ppName :: Ident -> Doc-> ppName x = text (name x)--> ppQual :: QualIdent -> Doc-> ppQual x = text (qualName x)--> typeVars :: [String]-> typeVars = [mkTypeVar c i | i <- [0..], c <- ['a' .. 'z']]->   where mkTypeVar c i = c : if i == 0 then [] else show i--> ppParen :: Bool -> Doc -> Doc-> ppParen p = if p then parens else id--\end{verbatim}
− src/IL/Scope.hs 
@@ -1,124 +0,0 @@-module IL.Scope (getModuleScope,-		insertDeclScope, insertConstrDeclScope,-		insertCallConvScope, insertTypeScope,-		insertLiteralScope, insertConstrTermScope,-		insertExprScope, insertAltScope,-		insertBindingScope) where--import Curry.Base.Ident--import IL.Type-import OldScopeEnv as ScopeEnv---------------------------------------------------------------------------------------getModuleScope :: Module -> ScopeEnv-getModuleScope (Module _ _ decls) = foldl insertDecl newScopeEnv decls------insertDeclScope :: ScopeEnv -> Decl -> ScopeEnv-insertDeclScope env (DataDecl _ _ _) = env-insertDeclScope env (NewtypeDecl _ _ _) = env-insertDeclScope env (FunctionDecl _ params _ _)-   = foldr ScopeEnv.insertIdent (ScopeEnv.beginScope env) params-insertDeclScope env (ExternalDecl _ _ _ _) = env------insertConstrDeclScope :: ScopeEnv -> ConstrDecl [Type] -> ScopeEnv-insertConstrDeclScope env _ = env------insertCallConvScope :: ScopeEnv -> CallConv -> ScopeEnv-insertCallConvScope env _ = env------insertTypeScope :: ScopeEnv -> Type -> ScopeEnv-insertTypeScope env _ = env------insertLiteralScope :: ScopeEnv -> Literal -> ScopeEnv-insertLiteralScope env _ = env------insertConstrTermScope :: ScopeEnv -> ConstrTerm -> ScopeEnv-insertConstrTermScope env _ = env------insertExprScope :: ScopeEnv -> Expression -> ScopeEnv-insertExprScope env (Literal _) = env-insertExprScope env (Variable _) = env-insertExprScope env (Function _ _) = env-insertExprScope env (Constructor _ _) = env-insertExprScope env (Apply _ _) = env-insertExprScope env (Case _ _ _ _) = env-insertExprScope env (Or _ _) = env-insertExprScope env (Exist ident _)-   = ScopeEnv.insertIdent ident (ScopeEnv.beginScope env)-insertExprScope env (Let bind _)-   = insertBinding (beginScope env) bind-insertExprScope env (Letrec binds _)-   = foldl insertBinding (beginScope env) binds------insertAltScope :: ScopeEnv -> Alt -> ScopeEnv-insertAltScope env (Alt cterm _)-   = insertConstrTerm (ScopeEnv.beginScope env) cterm------insertBindingScope :: ScopeEnv -> Binding -> ScopeEnv-insertBindingScope env _ = env-----------------------------------------------------------------------------------------------------------------------------------------------------------------------insertDecl :: ScopeEnv -> Decl -> ScopeEnv-insertDecl env (DataDecl qident _ cdecls)-   = foldl insertConstrDecl-	 (ScopeEnv.insertIdent (unqualify qident) env)-	 cdecls--insertDecl env (NewtypeDecl qident _ cdecl)-   = insertConstrDecl (ScopeEnv.insertIdent (unqualify qident) env) cdecl--insertDecl env (FunctionDecl qident _ _ _)-   = ScopeEnv.insertIdent (unqualify qident) env--insertDecl env (ExternalDecl qident _ _ _)-   = ScopeEnv.insertIdent (unqualify qident) env------insertConstrDecl :: ScopeEnv -> ConstrDecl a -> ScopeEnv-insertConstrDecl env (ConstrDecl qident _)-   = ScopeEnv.insertIdent (unqualify qident) env------insertConstrTerm :: ScopeEnv -> ConstrTerm -> ScopeEnv-insertConstrTerm env (LiteralPattern _) = env-insertConstrTerm env (ConstructorPattern _ params)-   = foldr ScopeEnv.insertIdent env params-insertConstrTerm env (VariablePattern ident)-   = ScopeEnv.insertIdent ident env------insertBinding :: ScopeEnv -> Binding -> ScopeEnv-insertBinding env (Binding ident _) = ScopeEnv.insertIdent ident env------------------------------------------------------------------------------------------------------------------------------------------------------------------
+ src/IL/ShowModule.hs view
@@ -0,0 +1,263 @@+{- |+    Module      :  $Header$+    Description :  Custom Show implementation for IL+    Copyright   :  (c) 2015        Björn Peemöller+                       2016 - 2017 Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++   This module implements a generic show function comparable to the one+   obtained by @deriving Show@. However, the internal representation of+   identifiers is hidden to avoid syntactic clutter.+-}++module IL.ShowModule (showModule) where++import Curry.Base.Ident+import Curry.Base.Position++import IL.Type++-- |Show a IL module like by an devired 'Show' instance+showModule :: Module -> String+showModule m = showsModule m "\n"++showsModule :: Module -> ShowS+showsModule (Module mident imps decls)+  = showsString "Module "+  . showsModuleIdent mident . newline+  . showsList (\i -> showsModuleIdent i . newline) imps+  . showsList (\d -> showsDecl d . newline) decls++showsDecl :: Decl -> ShowS+showsDecl (DataDecl qident arity constrdecls)+  = showsString "(DataDecl "+  . showsQualIdent qident . space+  . shows arity . space+  . showsList showsConstrDecl constrdecls+  . showsString ")"+showsDecl (NewtypeDecl qident arity newconstrdecl)+  = showsString "(NewtypeDecl "+  . showsQualIdent qident . space+  . shows arity . space+  . showsNewConstrDecl newconstrdecl+  . showsString ")"+showsDecl (ExternalDataDecl qident arity)+  = showsString "(ExternalDataDecl "+  . showsQualIdent qident . space+  . shows arity+  . showsString ")"+showsDecl (FunctionDecl qident idents typ expr)+  = showsString "(FunctionDecl "+  . showsQualIdent qident . space+  . showsList (showsIdent . snd) idents . space+  . showsType typ . space+  . showsExpression expr+  . showsString ")"+showsDecl (ExternalDecl qident arity typ)+  = showsString "(ExternalDecl "+  . showsQualIdent qident . space+  . shows arity+  . showsType typ+  . showsString ")"++showsConstrDecl :: ConstrDecl -> ShowS+showsConstrDecl (ConstrDecl qident tys)+  = showsString "(ConstrDecl "+  . showsQualIdent qident . space+  . showsList showsType tys+  . showsString ")"++showsNewConstrDecl :: NewConstrDecl -> ShowS+showsNewConstrDecl (NewConstrDecl qident ty)+  = showsString "(NewConstrDecl "+  . showsQualIdent qident . space+  . showsType ty+  . showsString ")"++showsType :: Type -> ShowS+showsType (TypeConstructor qident types)+  = showsString "(TypeConstructor "+  . showsQualIdent qident . space+  . showsList showsType types+  . showsString ")"+showsType (TypeVariable int)+  = showsString "(TypeVariable "+  . shows int+  . showsString ")"+showsType (TypeArrow type1 type2)+  = showsString "(TypeArrow "+  . showsType type1 . space+  . showsType type2+  . showsString ")"+showsType (TypeForall ints typ)+  = showsString "(TypeForall "+  . showsList shows ints . space+  . showsType typ+  . showsString ")"++showsLiteral :: Literal -> ShowS+showsLiteral (Char c)+  = showsString "(Char "+  . shows c+  . showsString ")"+showsLiteral (Int n)+  = showsString "(Int "+  . shows n+  . showsString ")"+showsLiteral (Float x)+  = showsString "(Float "+  . shows x+  . showsString ")"++showsConstrTerm :: ConstrTerm -> ShowS+showsConstrTerm (LiteralPattern ty lit)+  = showsString "(LiteralPattern "+  . showsType ty+  . showsLiteral lit+  . showsString ")"+showsConstrTerm (ConstructorPattern ty qident idents)+  = showsString "(ConstructorPattern "+  . showsType ty+  . showsQualIdent qident . space+  . showsList (showsIdent . snd) idents+  . showsString ")"+showsConstrTerm (VariablePattern ty ident)+  = showsString "(VariablePattern "+  . showsType ty+  . showsIdent ident+  . showsString ")"++showsExpression :: Expression -> ShowS+showsExpression (Literal ty lit)+  = showsString "(Literal "+  . showsType ty+  . showsLiteral lit+  . showsString ")"+showsExpression (Variable ty ident)+  = showsString "(Variable "+  . showsType ty+  . showsIdent ident+  . showsString ")"+showsExpression (Function ty qident int)+  = showsString "(Function "+  . showsType ty+  . showsQualIdent qident . space+  . shows int+  . showsString ")"+showsExpression (Constructor ty qident int)+  = showsString "(Constructor "+  . showsType ty+  . showsQualIdent qident . space+  . shows int+  . showsString ")"+showsExpression (Apply exp1 exp2)+  = showsString "(Apply "+  . showsExpression exp1 . space+  . showsExpression exp2+  . showsString ")"+showsExpression (Case eval expr alts)+  = showsString "(Case "+  . showsEval eval . space+  . showsExpression expr . space+  . showsList showsAlt alts+  . showsString ")"+showsExpression (Or exp1 exp2)+  = showsString "(Or "+  . showsExpression exp1 . space+  . showsExpression exp2+  . showsString ")"+showsExpression (Exist ident ty expr)+  = showsString "(Exist "+  . showsIdent ident . space+  . showsType ty . space+  . showsExpression expr+  . showsString ")"+showsExpression (Let bind expr)+  = showsString "(Let "+  . showsBinding bind . space+  . showsExpression expr+  . showsString ")"+showsExpression (Letrec binds expr)+  = showsString "(Letrec "+  . showsList showsBinding binds . space+  . showsExpression expr+  . showsString ")"+showsExpression (Typed expr typ)+  = showsString "(Typed "+  . showsExpression expr . space+  . showsType typ+  . showsString ")"++showsEval :: Eval -> ShowS+showsEval Rigid = showsString "Rigid"+showsEval Flex  = showsString "Flex"++showsAlt :: Alt -> ShowS+showsAlt (Alt constr expr)+  = showsString "(Alt "+  . showsConstrTerm constr . space+  . showsExpression expr+  . showsString ")"++showsBinding :: Binding -> ShowS+showsBinding (Binding ident expr)+  = showsString "(Binding "+  . showsIdent ident . space+  . showsExpression expr+  . showsString ")"++showsPosition :: Position -> ShowS+showsPosition Position { line = l, column = c } = showsPair shows shows (l, c)+showsPosition _ = showsString "(0,0)"++showsString :: String -> ShowS+showsString = (++)++space :: ShowS+space = showsString " "++newline :: ShowS+newline = showsString "\n"++showsMaybe :: (a -> ShowS) -> Maybe a -> ShowS+showsMaybe shs = maybe (showsString "Nothing")+                       (\x -> showsString "(Just " . shs x . showsString ")")++showsList :: (a -> ShowS) -> [a] -> ShowS+showsList _   [] = showsString "[]"+showsList shs (x:xs)+  = showsString "["+  . foldl (\sys y -> sys . showsString "," . shs y) (shs x) xs+  . showsString "]"++showsPair :: (a -> ShowS) -> (b -> ShowS) -> (a,b) -> ShowS+showsPair sa sb (a,b)+  = showsString "(" . sa a . showsString "," . sb b . showsString ")"++showsIdent :: Ident -> ShowS+showsIdent (Ident spi x n)+  = showsString "(Ident " . showsPosition (getPosition spi) . space+  . shows x . space . shows n . showsString ")"++showsQualIdent :: QualIdent -> ShowS+showsQualIdent (QualIdent _ mident ident)+  = showsString "(QualIdent "+  . showsMaybe showsModuleIdent mident+  . space+  . showsIdent ident+  . showsString ")"++showsModuleIdent :: ModuleIdent -> ShowS+showsModuleIdent (ModuleIdent spi ss)+  = showsString "(ModuleIdent "+  . showsPosition (getPosition spi) . space+  . showsList (showsQuotes showsString) ss+  . showsString ")"++showsQuotes :: (a -> ShowS) -> a -> ShowS+showsQuotes sa a+  = showsString "\"" . sa a . showsString "\""
+ src/IL/Type.hs view
@@ -0,0 +1,155 @@+{- |+    Module      :  $Header$+    Description :  Definition of the intermediate language (IL)+    Copyright   :  (c) 1999 - 2003 Wolfgang Lux+                                   Martin Engelke+                       2016 - 2017 Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++   The module 'IL' defines the intermediate language which will be+   compiled into abstract machine code. The intermediate language removes+   a lot of syntactic sugar from the Curry source language.  Top-level+   declarations are restricted to data type and function definitions. A+   newtype definition serves mainly as a hint to the backend that it must+   provide an auxiliary function for partial applications of the+   constructor (Newtype constructors must not occur in patterns+   and may be used in expressions only as partial applications.).++   Type declarations use a de-Bruijn indexing scheme (starting at 0) for+   type variables. In the type of a function, all type variables are+   numbered in the order of their occurence from left to right, i.e., a+   type '(Int -> b) -> (a,b) -> c -> (a,c)' is translated into the+   type (using integer numbers to denote the type variables)+   '(Int -> 0) -> (1,0) -> 2 -> (1,2)'.++   Pattern matching in an equation is handled via flexible and rigid+   'Case' expressions. Overlapping rules are translated with the+   help of 'Or' expressions. The intermediate language has three+   kinds of binding expressions, 'Exist' expressions introduce a+   new logical variable, 'Let' expression support a single+   non-recursive variable binding, and 'Letrec' expressions+   introduce multiple variables with recursive initializer expressions.+   The intermediate language explicitly distinguishes (local) variables+   and (global) functions in expressions.++   Note: this modified version uses haskell type 'Integer'+   instead of 'Int' for representing integer values. This provides+   an unlimited range of integer constants in Curry programs.+-}++module IL.Type+  ( -- * Representation of (type) variables+    TypeVariableWithKind+    -- * Data types+  , Module (..), Decl (..), ConstrDecl (..), NewConstrDecl (..), Type (..)+  , Kind (..), Literal (..), ConstrTerm (..), Expression (..), Eval (..)+  , Alt (..), Binding (..)+  ) where++import Curry.Base.Ident++import Base.Expr++data Module = Module ModuleIdent [ModuleIdent] [Decl]+    deriving (Eq, Show)++data Decl+  = DataDecl         QualIdent [Kind] [ConstrDecl]+  | NewtypeDecl      QualIdent [Kind] NewConstrDecl+  | ExternalDataDecl QualIdent [Kind]+  | FunctionDecl     QualIdent [(Type, Ident)] Type Expression+  | ExternalDecl     QualIdent Int Type+    deriving (Eq, Show)++data NewConstrDecl = NewConstrDecl QualIdent Type+    deriving (Eq, Show)++data ConstrDecl = ConstrDecl QualIdent [Type]+    deriving (Eq, Show)++type TypeVariableWithKind = (Int, Kind)++data Type+  = TypeConstructor QualIdent [Type]+  | TypeVariable    Int+  | TypeArrow       Type Type+  | TypeForall      [TypeVariableWithKind] Type+    deriving (Eq, Show)++data Kind+  = KindStar+  | KindVariable Int+  | KindArrow Kind Kind+    deriving (Eq, Ord, Show)++data Literal+  = Char  Char+  | Int   Integer+  | Float Double+    deriving (Eq, Show)++data ConstrTerm+    -- |literal patterns+  = LiteralPattern Type Literal+    -- |constructors+  | ConstructorPattern Type QualIdent [(Type, Ident)]+    -- |default+  | VariablePattern Type Ident+  deriving (Eq, Show)++data Expression+    -- |literal constants+  = Literal Type Literal+    -- |variables+  | Variable Type Ident+    -- |functions+  | Function Type QualIdent Int+    -- |constructors+  | Constructor Type QualIdent Int+    -- |applications+  | Apply Expression Expression+    -- |case expressions+  | Case Eval Expression [Alt]+    -- |non-deterministic or+  | Or Expression Expression+    -- |exist binding (introduction of a free variable)+  | Exist Ident Type Expression+    -- |let binding+  | Let Binding Expression+    -- |letrec binding+  | Letrec [Binding] Expression+    -- |typed expression+  | Typed Expression Type+  deriving (Eq, Show)++data Eval+  = Rigid+  | Flex+    deriving (Eq, Show)++data Alt = Alt ConstrTerm Expression+    deriving (Eq, Show)++data Binding = Binding Ident Expression+    deriving (Eq, Show)++instance Expr Expression where+  fv (Variable          _ v) = [v]+  fv (Apply           e1 e2) = fv e1 ++ fv e2+  fv (Case         _ e alts) = fv e  ++ fv alts+  fv (Or              e1 e2) = fv e1 ++ fv e2+  fv (Exist           v _ e) = filter (/= v) (fv e)+  fv (Let (Binding v e1) e2) = fv e1 ++ filter (/= v) (fv e2)+  fv (Letrec          bds e) = filter (`notElem` vs) (fv es ++ fv e)+    where (vs, es) = unzip [(v, e') | Binding v e' <- bds]+  fv (Typed             e _) = fv e+  fv _                       = []++instance Expr Alt where+  fv (Alt (ConstructorPattern _ _ vs) e) = filter (`notElem` map snd vs) (fv e)+  fv (Alt (VariablePattern       _ v) e) = filter (v /=) (fv e)+  fv (Alt _                           e) = fv e
− src/IL/Type.lhs 
@@ -1,112 +0,0 @@-> {-# LANGUAGE DeriveDataTypeable #-}--% $Id: IL.lhs,v 1.18 2003/10/28 05:43:38 wlux Exp $-%-% Copyright (c) 1999-2003 Wolfgang Lux-% See LICENSE for the full license.-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-%-\nwfilename{IL.lhs}-\section{The intermediate language}-The module \texttt{IL} defines the intermediate language which will be-compiled into abstract machine code. The intermediate language removes-a lot of syntactic sugar from the Curry source language.  Top-level-declarations are restricted to data type and function definitions. A-newtype definition serves mainly as a hint to the backend that it must-provide an auxiliary function for partial applications of the-constructor. \textbf{Newtype constructors must not occur in patterns-and may be used in expressions only as partial applications.}--Type declarations use a de-Bruijn indexing scheme (starting at 0) for-type variables. In the type of a function, all type variables are-numbered in the order of their occurence from left to right, i.e., a-type \texttt{(Int -> b) -> (a,b) -> c -> (a,c)} is translated into the-type (using integer numbers to denote the type variables)-\texttt{(Int -> 0) -> (1,0) -> 2 -> (1,2)}.--Pattern matching in an equation is handled via flexible and rigid-\texttt{Case} expressions. Overlapping rules are translated with the-help of \texttt{Or} expressions. The intermediate language has three-kinds of binding expressions, \texttt{Exist} expressions introduce a-new logical variable, \texttt{Let} expression support a single-non-recursive variable binding, and \texttt{Letrec} expressions-introduce multiple variables with recursive initializer expressions.-The intermediate language explicitly distinguishes (local) variables-and (global) functions in expressions.--\em{Note:} this modified version uses haskell type \texttt{Integer}-instead of \texttt{Int} for representing integer values. This provides-an unlimited range of integer constants in Curry programs.-\begin{verbatim}--> module IL.Type where--> import Data.Generics-> import Curry.Base.Ident-> import Curry.Base.Position (SrcRef(..))--> data Module = Module ModuleIdent [ModuleIdent] [Decl] deriving (Eq,Show)--> data Decl = ->     DataDecl QualIdent Int [ConstrDecl [Type]]->   | NewtypeDecl QualIdent Int (ConstrDecl Type)->   | FunctionDecl QualIdent [Ident] Type Expression->   | ExternalDecl QualIdent CallConv String Type->   deriving (Eq,Show)--> data ConstrDecl a = ConstrDecl QualIdent a deriving (Eq,Show)-> data CallConv = Primitive | CCall deriving (Eq,Show)--> data Type =->     TypeConstructor QualIdent [Type]->   | TypeVariable Int->   | TypeArrow Type Type->   deriving (Eq,Show, Typeable, Data)--> data Literal = Char SrcRef Char | Int SrcRef Integer | Float SrcRef Double deriving (Eq,Show)--> data ConstrTerm =->   -- literal patterns->     LiteralPattern Literal->   -- constructors->   | ConstructorPattern QualIdent [Ident]->   -- default->   | VariablePattern Ident->   deriving (Eq,Show)--> data Expression =->   -- literal constants->     Literal Literal->   -- variables, functions, constructors->   | Variable Ident | Function QualIdent Int | Constructor QualIdent Int->   -- applications->   | Apply Expression Expression->   -- case expressions->   | Case SrcRef Eval Expression [Alt]->   -- non-determinisismic or->   | Or Expression Expression->   -- binding forms->   | Exist Ident Expression->   | Let Binding Expression->   | Letrec [Binding] Expression->   deriving (Eq,Show)--> data Eval = Rigid | Flex deriving (Eq,Show)-> data Alt = Alt ConstrTerm Expression deriving (Eq,Show)-> data Binding = Binding Ident Expression deriving (Eq,Show)--\end{verbatim}--> instance SrcRefOf ConstrTerm where->   srcRefOf (LiteralPattern l) = srcRefOf l->   srcRefOf (ConstructorPattern i _) = srcRefOf i->   srcRefOf (VariablePattern i) = srcRefOf i---> instance SrcRefOf Literal where->   srcRefOf (Char s _)   = s->   srcRefOf (Int s _)    = s->   srcRefOf (Float s _)  = s  --
+ src/IL/Typing.hs view
@@ -0,0 +1,44 @@+{- |+    Module      :  $Header$+    Description :  TODO+    Copyright   :  (c)        2017 Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++   TODO+-}++module IL.Typing (Typeable(..)) where++import Base.Messages (internalError)++import IL.Type++class Typeable a where+  typeOf :: a -> Type++instance Typeable ConstrTerm where+  typeOf (LiteralPattern ty _) = ty+  typeOf (ConstructorPattern ty _ _) = ty+  typeOf (VariablePattern ty _) = ty++instance Typeable Expression where+  typeOf (Literal ty _) = ty+  typeOf (Variable ty _) = ty+  typeOf (Function ty _ _) = ty+  typeOf (Constructor ty _ _) = ty+  typeOf (Apply e _) = case typeOf e of+    TypeArrow _ ty -> ty+    _ -> internalError "IL.Typing.typeOf: application"+  typeOf (Case _ _ as) = typeOf $ head as+  typeOf (Or e _) = typeOf e+  typeOf (Exist _ _ e) = typeOf e+  typeOf (Let _ e) = typeOf e+  typeOf (Letrec _ e) = typeOf e+  typeOf (Typed e _) = typeOf e++instance Typeable Alt where+  typeOf (Alt _ e) = typeOf e
− src/IL/XML.lhs 
@@ -1,518 +0,0 @@--% $Id: ILxml.lhs,v 1.0 2001/06/19 12:19:18 rafa Exp $-%-% $Log: ILxml.lhs,v $-%-% Revision 1.1  2001/06/19 12:19:18  rafa-% Pretty printer in XML for the intermediate language added.-%-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-%-\nwfilename{ILxml.lhs}-\section{A pretty printer in XML for the intermediate language}-This module implements just another pretty printer, this time in XML and for-the intermediate language. It was mainly adapted from the Curry pretty-printer (see sect.~\ref{sec:CurryPP}), which in turn is based on Simon-Marlow's pretty printer for Haskell. The format of the output intends to be-similar to that of Flat-Curry XML representation.-\begin{verbatim}--> module IL.XML(module IL.XML) where--> import Text.PrettyPrint.HughesPJ-> import Data.Maybe--> import Curry.Base.Ident-> import qualified Curry.Syntax as CS--> import IL.Type-> import CurryEnv----> -- identation level-> level::Int-> level = 3--> xmlModule :: CurryEnv -> Module -> Doc-> xmlModule cEnv m = text "<prog>" $$ nest level (xmlBody cEnv m) ->	                           $$ text "</prog>"--> xmlBody :: CurryEnv -> Module -> Doc-> xmlBody cEnv (Module name imports decls) =->                   xmlElement "module"      xmlModuleDecl      moduleDecl   $$->                   xmlElement "import"      xmlImportDecl      importDecl   $$->                   xmlElement "types"       xmlTypeDecl        typeDecl     $$->                   xmlElement "functions"   xmlFunctionDecl    functionDecl $$->                   xmlElement "operators"   xmlOperatorDecl    operatorDecl $$->                   xmlElement "translation" xmlTranslationDecl translationDecl->               where->                 moduleDecl      = [name]->                 importDecl      = imports->                 operatorDecl    = infixDecls cEnv->                 translationDecl = foldl (qualIDeclId (moduleId cEnv))->			                  [] ->				          (interface cEnv)->                 (functionDecl,typeDecl) = splitDecls decls--> -- =========================================================================--> xmlModuleDecl :: ModuleIdent -> Doc-> xmlModuleDecl name = xmlModuleIdent name--> -- =========================================================================--> xmlImportDecl :: ModuleIdent -> Doc-> xmlImportDecl name = xmlElement "module" xmlModuleDecl  [name]---> -- =========================================================================-> --            T Y P E S-> -- =========================================================================--> xmlTypeDecl :: Decl -> Doc-> xmlTypeDecl (DataDecl tc arity cs) =->   beginType                                  $$->   nest level (xmlTypeParams arity)           $$->   xmlLines xmlConstructor cs                 $$->   endType->  where->   beginType = text "<type name=\"" <> (xmlQualIdent tc) <> text "\">"->   endType   = text "</type>"--> xmlTypeParams :: Int -> Doc-> xmlTypeParams n = xmlElement "params" xmlTypeVar [0..(n-1)]--> xmlConstructor :: ConstrDecl [Type] -> Doc-> xmlConstructor (ConstrDecl ident []) = xmlConstructorBegin ident 0-> xmlConstructor (ConstrDecl ident l)  =->   xmlConstructorBegin ident (length l) $$->   xmlLines xmlType l $$->   xmlConstructorEnd->  where->   xmlConstructorEnd = text "</cons>"--> xmlConstructorBegin :: QualIdent -> Int -> Doc-> xmlConstructorBegin ident n = xmlHeadingWithArity "cons" ident n (n==0)--> xmlHeadingWithArity :: String -> QualIdent -> Int -> Bool -> Doc-> xmlHeadingWithArity tagName ident n single =->   if single->   then prefix<>text "/>"->   else prefix<> text ">"->   where->     prefix = text ("<"++tagName++" name=\"") <> name <> text "\" " <> arity->     arity  = text "arity=\"" <> xmlInt n <> text "\""->     name   = xmlQualIdent ident---> xmlType :: Type -> Doc-> xmlType (TypeConstructor ident []) = xmlTypeConsBegin ident True-> xmlType (TypeConstructor ident l)  = xmlTypeConsBegin ident False $$->                                      xmlLines xmlType l           $$->                                      xmlTypeConsEnd->                                      where->                                        xmlTypeConsEnd = text "</tcons>"--> xmlType (TypeVariable n) = xmlTypeVar n-> xmlType (TypeArrow  a b) = xmlTypeFun a b--> xmlTypeConsBegin :: QualIdent -> Bool -> Doc-> xmlTypeConsBegin ident single =->   if single->   then prefix <> text "/>"->   else prefix <> text ">"->   where->     name   = xmlQualIdent ident->     prefix = text "<tcons name=\"" <> name <> text "\""--> xmlTypeVar :: Int -> Doc-> xmlTypeVar n = text "<tvar>"<> xmlInt n <> text "</tvar>"--> xmlTypeFun :: Type -> Type -> Doc-> xmlTypeFun a b =  xmlElement "functype" xmlType  [a,b]---> -- =========================================================================-> --            F U N C T I O N S-> -- =========================================================================--> xmlFunctionDecl :: Decl -> Doc-> xmlFunctionDecl (NewtypeDecl tc arity (ConstrDecl ident ty)) =->   xmlFunctionDecl (FunctionDecl ident [arg] ftype (Variable arg))->   where->    arg = mkIdent "_1"->    ftype = TypeArrow ty (TypeConstructor tc (map TypeVariable [0..arity-1]))--> xmlFunctionDecl (FunctionDecl ident largs fType expr) =->    heading $$ nest level (xmlRule largs expr) $$ end->  where->    heading = xmlBeginFunction ident (length largs) fType->    end     = text "</func>"--> xmlFunctionDecl (ExternalDecl ident callConv internalName fType) =->    heading $$ external $$ end->  where->    heading  = xmlBeginFunction ident (xmlFunctionArity fType) fType->    external = text ("<external>"->                     ++ xmlFormat internalName->                     ++ "</external>")->    end      = text "</func>"--> xmlBeginFunction :: QualIdent -> Int -> Type -> Doc-> xmlBeginFunction ident n fType =->    heading $$ typeDecls->    where->      heading   = xmlHeadingWithArity "func" ident n False->      typeDecls = nest level (xmlType fType)--> xmlEndFunction ::  Doc-> xmlEndFunction  = text "</func>"--> xmlFunctionArity :: Type -> Int-> xmlFunctionArity (TypeConstructor ident l) = 0-> xmlFunctionArity (TypeVariable n)          = 0-> xmlFunctionArity (TypeArrow  a b)          = 1 + (xmlFunctionArity b)--> xmlRule :: [Ident] -> Expression -> Doc-> xmlRule lArgs e = text "<rule>"               $$->                   nest level (xmlLhs lArgs)   $$->                   nest level (xmlRhs lArgs e) $$->                   text "</rule>"--> xmlLhs :: [Ident] -> Doc-> xmlLhs l  = xmlElement "lhs" xmlVar [0..((length l)-1)]--> xmlRhs :: [Ident] -> Expression -> Doc-> xmlRhs l e = text "<rhs>"  $$ nest level rhs $$ text "</rhs>"->              where->                varDicc    = xmlBuildDicc l->                (rhs, _) = xmlExpr varDicc e--> -- =========================================================================--> -- =========================================================================-> --            E X P R E S S I O N S-> -- =========================================================================--> xmlExpr :: [(Int,Ident)] -> Expression -> (Doc,[(Int,Ident)])-> xmlExpr d (Literal lit)  = (xmlLiteral (xmlLit lit),d)-> xmlExpr d (Variable ident)  = xmlExprVar d ident-> xmlExpr d (Function ident arity)    = (xmlSingleApp ident arity True,d)-> xmlExpr d (Constructor ident arity) = (xmlSingleApp ident arity False,d)-> xmlExpr d exp@(Apply e1 e2)         = xmlApply  d exp (xmlAppArgs exp)-> xmlExpr d (Case _ eval expr alt)      = xmlCase   d eval expr alt-> xmlExpr d (Or expr1 expr2)          = xmlOr     d expr1 expr2-> xmlExpr d (Exist ident expr)        = xmlFree   d ident expr-> xmlExpr d (Let binding expr)        = xmlLet    d binding expr-> xmlExpr d (Letrec lBinding expr)    = xmlLetrec d lBinding expr->   --error "Recursive let bindings not supported in FlatCurry"--> -- =========================================================================--> xmlSingleApp :: QualIdent -> Int -> Bool -> Doc-> xmlSingleApp ident arity isFunction =->    if arity>0->    then xmlCombHeading identDoc (text "PartCall") True->    else xmlCombHeading identDoc (text totalApp) True->    where->       identDoc = xmlQualIdent ident->       totalApp = if isFunction then "FuncCall" else "ConsCall"---> xmlCombHeading :: Doc -> Doc -> Bool -> Doc-> xmlCombHeading name cType single =->     if single->     then prefix <> text " />"->     else prefix <> text ">"->     where->       prefix = text "<comb type=\""<>cType<>text "\" name=\""<>name<>text "\""--> -- =========================================================================--> xmlExprVar :: [(Int,Ident)] -> Ident -> (Doc,[(Int,Ident)])-> xmlExprVar d ident =->    if isNew->    then (xmlVar newVar, (newVar,ident):d)->    else (xmlVar var, d)->    where->       var    = xmlLookUp ident d->       isNew  = var == -1->       newVar = xmlNewVar d--> -- =========================================================================---> xmlApply :: [(Int,Ident)] -> Expression -> (Expression,[Expression]) ->->              (Doc,[(Int,Ident)])--> xmlApply d exp ((Function ident arity),lExp) =->   xmlApplyFunctor d ident arity lExp True--> xmlApply d exp ((Constructor ident arity),lExp) =->   xmlApplyFunctor d ident arity lExp False--> xmlApply d (Apply expr1 expr2) e' =->   (text "<apply>" $$ nest level e1 $$ nest level e2 $$ text "</apply>", d2)->     where->        (e1,d1) = xmlExpr d  expr1->        (e2,d2) = xmlExpr d1 expr2--> xmlApplyFunctor ::[(Int,Ident)] -> QualIdent -> Int -> [Expression] ->->                     Bool -> (Doc,[(Int,Ident)])-> xmlApplyFunctor d ident arity lArgs isFunction =->    xmlCombApply d (xmlQualIdent ident)  (text cTypeS) n lArgs->    where->       n     = length (lArgs)->       cTypeS = if n==arity->               then if isFunction->                    then "FuncCall"->                    else "ConsCall"->               else "PartCall"---> xmlCombApply :: [(Int,Ident)] -> Doc -> Doc -> Int ->->                                 [Expression] -> (Doc,[(Int,Ident)])-> xmlCombApply d name cType 0 lArgs =->    (xmlCombHeading name cType True,d)-> xmlCombApply d name cType n lArgs =->    (xmlCombHeading name cType False $$ xmlLines id lDocs$$ text "</comb>", d1)->    where->      (lDocs,d1) = xmlMapDicc d xmlExpr lArgs---> xmlAppArgs :: Expression -> (Expression,[Expression])-> xmlAppArgs (Apply e1 e2) = (e,lArgs++[e2])->                            where->                                (e,lArgs) = (xmlAppArgs e1)-> xmlAppArgs e             = (e,[])-> -- =========================================================================---> -- =========================================================================--> xmlCase :: [(Int,Ident)] -> Eval -> Expression -> [Alt] -> (Doc,[(Int,Ident)])-> xmlCase d eval expr lAlt =->   (heading $$ nest level e1 $$ xmlLines id lDocs$$ end,d2)->   where->     sEval      = if eval==Rigid then "\"Rigid\"" else "\"Flex\""->     heading    = text "<case type=" <> text sEval <> text ">"->     end        = text "</case>"->     (e1,_)    = xmlExpr d expr->     (lDocs,d2) = xmlMapDicc d xmlBranch  lAlt--> xmlOr :: [(Int,Ident)] -> Expression -> Expression -> (Doc,[(Int,Ident)])-> xmlOr d  expr1 expr2 =->    (text "<or>" $$ nest level e1 $$ nest level e2 $$  text "</or>",d2)->    where->      (e1,d1) = xmlExpr d expr1->      (e2,d2) = xmlExpr d1 expr2---> xmlBranch :: [(Int,Ident)] -> Alt -> (Doc,[(Int,Ident)])-> xmlBranch d (Alt pattern expr) =->    (text "<branch>" $$ nest level e1 $$ nest level e2 $$ text "</branch>",d2)->    where->      (e1,d1) = xmlPattern d pattern->      (e2,d2) = xmlExpr d1 expr---> xmlPattern :: [(Int,Ident)] -> ConstrTerm -> (Doc,[(Int,Ident)])-> xmlPattern d (LiteralPattern lit) = (xmlLitPattern (xmlLit lit),d)-> xmlPattern d (ConstructorPattern ident lArgs) = xmlConsPattern d ident  lArgs-> xmlPattern d (VariablePattern _) = error "Variable patterns not allowed in Flat Curry"--> xmlConsPattern :: [(Int,Ident)] -> QualIdent -> [Ident] -> (Doc,[(Int,Ident)])-> xmlConsPattern d ident lArgs =->    (heading $$ xmlLines id lDocs $$ end,d2)->    where->      heading    = text "<pattern name=\""<> (xmlQualIdent ident) <>->                   text "\"" <> endh->      endh       = if (length lArgs)>0 then text ">" else text "/>"->      end        = if (length lArgs)>0 then text "</pattern>" else empty->      (lDocs,d2) = xmlMapDicc d xmlExprVar lArgs--> -- =========================================================================---> xmlFree :: [(Int,Ident)] -> Ident -> Expression -> (Doc,[(Int,Ident)])-> xmlFree d ident exp =->  (text "<freevars>" $$ nest level v $$ nest level e $$ text "</freevars>",d2)->                    where->                       (v,d1) = xmlExprVar d  ident->                       (e,d2) = xmlExpr d1 exp---> -- =========================================================================--> xmlLet :: [(Int,Ident)] -> Binding -> Expression -> (Doc,[(Int,Ident)])-> xmlLet d binding exp =->   (text "<let>" $$ nest level b $$ nest level e $$ text "</let>", d2)->   where->    (b,d1) = xmlBinding d binding->    (e,d2) = xmlExpr d1 exp--> xmlBinding :: [(Int,Ident)] -> Binding -> (Doc,[(Int,Ident)])-> xmlBinding d  (Binding ident exp) =->    (text "<binding>" $$ nest level v $$ nest level e $$ text "</binding>",d2)->    where->       (v,_)  = xmlExprVar d ident->       (e,d2) = xmlExpr d exp--> -- =========================================================================--> xmlLetrec :: [(Int,Ident)] -> [Binding] -> Expression -> (Doc,[(Int,Ident)])-> xmlLetrec d lB exp =->   (text "<letrec>" $$ xmlLines id b $$ nest level e $$ text "</letrec>",d2)->   where->     (b,d1) = xmlMapDicc d xmlBinding lB->     (e,d2) = xmlExpr d1 exp--> -- =========================================================================---> -- =========================================================================-> --            A U X I L I A R Y  F U N C T I O N S-> -- =========================================================================--> splitDecls :: [Decl] -> ([Decl],[Decl])-> splitDecls []     = ([],[])-> splitDecls (x:xs) = case x of->                      DataDecl     _ _ _   -> (functionDecl,x:typeDecl)->                      NewtypeDecl  _ _ _   -> (x:functionDecl,typeDecl)->                      FunctionDecl _ _ _ _ -> (x:functionDecl,typeDecl)->                      ExternalDecl _ _ _ _   -> (x:functionDecl,typeDecl)->                   where->                       (functionDecl,typeDecl) = splitDecls xs-----> xmlElement :: Eq a => String -> (a -> Doc) -> [a] -> Doc-> xmlElement name f []     = text ("<"++name++" />")-> xmlElement name f lDecls = beginElement $$ xmlLines f lDecls $$ endElement->                            where->                                beginElement = text ("<"++name++">")->                                endElement   = text ("</"++name++">")->--> xmlLines :: (a -> Doc) -> [a] -> Doc-> xmlLines f = (nest level).vcat.(map f)---> xmlMapDicc::[(Int,Ident)] -> ([(Int,Ident)] -> a -> (Doc,[(Int,Ident)])) ->->              [a] -> ([Doc],[(Int,Ident)])-> xmlMapDicc d f lArgs = foldl newArg ([],d) lArgs->                             where->                               newArg (l,d)  e = (l++[v'],d')->                                                 where (v',d') = f d e->---> -- The dictionary identifies var names with integers-> -- it will be ordered starting at the greatest integer-> xmlBuildDicc :: [Ident] -> [(Int,Ident)]-> xmlBuildDicc l = reverse (zip [0..((length l)-1)] l)--> -- looks for a ident in the dictorionary. If it appears returns its-> -- associated value. Otherwise, -1 is returned-> xmlLookUp :: Ident -> [(Int,Ident)] -> Int-> xmlLookUp ident []          = -1-> xmlLookUp ident ((n,name):xs) = if ident==name->                                 then n->                                 else xmlLookUp ident xs--> -- generates a integer corresponding to a new var-> xmlNewVar :: [(Int,Ident)] -> Int-> xmlNewVar []             = 0-> xmlNewVar ((n,ident):xs) = n+1--> xmlVar :: Int -> Doc-> xmlVar n = text "<var>" <> xmlInt n <> text "</var>"--> xmlLiteral :: Doc -> Doc-> xmlLiteral d =   text "<lit>" $$ nest level d $$ text "</lit>"--> xmlLitPattern :: Doc -> Doc-> xmlLitPattern d =   text "<lpattern>" $$ nest level d $$ text "</lpattern>"---> xmlLit :: Literal -> Doc-> xmlLit (Char _ c) = text "<charc>" <>  xmlInt (fromEnum c) <> text "</charc>"-> xmlLit (Int _ n) = text "<intc>" <>  xmlInteger n <> text "</intc>"-> xmlLit (Float _ n) = text "<floatc>" <>  xmlFloat n <> text "</floatc>"--> xmlOperatorDecl :: CS.IDecl -> Doc-> xmlOperatorDecl (CS.IInfixDecl _ fixity prec qident) =->     text "<op fixity=\"" <> xmlFixity fixity ->     <> text "\" prec=\"" <> xmlInteger prec <> text "\">"->     <> xmlIdent (unqualify qident)->     <> text "</op>"--> xmlFixity :: CS.Infix -> Doc-> xmlFixity CS.InfixL = text "InfixlOp"-> xmlFixity CS.InfixR = text "InfixrOp"-> xmlFixity CS.Infix  = text "InfixOp"---> xmlTranslationDecl :: QualIdent -> Doc-> xmlTranslationDecl expId =->       text "<trans>" ->    $$ nest level (   text "<name>"    <> xmlIdent (unqualify expId) <> text "</name>"->                   $$ text "<intname>" <> xmlQualIdent expId         <> text "</intname>")->    $$ text "</trans>"---> xmlIdent :: Ident -> Doc-> xmlIdent ident = text (xmlFormat (name ident))--> xmlInt :: Int -> Doc-> xmlInt n = text (show n)--> xmlInteger :: Integer -> Doc-> xmlInteger n = text (show n)--> xmlFloat :: Double -> Doc-> xmlFloat n = text (show n)--> xmlQualIdent :: QualIdent -> Doc-> xmlQualIdent ident = text (xmlFormat (qualName ident))--> xmlModuleIdent:: ModuleIdent -> Doc-> xmlModuleIdent name = text (xmlFormat (moduleName name))--> xmlFormat :: String -> String-> xmlFormat []       = []-> xmlFormat ('>':xs) = "&gt;"++xmlFormat xs-> xmlFormat ('<':xs) = "&lt;"++xmlFormat xs-> xmlFormat ('&':xs) = "&amp;"++xmlFormat xs-> xmlFormat (x:xs)   = x:(xmlFormat xs)--> -- =========================================================================--> qualIDeclId :: ModuleIdent -> [QualIdent] -> CS.IDecl -> [QualIdent]-> qualIDeclId mid qids (CS.IDataDecl _ qid _ mcdecls)->    = foldl (qualConstrDeclId mid) (qid:qids) (catMaybes mcdecls)-> qualIDeclId mid qids (CS.INewtypeDecl _ qid _ ncdecl)->    = qualNewConstrDeclId mid (qid:qids) ncdecl-> qualIDeclId mid qids (CS.ITypeDecl _ qid _ _)->    = qid:qids-> qualIDeclId mid qids (CS.IFunctionDecl _ qid _ _)->    = qid:qids-> qualIDeclId mid qids _ = qids--> qualConstrDeclId :: ModuleIdent -> [QualIdent] -> CS.ConstrDecl ->	              -> [QualIdent]-> qualConstrDeclId mid qids (CS.ConstrDecl _ _ id _)->    = (qualifyWith mid id):qids-> qualConstrDeclId mid qids (CS.ConOpDecl _ _ _ id _)->    = (qualifyWith mid id):qids--> qualNewConstrDeclId :: ModuleIdent -> [QualIdent] -> CS.NewConstrDecl ->	                 -> [QualIdent]-> qualNewConstrDeclId mid qids (CS.NewConstrDecl _ _ id _)->    = (qualifyWith mid id):qids---\end{verbatim}
+ src/Imports.hs view
@@ -0,0 +1,402 @@+{- |+    Module      :  $Header$+    Description :  Importing interface declarations+    Copyright   :  (c) 2000 - 2003 Wolfgang Lux+                       2011        Björn Peemöller+                       2016        Jan Tikovsky+                       2016        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module provides the function 'importModules' to bring the imported+    entities into the module's scope, and the function 'qualifyEnv' to+    qualify the environment prior to computing the export interface.+-}+module Imports (importInterfaces, importModules, qualifyEnv) where++import           Data.List                  (nubBy, find)+import qualified Data.Map            as Map+import           Data.Maybe                 (catMaybes, fromMaybe, isJust)+import qualified Data.Set            as Set++import Curry.Base.Ident+import Curry.Base.SpanInfo+import Curry.Base.Monad+import Curry.Syntax++import Base.CurryKinds (toKind')+import Base.CurryTypes ( toQualType, toQualTypes, toQualPredType, toConstrType+                       , toMethodType )++import Base.Kinds+import Base.Messages+import Base.TopEnv+import Base.Types+import Base.TypeSubst++import Env.Class+import Env.Instance+import Env.Interface+import Env.ModuleAlias (importAliases, initAliasEnv)+import Env.OpPrec+import Env.TypeConstructor+import Env.Value++import CompilerEnv++importModules :: Monad m => Module a -> InterfaceEnv -> [ImportDecl]+              -> CYT m CompilerEnv+importModules mdl@(Module _ _ _ mid _ _ _) iEnv expImps+  = ok $ foldl importModule initEnv expImps+  where+    initEnv = (initCompilerEnv mid)+      { aliasEnv     = importAliases expImps -- import module aliases+      , interfaceEnv = iEnv                  -- imported interfaces+      , extensions   = knownExtensions mdl+      }+    importModule env (ImportDecl _ m q asM is) =+      case Map.lookup m iEnv of+        Just intf -> importInterface (fromMaybe m asM) q is intf env+        Nothing   -> internalError $ "Imports.importModules: no interface for "+                                     ++ show m++-- |The function 'importInterfaces' brings the declarations of all+-- imported interfaces into scope for the current 'Interface'.+importInterfaces :: Interface -> InterfaceEnv -> CompilerEnv+importInterfaces (Interface m is _) iEnv+  = importUnifyData $ foldl importModule initEnv is+  where+    initEnv = (initCompilerEnv m) { aliasEnv = initAliasEnv, interfaceEnv = iEnv }+    importModule env (IImportDecl _ i) = case Map.lookup i iEnv of+      Just intf -> importInterfaceIntf intf env+      Nothing   -> internalError $ "Imports.importInterfaces: no interface for "+                                   ++ show m++-- ---------------------------------------------------------------------------+-- Importing an interface into the module+-- ---------------------------------------------------------------------------++-- Four kinds of environments are computed from the interface:+--+-- 1. The operator precedences+-- 2. The type constructors+-- 3. The types of the data constructors and functions (values)+-- 4. The instances+--+-- Note that the original names of all entities defined in the imported module+-- are qualified appropriately. The same is true for type expressions.++-- When an interface is imported, the compiler first transforms the+-- interface into these environments. If an import specification is+-- present, the environments are restricted to only those entities which+-- are included in the specification or not hidden by it, respectively.+-- The resulting environments are then imported into the current module+-- using either a qualified import (if the module is imported qualified)+-- or both a qualified and an unqualified import (non-qualified import).+-- Regardless of the type of import, all instance declarations are always+-- imported into the current module.++importInterface :: ModuleIdent -> Bool -> Maybe ImportSpec -> Interface+                -> CompilerEnv -> CompilerEnv+importInterface m q is (Interface mid _ ds) env = env'+  where+  env' = env+    { opPrecEnv = importEntities (precs  mid) m q vs id              ds $ opPrecEnv env+    , tyConsEnv = importEntities (types  mid) m q ts (importData vs) ds $ tyConsEnv env+    , valueEnv  = importEntities (values mid) m q vs id              ds $ valueEnv  env+    , classEnv  = importClasses   mid                                ds $ classEnv  env+    , instEnv   = importInstances mid                                ds $ instEnv   env+    }+  ts = isVisible addType  is+  vs = isVisible addValue is++addType :: Import -> [Ident] -> [Ident]+addType (Import            _ _) tcs = tcs+addType (ImportTypeWith _ tc _) tcs = tc : tcs+addType (ImportTypeAll     _ _) _   = internalError "Imports.addType"++addValue :: Import -> [Ident] -> [Ident]+addValue (Import            _ f) fs = f : fs+addValue (ImportTypeWith _ _ cs) fs = cs ++ fs+addValue (ImportTypeAll     _ _) _  = internalError "Imports.addValue"++isVisible :: (Import -> [Ident] -> [Ident]) -> Maybe ImportSpec+          -> Ident -> Bool+isVisible _   Nothing                 = const True+isVisible add (Just (Importing _ xs)) = (`Set.member`    Set.fromList (foldr add [] xs))+isVisible add (Just (Hiding    _ xs)) = (`Set.notMember` Set.fromList (foldr add [] xs))++importEntities :: Entity a => (IDecl -> [a]) -> ModuleIdent -> Bool+               -> (Ident -> Bool) -> (a -> a) -> [IDecl] -> TopEnv a -> TopEnv a+importEntities ents m q isVisible' f ds env =+  foldr (uncurry (if q then qualImportTopEnv m else importUnqual m)) env+        [ (x, f y) | y <- concatMap ents ds+        , let x = unqualify (origName y), isVisible' x+        ]+  where importUnqual m' x y = importTopEnv m' x y . qualImportTopEnv m' x y++importData :: (Ident -> Bool) -> TypeInfo -> TypeInfo+importData isVisible' (DataType tc k cs) =+  DataType tc k $ catMaybes $ map (importConstr isVisible') cs+importData isVisible' (RenamingType tc k nc) =+  maybe (DataType tc k []) (RenamingType tc k) (importConstr isVisible' nc)+importData _ (AliasType tc k n ty) = AliasType tc k n ty+importData isVisible' (TypeClass qcls k ms) =+  TypeClass qcls k $ catMaybes $ map (importMethod isVisible') ms+importData _ (TypeVar _) = internalError "Imports.importData: type variable"++importConstr :: (Ident -> Bool) -> DataConstr -> Maybe DataConstr+importConstr isVisible' dc+  | isVisible' (constrIdent dc) = Just dc+  | otherwise                   = Nothing++importMethod :: (Ident -> Bool) -> ClassMethod -> Maybe ClassMethod+importMethod isVisible' mthd+  | isVisible' (methodName mthd) = Just mthd+  | otherwise                    = Nothing++importClasses :: ModuleIdent -> [IDecl] -> ClassEnv -> ClassEnv+importClasses m = flip $ foldr (bindClass m)++bindClass :: ModuleIdent -> IDecl -> ClassEnv -> ClassEnv+bindClass m (HidingClassDecl p cx cls k tv) =+  bindClass m (IClassDecl p cx cls k tv [] [])+bindClass m (IClassDecl _ cx cls _ _ ds ids) =+  bindClassInfo (qualQualify m cls) (sclss, ms)+  where sclss = map (\(Constraint _ scls _) -> qualQualify m scls) cx+        ms = map (\d -> (imethod d, isJust $ imethodArity d)) $ filter isVis ds+        isVis (IMethodDecl _ idt _ _ ) = idt `notElem` ids+bindClass _ _ = id++importInstances :: ModuleIdent -> [IDecl] -> InstEnv -> InstEnv+importInstances m = flip $ foldr (bindInstance m)++bindInstance :: ModuleIdent -> IDecl -> InstEnv -> InstEnv+bindInstance m (IInstanceDecl _ cx qcls ty is mm) = bindInstInfo+  (qualQualify m qcls, qualifyTC m $ typeConstr ty) (fromMaybe m mm, ps, is)+  where PredType ps _ = toQualPredType m [] $ QualTypeExpr NoSpanInfo cx ty+bindInstance _ _ = id++-- ---------------------------------------------------------------------------+-- Building the initial environment+-- ---------------------------------------------------------------------------++-- In a first step, the four export environments are initialized from+-- the interface's declarations.++-- operator precedences+precs :: ModuleIdent -> IDecl -> [PrecInfo]+precs m (IInfixDecl _ fix prec op) = [PrecInfo (qualQualify m op) (OpPrec fix prec)]+precs _ _                          = []++hiddenTypes :: ModuleIdent -> IDecl -> [TypeInfo]+hiddenTypes m (HidingDataDecl     _ tc k tvs) = [typeCon DataType m tc k tvs []]+hiddenTypes m (HidingClassDecl  _ _ qcls k _) = [typeCls m qcls k []]+hiddenTypes m d                               = types m d++-- type constructors and type classes+types :: ModuleIdent -> IDecl -> [TypeInfo]+types m (IDataDecl _ tc k tvs cs _) =+  [typeCon DataType m tc k tvs (map mkData cs)]+  where+    mkData (ConstrDecl _ c tys) =+      DataConstr c (toQualTypes m tvs tys)+    mkData (ConOpDecl _  ty1 c ty2) =+      DataConstr c (toQualTypes m tvs [ty1, ty2])+    mkData (RecordDecl _ c fs) =+      RecordConstr c labels (toQualTypes m tvs tys)+      where (labels, tys) = unzip [(l, ty) | FieldDecl _ ls ty <- fs, l <- ls]+types m (INewtypeDecl _ tc k tvs nc _) =+  [typeCon RenamingType m tc k tvs (mkData nc)]+  where+    mkData (NewConstrDecl _ c ty) =+      DataConstr c [toQualType m tvs ty]+    mkData (NewRecordDecl _ c (l, ty)) =+      RecordConstr c [l] [toQualType m tvs ty]+types m (ITypeDecl _ tc k tvs ty) =+  [typeCon aliasType m tc k tvs (toQualType m tvs ty)]+  where+    aliasType tc' k' = AliasType tc' k' (length tvs)+types m (IClassDecl _ _ qcls k tv ds ids) =+  [typeCls m qcls k (map mkMethod $ filter isVis ds)]+  where+    isVis (IMethodDecl _ f _ _ ) = f `notElem` ids+    mkMethod (IMethodDecl _ f a qty) = ClassMethod f a $+      qualifyPredType m $ normalize 1 $ toMethodType qcls tv qty+types _ _ = []++-- type constructors+typeCon :: (QualIdent -> Kind -> a) -> ModuleIdent -> QualIdent+        -> Maybe KindExpr -> [Ident] -> a+typeCon f m tc k tvs = f (qualQualify m tc) (toKind' k (length tvs))++-- type classes+typeCls :: ModuleIdent -> QualIdent -> Maybe KindExpr -> [ClassMethod]+        -> TypeInfo+typeCls m qcls k ms = TypeClass (qualQualify m qcls) (toKind' k 0) ms++-- data constructors, record labels, functions and class methods+values :: ModuleIdent -> IDecl -> [ValueInfo]+values m (IDataDecl _ tc _ tvs cs hs) =+  map (dataConstr m tc' tvs)+      (filter ((\con -> con `notElem` hs || isHiddenButNeeded con)+              . constrId) cs) +++  map (recLabel m tc' tvs ty') (nubBy sameLabel clabels)+  where tc' = qualQualify m tc+        ty' = constrType tc' tvs+        labels   = [ (l, lty) | RecordDecl _ _ fs <- cs+                   , FieldDecl _ ls lty <- fs, l <- ls, l `notElem` hs+                   ]+        clabels  = [(l, constr l, ty) | (l, ty) <- labels]+        constr l = [constrId c | c <- cs, l `elem` recordLabels c]+        -- hidden constructors needed for record updates with visible labels+        hiddenCs = [c | (l, _) <- labels, c <- constr l, c `elem` hs]+        isHiddenButNeeded = flip elem hiddenCs+        sameLabel (l1,_,_) (l2,_,_) = l1 == l2+values m (INewtypeDecl _ tc _ tvs nc hs) =+  map (newConstr m tc' tvs) [nc | nconstrId nc `notElem` hs] +++  case nc of+    NewConstrDecl _ _ _        -> []+    NewRecordDecl _ c (l, lty) ->+      [recLabel m tc' tvs ty' (l, [c], lty) | l `notElem` hs]+  where tc' = qualQualify m tc+        ty' = constrType tc' tvs+values m (IFunctionDecl _ f Nothing a qty) =+  [Value (qualQualify m f) Nothing a (typeScheme (toQualPredType m [] qty))]+values m (IFunctionDecl _ f (Just tv) _ qty) =+  let mcls = case qty of+        QualTypeExpr _ ctx _ -> fmap (\(Constraint _ qcls _) -> qcls) $+                                find (\(Constraint _ _ ty) -> isVar ty) ctx+  in [Value (qualQualify m f) mcls 0 (typeScheme (toQualPredType m [tv] qty))]+  where+    isVar (VariableType _ i) = i == tv+    isVar _                  = False+values m (IClassDecl _ _ qcls _ tv ds hs) =+  map (classMethod m qcls' tv hs) ds+  where qcls' = qualQualify m qcls+values _ _                        = []++dataConstr :: ModuleIdent -> QualIdent -> [Ident] -> ConstrDecl -> ValueInfo+dataConstr m tc tvs (ConstrDecl _ c tys) =+  DataConstructor (qualifyLike tc c) a labels $+    constrType' m tc tvs tys+  where a      = length tys+        labels = replicate a anonId+dataConstr m tc tvs (ConOpDecl _ ty1 op ty2) =+  DataConstructor (qualifyLike tc op) 2 [anonId, anonId] $+    constrType' m tc tvs [ty1, ty2]+dataConstr m tc tvs (RecordDecl _ c fs) =+  DataConstructor (qualifyLike tc c) a labels $+    constrType' m tc tvs tys+  where fields        = [(l, ty) | FieldDecl _ ls ty <- fs, l <- ls]+        (labels, tys) = unzip fields+        a             = length labels++newConstr :: ModuleIdent -> QualIdent -> [Ident] -> NewConstrDecl -> ValueInfo+newConstr m tc tvs (NewConstrDecl _ c ty1) =+  NewtypeConstructor (qualifyLike tc c) anonId $+  constrType' m tc tvs [ty1]+newConstr m tc tvs (NewRecordDecl _ c (l, ty1)) =+  NewtypeConstructor (qualifyLike tc c) l $+  constrType' m tc tvs [ty1]++recLabel :: ModuleIdent -> QualIdent -> [Ident] -> TypeExpr+           -> (Ident, [Ident], TypeExpr) -> ValueInfo+recLabel m tc tvs ty0 (l, cs, lty) = Label ql qcs tySc+  where ql   = qualifyLike tc l+        qcs  = map (qualifyLike tc) cs+        tySc = polyType (toQualType m tvs (ArrowType NoSpanInfo ty0 lty))++constrType' :: ModuleIdent -> QualIdent -> [Ident] -> [TypeExpr] -> TypeScheme+constrType' m tc tvs tys = ForAll (length tvs) pty+  where pty  = qualifyPredType m $ toConstrType tc tvs tys++constrType :: QualIdent -> [Ident] -> TypeExpr+constrType tc tvs = foldl (ApplyType NoSpanInfo) (ConstructorType NoSpanInfo tc)+                      $ map (VariableType NoSpanInfo) tvs++-- We always enter class methods with an arity of 0 into the value environment+-- because there may be different implementations with different arities.++classMethod :: ModuleIdent -> QualIdent -> Ident -> [Ident] -> IMethodDecl+            -> ValueInfo+classMethod m qcls tv hs (IMethodDecl _ f _ qty) =+  Value (qualifyLike qcls f) mcls 0 $+    typeScheme $ qualifyPredType m $ toMethodType qcls tv qty+  where+    mcls = if f `elem` hs then Nothing else Just qcls++-- ---------------------------------------------------------------------------++-- After all modules have been imported, the compiler has to ensure that+-- all references to a data type use the same list of constructors.++importUnifyData :: CompilerEnv -> CompilerEnv+importUnifyData cEnv = cEnv { tyConsEnv = importUnifyData' $ tyConsEnv cEnv }++importUnifyData' :: TCEnv -> TCEnv+importUnifyData' tcEnv = fmap (setInfo allTyCons) tcEnv+  where+  setInfo tcs t   = case Map.lookup (origName t) tcs of+                         Nothing -> error "Imports.importUnifyData'"+                         Just ty -> ty+  allTyCons       = foldr (mergeData . snd) Map.empty $ allImports tcEnv+  mergeData t tcs =+    Map.insert tc (maybe t (sureMerge t) $ Map.lookup tc tcs) tcs+    where tc = origName t+  sureMerge x y = case merge x y of+                       Nothing -> error "Imports.importUnifyData'.sureMerge"+                       Just z  -> z++-- ---------------------------------------------------------------------------++-- |+qualifyEnv :: CompilerEnv -> CompilerEnv+qualifyEnv env = qualifyLocal env+               $ foldl (flip importInterfaceIntf) initEnv+               $ Map.elems+               $ interfaceEnv env+  where initEnv = initCompilerEnv $ moduleIdent env++qualifyLocal :: CompilerEnv -> CompilerEnv -> CompilerEnv+qualifyLocal currentEnv initEnv = currentEnv+  { opPrecEnv = foldr bindQual   pEnv  $ localBindings $ opPrecEnv currentEnv+  , tyConsEnv = foldr bindQual   tcEnv $ localBindings $ tyConsEnv currentEnv+  , valueEnv  = foldr bindGlobal tyEnv $ localBindings $ valueEnv  currentEnv+  , classEnv  = Map.unionWith mergeClassInfo clsEnv $ classEnv currentEnv+  , instEnv   = Map.union                    iEnv   $ instEnv  currentEnv+  }+  where+    pEnv   = opPrecEnv initEnv+    tcEnv  = tyConsEnv initEnv+    tyEnv  = valueEnv  initEnv+    clsEnv = classEnv  initEnv+    iEnv   = instEnv   initEnv+    bindQual   (_, y) = qualBindTopEnv (origName y) y+    bindGlobal (x, y)+      | hasGlobalScope x = bindQual (x, y)+      | otherwise        = bindTopEnv x y++-- Importing an interface into another interface is somewhat simpler+-- because all entities are imported into the environment. In addition,+-- only a qualified import is necessary. Note that the hidden data types+-- are imported as well because they may be used in type expressions in+-- an interface.++importInterfaceIntf :: Interface -> CompilerEnv -> CompilerEnv+importInterfaceIntf (Interface m _ ds) env = env+  { opPrecEnv = importEntitiesIntf m (precs  m)       ds $ opPrecEnv env+  , tyConsEnv = importEntitiesIntf m (hiddenTypes  m) ds $ tyConsEnv env+  , valueEnv  = importEntitiesIntf m (values m)       ds $ valueEnv  env+  , classEnv  = importClasses      m                  ds $ classEnv  env+  , instEnv   = importInstances    m                  ds $ instEnv   env+  }++importEntitiesIntf :: Entity a => ModuleIdent -> (IDecl -> [a]) -> [IDecl]+                    -> TopEnv a -> TopEnv a+importEntitiesIntf m ents ds env = foldr importEntity env (concatMap ents ds)+  where importEntity x = qualImportTopEnv (fromMaybe m (qidModule (origName x)))+                                          (unqualify (origName x)) x
− src/Imports.lhs 
@@ -1,379 +0,0 @@--% $Id: Imports.lhs,v 1.25 2004/02/13 19:24:00 wlux Exp $-%-% Copyright (c) 2000-2003, Wolfgang Lux-% See LICENSE for the full license.-%-\nwfilename{Imports.lhs}-\section{Importing interfaces}-This module provides a few functions which can be used to import-interfaces into the current module.-\begin{verbatim}--> module Imports(importInterface,importInterfaceIntf,importUnifyData) where--> import Data.Maybe-> import qualified Data.Set as Set-> import qualified Data.Map as Map--> import Curry.Syntax-> import Types-> import Curry.Base.Position-> import Curry.Base.Ident-> import Base-> import TopEnv---\end{verbatim}-Four kinds of environments are computed from the interface, one-containing the operator precedences, another for the type-constructors, the third containing the types of the data-constructors and functions, and the last contains the arity for each-function and constructor. Note that the original names of all-entities defined in the imported module are qualified appropriately.-The same is true for type expressions.-\begin{verbatim}--> type ExpPEnv = Map.Map Ident PrecInfo-> type ExpTCEnv = Map.Map Ident TypeInfo-> type ExpValueEnv = Map.Map Ident ValueInfo-> type ExpArityEnv = Map.Map Ident ArityInfo--\end{verbatim}-When an interface is imported, the compiler first transforms the-interface into these environments. If an import specification is-present, the environments are restricted to only those entities which-are included in the specification or not hidden by it, respectively.-The resulting environments are then imported into the current module-using either a qualified import or both a qualified and an unqualified-import.-\begin{verbatim}--> importInterface :: Position -> ModuleIdent -> Bool -> Maybe ImportSpec->                 -> Interface -> PEnv -> TCEnv -> ValueEnv -> ArityEnv->                 -> (PEnv,TCEnv,ValueEnv,ArityEnv)-> importInterface p m q is i pEnv tcEnv tyEnv aEnv =->   (importEntities m q vs id mPEnv pEnv,->    importEntities m q ts (importData vs) mTCEnv tcEnv,->    importEntities m q vs id mTyEnv tyEnv,->    importEntities m q as id mAEnv aEnv)->   where mPEnv  = intfEnv bindPrec i->         mTCEnv = intfEnv bindTC i->         mTyEnv = intfEnv bindTy i->         mAEnv  = intfEnv bindA i->         is' = maybe [] (expandSpecs m mTCEnv mTyEnv) is->         ts  = isVisible is (Set.fromList (foldr addType [] is'))->         vs  = isVisible is (Set.fromList (foldr addValue [] is'))->         as  = isVisible is (Set.fromList (foldr addArity [] is'))--> isVisible :: Maybe ImportSpec -> Set.Set Ident -> Ident -> Bool-> isVisible (Just (Importing _ _)) xs = (`Set.member` xs)-> isVisible (Just (Hiding _ _)) xs = (`Set.notMember` xs)-> isVisible _ _ = const True--> importEntities :: Entity a => ModuleIdent -> Bool -> (Ident -> Bool)->                -> (a -> a) -> Map.Map Ident a -> TopEnv a -> TopEnv a-> importEntities m q isVisible f mEnv env =->   foldr (uncurry (if q then qualImportTopEnv m else importUnqual m)) env->         [(x,f y) | (x,y) <- Map.toList mEnv, isVisible x]->   where importUnqual m x y = importTopEnv m x y . qualImportTopEnv m x y--> importData :: (Ident -> Bool) -> TypeInfo -> TypeInfo-> importData isVisible (DataType tc n cs) =->   DataType tc n (map (>>= importConstr isVisible) cs)-> importData isVisible (RenamingType tc n nc) =->   maybe (DataType tc n []) (RenamingType tc n) (importConstr isVisible nc)-> importData isVisible (AliasType tc  n ty) = AliasType tc n ty--> importConstr :: (Ident -> Bool) -> Data a -> Maybe (Data a)-> importConstr isVisible (Data c n tys)->   | isVisible c = Just (Data c n tys)->   | otherwise = Nothing--\end{verbatim}-Importing an interface into another interface is somewhat simpler-because all entities are imported into the environment. In addition,-only a qualified import is necessary. Note that the hidden data types-are imported as well because they may be used in type expressions in-an interface.-\begin{verbatim}--> importInterfaceIntf :: Interface -> PEnv -> TCEnv -> ValueEnv -> ArityEnv->                     -> (PEnv,TCEnv,ValueEnv,ArityEnv)-> importInterfaceIntf i pEnv tcEnv tyEnv aEnv =->   (importEntities m True (const True) id (intfEnv bindPrec i) pEnv,->    importEntities m True (const True) id (intfEnv bindTCHidden i) tcEnv,->    importEntities m True (const True) id (intfEnv bindTy i) tyEnv,->    importEntities m True (const True) id (intfEnv bindA i) aEnv)->   where Interface m _ = i--\end{verbatim}-In a first step, the three export environments are initialized from-the interface's declarations. This step also qualifies the names of-all entities defined in (but not imported into) the interface with its-module name.  -\begin{verbatim}--> intfEnv :: (ModuleIdent -> IDecl -> Map.Map Ident a -> Map.Map Ident a)->         -> Interface -> Map.Map Ident a-> intfEnv bind (Interface m ds) = foldr (bind m) Map.empty ds--> bindPrec :: ModuleIdent -> IDecl -> ExpPEnv -> ExpPEnv-> bindPrec m (IInfixDecl _ fix p op) =->   Map.insert (unqualify op) (PrecInfo (qualQualify m op) (OpPrec fix p))-> bindPrec _ _ = id--> bindTC :: ModuleIdent -> IDecl -> ExpTCEnv -> ExpTCEnv-> bindTC m (IDataDecl _ tc tvs cs) mTCEnv ->   | isJust (Map.lookup (unqualify tc) mTCEnv) =->     mTCEnv->   | otherwise =->     bindType DataType m tc tvs (map (fmap mkData) cs) mTCEnv->   where mkData (ConstrDecl _ evs c tys) =->           Data c (length evs) (toQualTypes m tvs tys)->         mkData (ConOpDecl _ evs ty1 c ty2) =->           Data c (length evs) (toQualTypes m tvs [ty1,ty2])-> bindTC m (INewtypeDecl _ tc tvs (NewConstrDecl _ evs c ty)) mTCEnv =->   bindType RenamingType m tc tvs ->	 (Data c (length evs) (toQualType m tvs ty)) mTCEnv-> bindTC m (ITypeDecl _ tc tvs ty) mTCEnv->   | isRecordExtId tc' = ->     bindType AliasType m (qualify (fromRecordExtId tc')) tvs ->	   (toQualType m tvs ty) mTCEnv->   | otherwise =->     bindType AliasType m tc tvs (toQualType m tvs ty) mTCEnv->   where tc' = unqualify tc-> bindTC m _ mTCEnv = mTCEnv--> bindTCHidden :: ModuleIdent -> IDecl -> ExpTCEnv -> ExpTCEnv-> bindTCHidden m (HidingDataDecl _ tc tvs) =->   bindType DataType m (qualify tc) tvs []-> bindTCHidden m d = bindTC m d--> bindType :: (QualIdent -> Int -> a -> TypeInfo) -> ModuleIdent -> QualIdent->          -> [Ident] -> a -> ExpTCEnv -> ExpTCEnv-> bindType f m tc tvs =->   Map.insert (unqualify tc) . f (qualQualify m tc) (length tvs) --> bindTy :: ModuleIdent -> IDecl -> ExpValueEnv -> ExpValueEnv-> bindTy m (IDataDecl _ tc tvs cs) =->   flip (foldr (bindConstr m tc' tvs (constrType tc' tvs))) (catMaybes cs)->   where tc' = qualQualify m tc-> bindTy m (INewtypeDecl _ tc tvs nc) =->   bindNewConstr m tc' tvs (constrType tc' tvs) nc->   where tc' = qualQualify m tc-> --bindTy m (ITypeDecl _ r tvs (RecordType fs _)) =-> --  flip (foldr (bindRecLabel m r')) fs-> --  where r' = qualifyWith m (fromRecordExtId (unqualify r))-> bindTy m (IFunctionDecl _ f _ ty) =->   Map.insert (unqualify f)->           (Value (qualQualify m f) (polyType (toQualType m [] ty)))-> bindTy m _ = id--> bindConstr :: ModuleIdent -> QualIdent -> [Ident] -> TypeExpr -> ConstrDecl->            -> ExpValueEnv -> ExpValueEnv-> bindConstr m tc tvs ty0 (ConstrDecl _ evs c tys) =->   bindValue DataConstructor m tc tvs c evs (foldr ArrowType ty0 tys)-> bindConstr m tc tvs ty0 (ConOpDecl _ evs ty1 op ty2) =->   bindValue DataConstructor m tc tvs op evs->             (ArrowType ty1 (ArrowType ty2 ty0))--> bindNewConstr :: ModuleIdent -> QualIdent -> [Ident] -> TypeExpr->               -> NewConstrDecl -> ExpValueEnv -> ExpValueEnv-> bindNewConstr m tc tvs ty0 (NewConstrDecl _ evs c ty1) =->   bindValue NewtypeConstructor m tc tvs c evs (ArrowType ty1 ty0)--> --bindRecLabel :: ModuleIdent -> QualIdent -> ([Ident],TypeExpr)-> --      -> ExpValueEnv -> ExpValueEnv-> --bindRecLabel m r ([l],ty) =-> --  Map.insert l (Label (qualify l) r (polyType (toQualType m [] ty)))--> bindValue :: (QualIdent -> ExistTypeScheme -> ValueInfo) -> ModuleIdent->           -> QualIdent -> [Ident] -> Ident -> [Ident] -> TypeExpr->           -> ExpValueEnv -> ExpValueEnv-> bindValue f m tc tvs c evs ty = Map.insert c (f (qualifyLike tc c) sigma)->   where sigma = ForAllExist (length tvs) (length evs) (toQualType m tvs ty)->         qualifyLike x = maybe qualify qualifyWith (qualidMod x)--> bindA :: ModuleIdent -> IDecl -> ExpArityEnv -> ExpArityEnv-> bindA m (IDataDecl _ _ _ cs) expAEnv->    = foldr (bindConstrA m) expAEnv (catMaybes cs)-> bindA m (IFunctionDecl _ f a _) expAEnv->    = Map.insert (unqualify f) (ArityInfo (qualQualify m f) a) expAEnv-> bindA _ _ expAEnv = expAEnv--> bindConstrA :: ModuleIdent -> ConstrDecl -> ExpArityEnv -> ExpArityEnv-> bindConstrA m (ConstrDecl _ _ c tys) expAEnv->    = Map.insert c (ArityInfo (qualifyWith m c) (length tys)) expAEnv-> bindConstrA m (ConOpDecl _ _ _ c _) expAEnv->    = Map.insert c (ArityInfo (qualifyWith m c) 2) expAEnv--\end{verbatim}-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-\begin{verbatim}-import A(T(C))-import A(T(..))-\end{verbatim}-but can be hidden in three different ways:-\begin{verbatim}-import A hiding(C)-import A hiding(T(C))-import A hiding(T(..))-\end{verbatim}--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.-\begin{verbatim}--> expandSpecs :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> ImportSpec->             -> [Import]-> expandSpecs m tcEnv tyEnv (Importing _ is) =->   concat (map (expandImport m tcEnv tyEnv) is)-> expandSpecs m tcEnv tyEnv (Hiding _ is) =->   concat (map (expandHiding m tcEnv tyEnv) is)--> expandImport :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> Import->              -> [Import]-> expandImport m tcEnv tyEnv (Import x) = expandThing m tcEnv tyEnv x-> expandImport m tcEnv tyEnv (ImportTypeWith tc cs) =->   [expandTypeWith m tcEnv tc cs]-> expandImport m tcEnv tyEnv (ImportTypeAll tc) =->   [expandTypeAll m tcEnv tc]--> expandHiding :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> Import->              -> [Import]-> expandHiding m tcEnv tyEnv (Import x) = expandHide m tcEnv tyEnv x-> expandHiding m tcEnv tyEnv (ImportTypeWith tc cs) =->   [expandTypeWith m tcEnv tc cs]-> expandHiding m tcEnv tyEnv (ImportTypeAll tc) =->   [expandTypeAll m tcEnv tc]--> expandThing :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> Ident->             -> [Import]-> expandThing m tcEnv tyEnv tc =->   case Map.lookup tc tcEnv of->     Just _ -> expandThing' m tyEnv tc (Just [ImportTypeWith tc []])->     Nothing -> expandThing' m tyEnv tc Nothing--> expandThing' :: ModuleIdent -> ExpValueEnv -> Ident->              -> Maybe [Import] -> [Import]-> expandThing' m tyEnv f tcImport =->   case Map.lookup f tyEnv of->     Just v->       | isConstr v -> maybe (errorAt' (importDataConstr m f)) id tcImport->       | otherwise -> Import f : maybe [] id tcImport->     Nothing -> maybe (errorAt' (undefinedEntity m f)) id tcImport->   where isConstr (DataConstructor _ _) = True->         isConstr (NewtypeConstructor _ _) = True->         isConstr (Value _ _) = False--> expandHide :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> Ident->            -> [Import]-> expandHide m tcEnv tyEnv tc =->   case Map.lookup tc tcEnv of->     Just _ -> expandHide' m tyEnv tc (Just [ImportTypeWith tc []])->     Nothing -> expandHide' m tyEnv tc Nothing--> expandHide' :: ModuleIdent -> ExpValueEnv -> Ident->             -> Maybe [Import] -> [Import]-> expandHide' m tyEnv f tcImport =->   case Map.lookup f tyEnv of->     Just _ -> Import f : maybe [] id tcImport->     Nothing -> maybe (errorAt' (undefinedEntity m f)) id tcImport--> expandTypeWith ::  ModuleIdent -> ExpTCEnv -> Ident -> [Ident]->                -> Import-> expandTypeWith m tcEnv tc cs =->   case Map.lookup tc tcEnv of->     Just (DataType _ _ cs') ->->       ImportTypeWith tc (map (checkConstr [c | Just (Data c _ _) <- cs']) cs)->     Just (RenamingType _ _ (Data c _ _)) ->->       ImportTypeWith tc (map (checkConstr [c]) cs)->     Just _ -> errorAt' (nonDataType m tc)->     Nothing -> errorAt' (undefinedEntity m tc)->   where checkConstr cs c->           | c `elem` cs = c->           | otherwise = errorAt' (undefinedDataConstr m tc c)--> expandTypeAll :: ModuleIdent -> ExpTCEnv -> Ident -> Import-> expandTypeAll m tcEnv tc =->   case Map.lookup tc tcEnv of->     Just (DataType _ _ cs) -> ImportTypeWith tc [c | Just (Data c _ _) <- cs]->     Just (RenamingType _ _ (Data c _ _)) -> ImportTypeWith tc [c]->     Just _ -> errorAt' (nonDataType m tc)->     Nothing -> errorAt' (undefinedEntity m tc)--\end{verbatim}-After all modules have been imported, the compiler has to ensure that-all references to a data type use the same list of constructors.-\begin{verbatim}--> importUnifyData :: TCEnv -> TCEnv-> importUnifyData tcEnv =->   fmap (setInfo (foldr (mergeData . snd) Map.empty (allImports tcEnv))) tcEnv->   where setInfo tcs t = fromJust (Map.lookup (origName t) tcs)->         mergeData t tcs =->           Map.insert tc (maybe t (fromJust . merge t) (Map.lookup tc tcs)) tcs->           where tc = origName t--\end{verbatim}-Auxiliary functions:-\begin{verbatim}--> addType :: Import -> [Ident] -> [Ident]-> addType (Import _) tcs = tcs-> addType (ImportTypeWith tc _) tcs = tc : tcs-> addType (ImportTypeAll _) _ = internalError "types"--> addValue :: Import -> [Ident] -> [Ident]-> addValue (Import f) fs = f : fs-> addValue (ImportTypeWith _ cs) fs = cs ++ fs-> addValue (ImportTypeAll _) _ = internalError "values"--> addArity :: Import -> [Ident] -> [Ident]-> addArity (Import f) ids = f:ids-> addArity (ImportTypeWith _ cs) ids = cs ++ ids-> addArity (ImportTypeAll _) _ = internalError "arities"--> constrType :: QualIdent -> [Ident] -> TypeExpr-> constrType tc tvs = ConstructorType tc (map VariableType tvs)--\end{verbatim}-Error messages:-\begin{verbatim}--> undefinedEntity :: ModuleIdent -> Ident -> (Position,String)-> undefinedEntity m x =->  (positionOfIdent x,->   "Module " ++ moduleName m ++ " does not export " ++ name x)--> undefinedDataConstr :: ModuleIdent -> Ident -> Ident -> (Position,String)-> undefinedDataConstr m tc c =->  (positionOfIdent c,   ->   name c ++ " is not a data constructor of type " ++ name tc)--> nonDataType :: ModuleIdent -> Ident -> (Position,String)-> nonDataType m tc = ->  (positionOfIdent tc,->   name tc ++ " is not a data type")--> importDataConstr :: ModuleIdent -> Ident -> (Position,String)-> importDataConstr m c = ->  (positionOfIdent c,->   "Explicit import for data constructor " ++ name c)--\end{verbatim}
− src/InterfaceCheck.hs 
@@ -1,142 +0,0 @@---------------------------------------------------------------------------------------------------------------------------------------------------------------------- InterfaceCheck - Checks the equality of the interfaces of two FlatCurry ---                  programs ------ January 2006,--- Martin Engelke (men@informatik.uni-kiel.de)----module InterfaceCheck where--import Data.List--import Curry.ExtendedFlat.Type--------------------------------------------------------------------------------------- Checks whether the interfaces of two FlatCurry programs are equal -interfaceCheck :: Prog -> Prog -> Bool-interfaceCheck (Prog m1 is1 ts1 fs1 os1) (Prog m2 is2 ts2 fs2 os2)-   = m1 == m2 -     && sort is1 == sort is2-     && checkTypeDecls ts1 ts2-     && checkFuncDecls fs1 fs2-     && checkOpDecls os1 os2-----------------------------------------------------------------------------------------------------------------------------------------------------------------------checkTypeDecls :: [TypeDecl] -> [TypeDecl] -> Bool-checkTypeDecls ts1 [] = null ts1-checkTypeDecls ts1 ((Type qname vis2 is2 cs2):ts2')-   = let (mt,ts1') = extract (isDataType qname) ts1-     in  maybe False -               (\ (Type _ vis1 is1 cs1) -		-> vis1 == vis2 -		   && is1 == is2 -		   && checkConsDecls cs1 cs2-		   && checkTypeDecls ts1' ts2')-	       mt-checkTypeDecls ts1 ((TypeSyn qname vis2 is2 texpr2):ts2')-   = let (mt,ts1') = extract (isTypeSyn qname) ts1-     in  maybe False-	       (\ (TypeSyn _ vis1 is1 texpr1)-		-> vis1 == vis2-		   && is1 == is2-		   && texpr1 == texpr2-		   && checkTypeDecls ts1' ts2')-	       mt-----checkConsDecls :: [ConsDecl] -> [ConsDecl] -> Bool-checkConsDecls cs1 [] = null cs1-checkConsDecls cs1 ((Cons qname arity2 vis2 texprs2):cs2')-   = let (mc,cs1') = extract (isCons qname) cs1-     in  maybe False-	       (\ (Cons _ arity1 vis1 texprs1)-		-> arity1 == arity2-		   && vis1 == vis2-		   && texprs1 == texprs2-		   && checkConsDecls cs1' cs2')-	       mc-----checkFuncDecls :: [FuncDecl] -> [FuncDecl] -> Bool-checkFuncDecls fs1 [] = null fs1-checkFuncDecls fs1 ((Func qname arity2 vis2 texpr2 rule2):fs2')-   = let (mf,fs1') = extract (isFunc qname) fs1-     in  maybe False-	       (\ (Func _ arity1 vis1 texpr1 rule1)-		-> arity1 == arity2-		   && vis1 == vis2-		   && texpr1 == texpr2-		   && checkRule rule1 rule2-		   && checkFuncDecls fs1' fs2')-	       mf-----checkRule :: Rule -> Rule -> Bool-checkRule (Rule _ _)   (Rule _ _)   = True-checkRule (External _) (External _) = True-checkRule _            _            = False-----checkOpDecls :: [OpDecl] -> [OpDecl] -> Bool-checkOpDecls os1 [] = null os1-checkOpDecls os1 ((Op qname fix2 prec2):os2')-   = let (mo,os1') = extract (isOp qname) os1-     in  maybe False-	       (\ (Op _ fix1 prec1)-		-> prec1 == prec2-		   && fix1 == fix2-		   && checkOpDecls os1' os2')-	       mo---------------------------------------------------------------------------------------isDataType :: QName -> TypeDecl -> Bool-isDataType qname (Type qname' _ _ _) = qname == qname'-isDataType _     _                   = False-----isTypeSyn :: QName -> TypeDecl -> Bool-isTypeSyn qname (TypeSyn qname' _ _ _) = qname == qname'-isTypeSyn _     _                      = False-----isCons :: QName -> ConsDecl -> Bool-isCons qname (Cons qname' _ _ _) = qname == qname'-----isFunc :: QName -> FuncDecl -> Bool-isFunc qname (Func qname' _ _ _ _) = qname == qname'-----isOp :: QName -> OpDecl -> Bool-isOp qname (Op qname' _ _) = qname == qname'---------------------------------------------------------------------------------------extract :: (a -> Bool) -> [a] -> (Maybe a, [a])-extract _ [] = (Nothing, [])-extract c (x:xs) | c x       = (Just x, xs)-		 | otherwise = let (res, xs') = extract c xs in (res, x:xs')--{---- Alternativ:-extract :: (a -> Bool) -> [a] -> (Maybe a, [a])-extract c xs = maybe (Nothing, xs) (\x -> (Just x, delete x xs)) (find c xs)--}------------------------------------------------------------------------------------------------------------------------------------------------------------------
+ src/Interfaces.hs view
@@ -0,0 +1,151 @@+{- |+    Module      :  $Header$+    Description :  Loading interfaces+    Copyright   :  (c) 2000 - 2004, Wolfgang Lux+                       2011 - 2013, Björn Peemöller+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    The compiler maintains a global environment holding all (directly or+    indirectly) imported interface declarations for a module.++    This module contains a function to load *all* interface declarations+    declared by the (directly or indirectly) imported modules, regardless+    whether they are included by the import specification or not.++    The declarations are later brought into the scope of the module via the+    function 'importModules', see module "Imports".++    Interface files are updated by the Curry builder when necessary,+    see module "CurryBuilder".+-}+{-# LANGUAGE CPP #-}+module Interfaces (loadInterfaces) where++#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif++import           Control.Monad               (unless)+import qualified Control.Monad.State    as S (StateT, execStateT, gets, modify)+import qualified Data.Map               as M (insert, member)++import           Curry.Base.Ident+import           Curry.Base.Monad+import           Curry.Base.Position+import           Curry.Base.SpanInfo ()+import           Curry.Base.Pretty+import           Curry.Files.PathUtils+import           Curry.Syntax++import Base.Messages+import Env.Interface++import Checks.InterfaceSyntaxCheck (intfSyntaxCheck)++-- Interface accumulating monad+type IntfLoader a = S.StateT LoaderState IO a++data LoaderState = LoaderState+  { iEnv   :: InterfaceEnv+  , spaths :: [FilePath]+  , errs   :: [Message]+  }++-- Report an error.+report :: [Message] -> IntfLoader ()+report msg = S.modify $ \ s -> s { errs = msg ++ errs s }++-- Check whether a module interface is already loaded.+loaded :: ModuleIdent -> IntfLoader Bool+loaded m = S.gets $ \ s -> m `M.member` iEnv s++-- Retrieve the search paths+searchPaths :: IntfLoader [FilePath]+searchPaths = S.gets spaths++-- Add an interface to the environment.+addInterface :: ModuleIdent -> Interface -> IntfLoader ()+addInterface m intf = S.modify $ \ s -> s { iEnv = M.insert m intf $ iEnv s }++-- |Load the interfaces needed by a given module.+-- This function returns an 'InterfaceEnv' containing the 'Interface's which+-- were successfully loaded.+loadInterfaces :: [FilePath] -- ^ 'FilePath's to search in for interfaces+               -> Module a   -- ^ 'Module' header with import declarations+               -> CYIO InterfaceEnv+loadInterfaces paths (Module _ _ _ m _ is _) = do+  res <- liftIO $ S.execStateT load (LoaderState initInterfaceEnv paths [])+  if null (errs res) then ok (iEnv res) else failMessages (reverse $ errs res)+  where load = mapM_ (loadInterface [m]) [(p, m') | ImportDecl p m' _ _ _ <- is]++-- |Load an interface into the given environment.+--+-- If an import declaration for a module is found, the compiler first+-- checks whether an import for the module is already pending.+-- In this case the module imports are cyclic which is not allowed in Curry.+-- Therefore, the import will be skipped and an error will be issued.+-- Otherwise, the compiler checks whether the module has already been imported.+-- If so, nothing needs to be done, otherwise the interface will be searched+-- for in the import paths and compiled.+loadInterface :: HasPosition a => [ModuleIdent] -> (a, ModuleIdent)+              -> IntfLoader ()+loadInterface ctxt (_, m)+  | m `elem` ctxt = report [errCyclicImport $ m : takeWhile (/= m) ctxt]+  | otherwise     = do+    isLoaded <- loaded m+    unless isLoaded $ do+      paths  <- searchPaths+      mbIntf <- liftIO $ lookupCurryInterface paths m+      case mbIntf of+        Nothing -> report [errInterfaceNotFound m]+        Just fn -> compileInterface ctxt m fn++-- |Compile an interface by recursively loading its dependencies.+--+-- After reading an interface, all imported interfaces are recursively+-- loaded and inserted into the interface's environment.+compileInterface :: [ModuleIdent] -> ModuleIdent -> FilePath+                 -> IntfLoader ()+compileInterface ctxt m fn = do+  mbSrc <- liftIO $ readModule fn+  case mbSrc of+    Nothing  -> report [errInterfaceNotFound m]+    Just src -> case runCYMIgnWarn (parseInterface fn src) of+      Left err -> report err+      Right intf@(Interface n is _) ->+        if m /= n+          then report [errWrongInterface m n]+          else do+            let (intf', intfErrs) = intfSyntaxCheck intf+            mapM_ report [intfErrs]+            mapM_ (loadInterface (m : ctxt)) [ (q, i) | IImportDecl q i <- is ]+            addInterface m intf'++-- Error message for required interface that could not be found.+errInterfaceNotFound :: ModuleIdent -> Message+errInterfaceNotFound m = spanInfoMessage m $+  text "Interface for module" <+> text (moduleName m) <+> text "not found"++-- Error message for an unexpected interface.+errWrongInterface :: ModuleIdent -> ModuleIdent -> Message+errWrongInterface m n = spanInfoMessage m $+  text "Expected interface for" <+> text (moduleName m)+  <> comma <+> text "but found" <+> text (moduleName n)++-- Error message for a cyclic import.+errCyclicImport :: [ModuleIdent] -> Message+errCyclicImport []  = internalError "Interfaces.errCyclicImport: empty list"+errCyclicImport [m] = spanInfoMessage m $+  text "Recursive import for module" <+> text (moduleName m)+errCyclicImport ms  = spanInfoMessage (head ms) $+  text "Cyclic import dependency between modules"+  <+> hsep (punctuate comma (map text inits)) <+> text "and" <+> text lastm+  where+  (inits, lastm)         = splitLast $ map moduleName ms+  splitLast []           = internalError "Interfaces.splitLast: empty list"+  splitLast (x : [])     = ([]  , x)+  splitLast (x : y : ys) = (x : xs, z) where (xs, z) = splitLast (y : ys)
− src/KindCheck.lhs 
@@ -1,320 +0,0 @@--% $Id: KindCheck.lhs,v 1.33 2004/02/13 19:24:04 wlux Exp $-%-% Copyright (c) 1999-2004, Wolfgang Lux-% See LICENSE for the full license.-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-%-\nwfilename{KindCheck.lhs}-\section{Checking Type Definitions}-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 ($\star$), i.e., all type constructor applications-must be saturated.--During kind checking, this module will also disambiguate nullary-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.-\begin{verbatim}--> module KindCheck(kindCheck) where--> import Data.Maybe--> import Curry.Syntax-> import Curry.Syntax.Utils(isTypeDecl)-> import Curry.Base.Position-> import Curry.Base.Ident-> import Base hiding (bindArity)-> import TopEnv--\end{verbatim}-In order to check type constructor applications, the compiler-maintains an environment containing the kind information for all type-constructors. The function \texttt{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.-\begin{verbatim}--> kindCheck :: ModuleIdent -> TCEnv -> [Decl] -> [Decl]-> kindCheck m tcEnv ds =->   case findDouble (map tconstr ds') of->     Nothing -> map (checkDecl m kEnv) ds->     Just tc -> errorAt' (duplicateType tc)->   where ds' = filter isTypeDecl ds->         kEnv = foldr (bindArity m) (fmap tcArity tcEnv) ds'--\end{verbatim}-The kind environment only needs to record the arity of each type constructor.-\begin{verbatim}--> type KindEnv = TopEnv Int--> bindArity :: ModuleIdent -> Decl -> KindEnv -> KindEnv-> bindArity m (DataDecl _ tc tvs _) = bindArity' m  tc tvs-> bindArity m (NewtypeDecl _ tc tvs _) = bindArity' m  tc tvs-> bindArity m (TypeDecl _ tc tvs _) = bindArity' m  tc tvs-> bindArity _ _ = id--> bindArity' :: ModuleIdent -> Ident -> [Ident]->            -> KindEnv -> KindEnv-> bindArity' m tc tvs ->   = bindTopEnv "KindCheck.bindArity'" tc n ->                . qualBindTopEnv "KindCheck.bindArity'" (qualifyWith m tc) n->   where n = length tvs--> lookupKind :: Ident -> KindEnv -> [Int]-> lookupKind = lookupTopEnv--> qualLookupKind :: QualIdent -> KindEnv -> [Int]-> qualLookupKind = qualLookupTopEnv--\end{verbatim}-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.-\begin{verbatim}--> checkDecl :: ModuleIdent -> KindEnv -> Decl -> Decl-> checkDecl m kEnv (DataDecl p tc tvs cs) =->   DataDecl p tc tvs' (map (checkConstrDecl m kEnv tvs') cs)->   where tvs' = checkTypeLhs kEnv tvs-> checkDecl m kEnv (NewtypeDecl p tc tvs nc) =->   NewtypeDecl p tc tvs' (checkNewConstrDecl m kEnv tvs' nc)->   where tvs' = checkTypeLhs kEnv tvs-> checkDecl m kEnv (TypeDecl p tc tvs ty) =->   TypeDecl p tc tvs' (checkClosedType m kEnv tvs' ty)->   where tvs' = checkTypeLhs kEnv tvs-> checkDecl m kEnv (TypeSig p vs ty) =->   TypeSig p vs (checkType m kEnv ty)-> checkDecl m kEnv (FunctionDecl p f eqs) =->   FunctionDecl p f (map (checkEquation m kEnv) eqs)-> checkDecl m kEnv (PatternDecl p t rhs) =->   PatternDecl p t (checkRhs m kEnv rhs)-> checkDecl m kEnv (ExternalDecl p cc ie f ty) =->   ExternalDecl p cc ie f (checkType m kEnv ty)-> checkDecl _ _ d = d--> checkTypeLhs :: KindEnv -> [Ident] -> [Ident]-> checkTypeLhs kEnv (tv:tvs)->   | tv == anonId = tv : checkTypeLhs kEnv tvs->   | isTypeConstr tv = errorAt' (noVariable tv)->   | tv `elem` tvs = errorAt' (nonLinear tv)->   | otherwise = tv : checkTypeLhs kEnv tvs->   where isTypeConstr tv = not (null (lookupKind tv kEnv))-> checkTypeLhs _ [] = []--> checkConstrDecl :: ModuleIdent -> KindEnv -> [Ident] -> ConstrDecl -> ConstrDecl-> checkConstrDecl m kEnv tvs (ConstrDecl p evs c tys) =->   ConstrDecl p evs' c (map (checkClosedType m kEnv tvs') tys)->   where evs' = checkTypeLhs kEnv evs->         tvs' = evs' ++ tvs-> checkConstrDecl m kEnv tvs (ConOpDecl p evs ty1 op ty2) =->   ConOpDecl p evs' (checkClosedType m kEnv tvs' ty1) op->             (checkClosedType m kEnv tvs' ty2)->   where evs' = checkTypeLhs kEnv evs->         tvs' = evs' ++ tvs--> checkNewConstrDecl :: ModuleIdent -> KindEnv -> [Ident] -> NewConstrDecl ->	     -> NewConstrDecl-> checkNewConstrDecl m kEnv tvs (NewConstrDecl p evs c ty) =->   NewConstrDecl p evs' c (checkClosedType m kEnv tvs' ty)->   where evs' = checkTypeLhs kEnv evs->         tvs' = evs' ++ tvs--\end{verbatim}-Checking expressions is rather straight forward. The compiler must-only traverse the structure of expressions in order to find local-declaration groups.-\begin{verbatim}--> checkEquation :: ModuleIdent -> KindEnv -> Equation -> Equation-> checkEquation m kEnv (Equation p lhs rhs) = ->     Equation p lhs (checkRhs m kEnv rhs)--> checkRhs :: ModuleIdent -> KindEnv -> Rhs -> Rhs-> checkRhs m kEnv (SimpleRhs p e ds) =->   SimpleRhs p (checkExpr m kEnv e) (map (checkDecl m kEnv) ds)-> checkRhs m kEnv (GuardedRhs es ds) =->   GuardedRhs (map (checkCondExpr m kEnv) es) (map (checkDecl m kEnv) ds)--> checkCondExpr :: ModuleIdent -> KindEnv -> CondExpr -> CondExpr-> checkCondExpr m kEnv (CondExpr p g e) =->   CondExpr p (checkExpr m kEnv g) (checkExpr m kEnv e)--> checkExpr :: ModuleIdent -> KindEnv -> Expression -> Expression-> checkExpr _ _ (Literal l) = Literal l-> checkExpr _ _ (Variable v) = Variable v-> checkExpr _ _ (Constructor c) = Constructor c-> checkExpr m kEnv (Paren e) = Paren (checkExpr m kEnv e)-> checkExpr m kEnv (Typed e ty) =->   Typed (checkExpr m kEnv e) (checkType m kEnv ty)-> checkExpr m kEnv (Tuple p es) = Tuple p (map (checkExpr m kEnv ) es)-> checkExpr m kEnv (List p es) = List p (map (checkExpr m kEnv ) es)-> checkExpr m kEnv (ListCompr p e qs) =->   ListCompr p (checkExpr m kEnv e) (map (checkStmt m kEnv ) qs)-> checkExpr m kEnv  (EnumFrom e) = EnumFrom (checkExpr m kEnv  e)-> checkExpr m kEnv  (EnumFromThen e1 e2) =->   EnumFromThen (checkExpr m kEnv  e1) (checkExpr m kEnv  e2)-> checkExpr m kEnv  (EnumFromTo e1 e2) =->   EnumFromTo (checkExpr m kEnv  e1) (checkExpr m kEnv  e2)-> checkExpr m kEnv  (EnumFromThenTo e1 e2 e3) =->   EnumFromThenTo (checkExpr m kEnv  e1) (checkExpr m kEnv  e2)->                  (checkExpr m kEnv  e3)-> checkExpr m kEnv  (UnaryMinus op e) = UnaryMinus op (checkExpr m kEnv  e)-> checkExpr m kEnv  (Apply e1 e2) =->   Apply (checkExpr m kEnv  e1) (checkExpr m kEnv  e2)-> checkExpr m kEnv  (InfixApply e1 op e2) =->   InfixApply (checkExpr m kEnv  e1) op (checkExpr m kEnv  e2)-> checkExpr m kEnv  (LeftSection e op) = LeftSection (checkExpr m kEnv  e) op-> checkExpr m kEnv  (RightSection op e) = RightSection op (checkExpr m kEnv  e)-> checkExpr m kEnv  (Lambda r ts e) = Lambda r ts (checkExpr m kEnv  e)-> checkExpr m kEnv  (Let ds e) =->   Let (map (checkDecl m kEnv) ds) (checkExpr m kEnv  e)-> checkExpr m kEnv  (Do sts e) =->   Do (map (checkStmt m kEnv ) sts) (checkExpr m kEnv  e)-> checkExpr m kEnv  (IfThenElse r e1 e2 e3) =->   IfThenElse r (checkExpr m kEnv  e1) (checkExpr m kEnv  e2)->              (checkExpr m kEnv  e3)-> checkExpr m kEnv  (Case r e alts) =->   Case r (checkExpr m kEnv  e) (map (checkAlt m kEnv) alts)-> checkExpr m kEnv  (RecordConstr fs) =->   RecordConstr (map (checkFieldExpr m kEnv) fs)-> checkExpr m kEnv  (RecordSelection e l) =->   RecordSelection (checkExpr m kEnv  e) l-> checkExpr m kEnv  (RecordUpdate fs e) =->   RecordUpdate (map (checkFieldExpr m kEnv) fs) (checkExpr m kEnv  e)--> checkStmt :: ModuleIdent -> KindEnv -> Statement -> Statement-> checkStmt m kEnv  (StmtExpr p e) = StmtExpr p (checkExpr m kEnv  e)-> checkStmt m kEnv  (StmtBind p t e) = StmtBind p t (checkExpr m kEnv  e)-> checkStmt m kEnv  (StmtDecl ds) = StmtDecl (map (checkDecl m kEnv) ds)--> checkAlt :: ModuleIdent -> KindEnv -> Alt -> Alt-> checkAlt m kEnv (Alt p t rhs) = Alt p t (checkRhs m kEnv rhs)--> checkFieldExpr :: ModuleIdent -> KindEnv -> Field Expression->	            -> Field Expression-> checkFieldExpr m kEnv (Field p l e) = Field p l (checkExpr m kEnv e)--\end{verbatim}-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.-\begin{verbatim}--> checkClosedType :: ModuleIdent -> KindEnv -> [Ident] -> TypeExpr ->	  -> TypeExpr-> checkClosedType m kEnv tvs ty = checkClosed tvs (checkType m kEnv  ty)--> checkType :: ModuleIdent -> KindEnv -> TypeExpr -> TypeExpr-> checkType m kEnv (ConstructorType tc tys) =->   case qualLookupKind tc kEnv of->     []->       | not (isQualified tc) && null tys -> VariableType (unqualify tc)->       | otherwise -> errorAt' (undefinedType tc)->     [n]->       | n == n' -> ConstructorType tc (map (checkType m kEnv ) tys)->       | otherwise -> errorAt' (wrongArity tc n n')->     _ -> case (qualLookupKind (qualQualify m tc) kEnv) of->            [n] ->               | n == n' -> ConstructorType tc (map (checkType m kEnv ) tys)->               | otherwise -> errorAt' (wrongArity tc n n')->            _ -> errorAt' (ambiguousType tc)->  where n' = length tys -> checkType m kEnv  (VariableType tv)->   | tv == anonId = VariableType tv->   | otherwise = checkType m kEnv  (ConstructorType (qualify tv) [])-> checkType m kEnv  (TupleType tys) =->   TupleType (map (checkType m kEnv ) tys)-> checkType m kEnv  (ListType ty) =->   ListType (checkType m kEnv  ty)-> checkType m kEnv  (ArrowType ty1 ty2) =->   ArrowType (checkType m kEnv  ty1) (checkType m kEnv  ty2)-> checkType m kEnv  (RecordType fs r) =->   RecordType (map (\ (ls,ty) -> (ls, checkType m kEnv  ty)) fs)->	       (maybe Nothing (Just . checkType m kEnv ) r)--> checkClosed :: [Ident] -> TypeExpr -> TypeExpr-> checkClosed tvs (ConstructorType tc tys) =->   ConstructorType tc (map (checkClosed tvs) tys)-> checkClosed tvs (VariableType tv)->   | tv == anonId || tv `notElem` tvs = errorAt' (unboundVariable tv)->   | otherwise = VariableType tv-> checkClosed tvs (TupleType tys) =->   TupleType (map (checkClosed tvs) tys)-> checkClosed tvs (ListType ty) =->   ListType (checkClosed tvs ty)-> checkClosed tvs (ArrowType ty1 ty2) =->   ArrowType (checkClosed tvs ty1) (checkClosed tvs ty2)-> checkClosed tvs (RecordType fs r) =->   RecordType (map (\ (ls,ty) -> (ls, checkClosed tvs ty)) fs)->	       (maybe Nothing (Just . checkClosed tvs) r)->       --\end{verbatim}-Auxiliary definitions-\begin{verbatim}--> tconstr :: Decl -> Ident-> tconstr (DataDecl p tc _ _) = tc-> tconstr (NewtypeDecl p tc _ _) = tc-> tconstr (TypeDecl p tc _ _) = tc-> tconstr _ = internalError "tconstr"--\end{verbatim}-Error messages:-\begin{verbatim}--> undefinedType :: QualIdent -> (Position,String)-> undefinedType tc = ->     (positionOfQualIdent tc,->      "Undefined type " ++ qualName tc)--> ambiguousType :: QualIdent -> (Position,String)-> ambiguousType tc = ->     (positionOfQualIdent tc,->      "Ambiguous type " ++ qualName tc)--> duplicateType :: Ident -> (Position,String)-> duplicateType tc = ->     (positionOfIdent tc,->      "More than one definition for type " ++ name tc)--> nonLinear :: Ident -> (Position,String)-> nonLinear tv =->  (positionOfIdent tv,      ->   "Type variable " ++ name tv ++->   " occurs more than once on left hand side of type declaration")--> noVariable :: Ident -> (Position,String)-> noVariable tv =->  (positionOfIdent tv,      ->   "Type constructor " ++ name tv ++->   " used in left hand side of type declaration")--> wrongArity :: QualIdent -> Int -> Int -> (Position,String)-> wrongArity tc arity argc =->  (positionOfQualIdent tc,      ->   "Type constructor " ++ qualName tc ++ " expects " ++ arguments arity ++->   " but is applied to " ++ show argc)->   where arguments 0 = "no arguments"->         arguments 1 = "1 argument"->         arguments n = show n ++ " arguments"--> unboundVariable :: Ident -> (Position,String)-> unboundVariable tv = ->     (positionOfIdent tv,->      "Unbound type variable " ++ name tv)--\end{verbatim}
− src/Lift.lhs 
@@ -1,307 +0,0 @@--% $Id: Lift.lhs,v 1.23 2004/02/13 14:02:54 wlux Exp $-%-% Copyright (c) 2001-2003, Wolfgang Lux-% See LICENSE for the full license.-%-\nwfilename{Lift.lhs}-\section{Lifting Declarations}-After desugaring and simplifying the code, the compiler lifts all-local function declarations to the top-level keeping only local-variable declarations. The algorithm used here is similar to-Johnsson's~\cite{Johnsson87:Thesis} (see also chapter 6-of~\cite{PeytonJonesLester92:Book}). It consists of two phases, first-we abstract each local function declaration, adding its free variables-as initial parameters and update all calls to take these variables-into account. Then all local function declarations are collected and-lifted to the top-level.-\begin{verbatim}--> module Lift(lift) where--> import Control.Monad-> import qualified Control.Monad.State as S-> import Data.List-> import qualified Data.Map as Map-> import qualified Data.Set as Set--> import Curry.Syntax-> import Curry.Syntax.Utils-> import Types-> import Curry.Base.Ident-> import Base-> import TopEnv-> import SCC--> lift :: ValueEnv -> EvalEnv -> Module -> (Module,ValueEnv,EvalEnv)-> lift tyEnv evEnv (Module m es ds) =->   (Module m es (concatMap liftFunDecl ds'),tyEnv',evEnv')->   where (ds',tyEnv',evEnv') =->           S.evalState (S.evalStateT (abstractModule m ds) tyEnv) evEnv--\end{verbatim}-\paragraph{Abstraction}-Besides adding the free variables to every (local) function, the-abstraction pass also has to update the type environment in order to-reflect the new types of the expanded functions. As usual we use a-state monad transformer in order to pass the type environment-through. The environment constructed in the abstraction phase maps-each local function declaration onto its replacement expression,-i.e. the function applied to its free variables.-\begin{verbatim}--> type AbstractState a = S.StateT ValueEnv (S.State EvalEnv) a-> type AbstractEnv = Map.Map Ident Expression--> abstractModule :: ModuleIdent -> [Decl]->                -> AbstractState ([Decl],ValueEnv,EvalEnv)-> abstractModule m ds =->   do->     ds' <- mapM (abstractDecl m "" [] Map.empty) ds->     tyEnv' <- S.get->     evEnv' <- S.lift S.get->     return (ds',tyEnv',evEnv')--> abstractDecl :: ModuleIdent -> String -> [Ident] -> AbstractEnv -> Decl->              -> AbstractState Decl-> abstractDecl m _ lvs env (FunctionDecl p f eqs) =->   liftM (FunctionDecl p f) (mapM (abstractEquation m lvs env) eqs)-> abstractDecl m pre lvs env (PatternDecl p t rhs) =->   liftM (PatternDecl p t) (abstractRhs m pre lvs env rhs)-> abstractDecl _ _ _ _ d = return d--> abstractEquation :: ModuleIdent -> [Ident] -> AbstractEnv -> Equation->                  -> AbstractState Equation-> abstractEquation m lvs env (Equation p lhs@(FunLhs f ts) rhs) =->   liftM (Equation p lhs)->         (abstractRhs m (name f ++ ".") (lvs ++ bv ts) env rhs)--> abstractRhs :: ModuleIdent -> String -> [Ident] -> AbstractEnv -> Rhs->             -> AbstractState Rhs-> abstractRhs m pre lvs env (SimpleRhs p e _) =->   liftM (flip (SimpleRhs p) []) (abstractExpr m pre lvs env e)--\end{verbatim}-Within a declaration group we have to split the list of declarations-into the function and value declarations. Only the function-declarations are affected by the abstraction algorithm; the value-declarations are left unchanged except for abstracting their right-hand sides.--The abstraction of a recursive declaration group is complicated by the-fact that not all functions need to call each in a recursive-declaration group. E.g., in the following example neither g nor h-call each other.-\begin{verbatim}-  f = g True-    where x = f 1-          f z = y + z-          y = g False-          g z = if z then x else 0-\end{verbatim}-Because of this fact, f and g can be abstracted separately by adding-only \texttt{y} to \texttt{f} and \texttt{x} to \texttt{g}. On the-other hand, in the following example-\begin{verbatim}-  f x y = g 4-    where g p = h p + x-          h q = k + y + q-          k = g x-\end{verbatim}-the local function \texttt{g} uses \texttt{h}, so the free variables-of \texttt{h} have to be added to \texttt{g} as well. However, because-\texttt{h} does not call \texttt{g} it is sufficient to add only-\texttt{k} and \texttt{y} (and not \texttt{x}) to its definition. We-handle this by computing the dependency graph between the functions-and splitting this graph into its strongly connected components. Each-component is then processed separately, adding the free variables in-the group to its functions.--We have to be careful with local declarations within desugared case-expressions. If some of the cases have guards, e.g.,-\begin{verbatim}-  case e of-    x | x < 1 -> 1-    x -> let double y = y * y in double x-\end{verbatim}-the desugarer at present may duplicate code. While there is no problem-with local variable declaration being duplicated, we must avoid to-lift local function declarations more than once. Therefore-\texttt{abstractFunDecls} transforms only those function declarations-that have not been lifted and discards the other declarations. Note-that it is easy to check whether a function has been lifted by-checking whether an entry for its untransformed name is still present-in the type environment.-\begin{verbatim}--> abstractDeclGroup :: ModuleIdent -> String -> [Ident] -> AbstractEnv->                   -> [Decl] -> Expression -> AbstractState Expression-> abstractDeclGroup m pre lvs env ds e =->   abstractFunDecls m pre (lvs ++ bv vds) env (scc bv (qfv m) fds) vds e->   where (fds,vds) = partition isFunDecl ds--> abstractFunDecls :: ModuleIdent -> String -> [Ident] -> AbstractEnv->                  -> [[Decl]] -> [Decl] -> Expression->                  -> AbstractState Expression-> abstractFunDecls m pre lvs env [] vds e =->   do->     vds' <- mapM (abstractDecl m pre lvs env) vds->     e' <- abstractExpr m pre lvs env e->     return (Let vds' e')-> abstractFunDecls m pre lvs env (fds:fdss) vds e =->   do->     fs' <- liftM (\tyEnv -> filter (not . isLifted tyEnv) fs) S.get->     S.modify (abstractFunTypes m pre fvs fs')->     S.lift (S.modify (abstractFunAnnots m pre fs'))->     fds' <- mapM (abstractFunDecl m pre fvs lvs env')->                  [d | d <- fds, any (`elem` fs') (bv d)]->     e' <- abstractFunDecls m pre lvs env' fdss vds e->     return (Let fds' e')->   where fs = bv fds->         fvs = filter (`elem` lvs) (Set.toList fvsRhs)->         env' = foldr (bindF (map mkVar fvs)) env fs->         fvsRhs = Set.unions->           [Set.fromList (maybe [v] (qfv m) (Map.lookup v env)) | v <- qfv m fds]->         bindF fvs f = Map.insert f (apply (mkFun m pre f) fvs)->         isLifted tyEnv f = null (lookupValue f tyEnv)--> abstractFunTypes :: ModuleIdent -> String -> [Ident] -> [Ident]->                  -> ValueEnv -> ValueEnv-> abstractFunTypes m pre fvs fs tyEnv = foldr abstractFunType tyEnv fs->   where tys = map (varType tyEnv) fvs->         abstractFunType f tyEnv =->           qualBindFun m (liftIdent pre f)->                         (foldr TypeArrow (varType tyEnv f) tys)->                         (unbindFun f tyEnv)--> abstractFunAnnots :: ModuleIdent -> String -> [Ident] -> EvalEnv -> EvalEnv-> abstractFunAnnots m pre fs evEnv = foldr abstractFunAnnot evEnv fs->   where abstractFunAnnot f evEnv =->           case Map.lookup f evEnv of->             Just ev -> Map.insert (liftIdent pre f) ev (Map.delete f evEnv)->             Nothing -> evEnv--> abstractFunDecl :: ModuleIdent -> String -> [Ident] -> [Ident]->                 -> AbstractEnv -> Decl -> AbstractState Decl-> abstractFunDecl m pre fvs lvs env (FunctionDecl p f eqs) =->   abstractDecl m pre lvs env (FunctionDecl p f' (map (addVars f') eqs))->   where f' = liftIdent pre f->         addVars f (Equation p (FunLhs _ ts) rhs) =->           Equation p (FunLhs f (map VariablePattern fvs ++ ts)) rhs-> abstractFunDecl m pre _ lvs env (ExternalDecl p cc ie f ty) =->   return (ExternalDecl p cc ie (liftIdent pre f) ty)--> abstractExpr :: ModuleIdent -> String -> [Ident] -> AbstractEnv->              -> Expression -> AbstractState Expression-> abstractExpr _ _ _ _ (Literal l) = return (Literal l)-> abstractExpr m pre lvs env (Variable v)->   | isQualified v = return (Variable v)->   | otherwise = maybe (return (Variable v)) (abstractExpr m pre lvs env)->                       (Map.lookup (unqualify v) env)-> abstractExpr _ _ _ _ (Constructor c) = return (Constructor c)-> abstractExpr m pre lvs env (Apply e1 e2) =->   do->     e1' <- abstractExpr m pre lvs env e1->     e2' <- abstractExpr m pre lvs env e2->     return (Apply e1' e2')-> abstractExpr m pre lvs env (Let ds e) = abstractDeclGroup m pre lvs env ds e-> abstractExpr m pre lvs env (Case r e alts) =->   do->     e' <- abstractExpr m pre lvs env e->     alts' <- mapM (abstractAlt m pre lvs env) alts->     return (Case r e' alts')-> abstractExpr m _ _ _ _ = internalError "abstractExpr"--> abstractAlt :: ModuleIdent -> String -> [Ident] -> AbstractEnv -> Alt->             -> AbstractState Alt-> abstractAlt m pre lvs env (Alt p t rhs) =->   liftM (Alt p t) (abstractRhs m pre (lvs ++ bv t) env rhs)--\end{verbatim}-\paragraph{Lifting}-After the abstraction pass, all local function declarations are lifted-to the top-level.-\begin{verbatim}--> liftFunDecl :: Decl -> [Decl]-> liftFunDecl (FunctionDecl p f eqs) = (FunctionDecl p f eqs' : concat dss')->   where (eqs',dss') = unzip (map liftEquation eqs)-> liftFunDecl d = [d]--> liftVarDecl :: Decl -> (Decl,[Decl])-> liftVarDecl (PatternDecl p t rhs) = (PatternDecl p t rhs',ds')->   where (rhs',ds') = liftRhs rhs-> liftVarDecl (ExtraVariables p vs) = (ExtraVariables p vs,[])--> liftEquation :: Equation -> (Equation,[Decl])-> liftEquation (Equation p lhs rhs) = (Equation p lhs rhs',ds')->   where (rhs',ds') = liftRhs rhs--> liftRhs :: Rhs -> (Rhs,[Decl])-> liftRhs (SimpleRhs p e _) = (SimpleRhs p e' [],ds')->   where (e',ds') = liftExpr e--> liftDeclGroup :: [Decl] -> ([Decl],[Decl])-> liftDeclGroup ds = (vds',concat (map liftFunDecl fds ++ dss'))->   where (fds,vds) = partition isFunDecl ds->         (vds',dss') = unzip (map liftVarDecl vds)--> liftExpr :: Expression -> (Expression,[Decl])-> liftExpr (Literal l) = (Literal l,[])-> liftExpr (Variable v) = (Variable v,[])-> liftExpr (Constructor c) = (Constructor c,[])-> liftExpr (Apply e1 e2) = (Apply e1' e2',ds' ++ ds'')->   where (e1',ds') = liftExpr e1->         (e2',ds'') = liftExpr e2-> liftExpr (Let ds e) = (mkLet ds' e',ds'' ++ ds''')->   where (ds',ds'') = liftDeclGroup ds->         (e',ds''') = liftExpr e->         mkLet ds e = if null ds then e else Let ds e-> liftExpr (Case r e alts) = (Case r e' alts',concat (ds':dss'))->   where (e',ds') = liftExpr e->         (alts',dss') = unzip (map liftAlt alts)-> liftExpr _ = internalError "liftExpr"--> liftAlt :: Alt -> (Alt,[Decl])-> liftAlt (Alt p t rhs) = (Alt p t rhs',ds')->   where (rhs',ds') = liftRhs rhs---\end{verbatim}-\paragraph{Auxiliary definitions}-\begin{verbatim}--> isFunDecl :: Decl -> Bool-> isFunDecl (FunctionDecl _ _ _) = True-> isFunDecl (ExternalDecl _ _ _ _ _) = True-> isFunDecl _ = False--> mkFun :: ModuleIdent -> String -> Ident -> Expression-> mkFun m pre f = Variable (qualifyWith m (liftIdent pre f))--> mkVar :: Ident -> Expression-> mkVar v = Variable (qualify v)--> apply :: Expression -> [Expression] -> Expression-> apply = foldl Apply--> qualBindFun :: ModuleIdent -> Ident -> Type -> ValueEnv -> ValueEnv-> qualBindFun m f ty ->   = qualBindTopEnv "Lift.qualBindFun" f' (Value f' (polyType ty))->   where f' = qualifyWith m f--> unbindFun :: Ident -> ValueEnv -> ValueEnv-> unbindFun = unbindTopEnv--> varType :: ValueEnv -> Ident -> Type-> varType tyEnv v =->   case lookupValue v tyEnv of->     [Value _ (ForAll _ ty)] -> ty->     _ -> internalError ("varType " ++ show v)--> liftIdent :: String -> Ident -> Ident-> liftIdent prefix x =->     renameIdent (mkIdent (prefix ++ (show x))) (uniqueId x)->    --renameIdent (mkIdent (prefix ++ name x ++ show (uniqueId x))) (uniqueId x)--\end{verbatim}
+ src/Modules.hs view
@@ -0,0 +1,453 @@+{- |+    Module      :  $Header$+    Description :  Compilation of a single module+    Copyright   :  (c) 1999 - 2004 Wolfgang Lux+                       2005        Martin Engelke+                       2007        Sebastian Fischer+                       2011 - 2015 Björn Peemöller+                       2016        Jan Tikovsky+                       2016 - 2017 Finn Teegen+                       2018        Kai-Oliver Prott+    License     :  BSD-3-clause++    Maintainer  :  fte@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module controls the compilation of modules.+-}++module Modules+  ( compileModule, loadAndCheckModule, loadModule, checkModule+  , parseModule, checkModuleHeader+  ) where++import qualified Control.Exception as C   (catch, IOException)+import           Control.Monad            (liftM, unless, when)+import           Data.Char                (toUpper)+import qualified Data.Map          as Map (elems, lookup)+import           Data.Maybe               (fromMaybe)+import           System.Directory         (getTemporaryDirectory, removeFile)+import           System.Exit              (ExitCode (..))+import           System.FilePath          (normalise)+import           System.IO+   (IOMode (ReadMode), Handle, hClose, hGetContents, hPutStr, openFile+  , openTempFile)+import           System.Process           (system)++import Curry.Base.Ident+import Curry.Base.Monad+import Curry.Base.SpanInfo+import Curry.Base.Pretty+import Curry.Base.Span+import Curry.FlatCurry.InterfaceEquivalence (eqInterface)+import Curry.Files.Filenames+import Curry.Files.PathUtils+import Curry.Syntax.InterfaceEquivalence+import Curry.Syntax.Utils (shortenModuleAST)++import Base.Messages+import Base.Types++import Env.Interface++-- source representations+import qualified Curry.AbstractCurry as AC+import qualified Curry.FlatCurry     as FC+import qualified Curry.Syntax        as CS+import qualified IL++import Checks+import CompilerEnv+import CompilerOpts+import CondCompile (condCompile)+import Exports+import Generators+import Html.CurryHtml (source2html)+import Imports+import Interfaces (loadInterfaces)+import TokenStream (showTokenStream, showCommentTokenStream)+import Transformations++-- The function 'compileModule' is the main entry-point of this+-- module for compiling a Curry source module. Depending on the command+-- line options, it will emit either FlatCurry code or AbstractCurry code+-- (typed, untyped or with type signatures) for the module.+-- Usually, the first step is to check the module.+-- Then the code is translated into the intermediate+-- language. If necessary, this phase will also update the module's+-- interface file. The resulting code then is written out+-- to the corresponding file.+-- The untyped  AbstractCurry representation is written+-- out directly after parsing and simple checking the source file.+-- The typed AbstractCurry code is written out after checking the module.+--+-- The compiler automatically loads the prelude when compiling any+-- module, except for the prelude itself, by adding an appropriate import+-- declaration to the module.+compileModule :: Options -> ModuleIdent -> FilePath -> CYIO ()+compileModule opts m fn = do+  mdl <- loadAndCheckModule opts m fn+  writeTokens   opts (fst mdl)+  writeComments opts (fst mdl)+  writeParsed   opts mdl+  let qmdl = qual mdl+  writeHtml     opts qmdl+  writeAST      opts (fst  mdl, fmap (const ()) (snd  mdl))+  writeShortAST opts (fst qmdl, fmap (const ()) (snd qmdl))+  mdl' <- expandExports opts mdl+  qmdl' <- dumpWith opts CS.showModule pPrint DumpQualified $ qual mdl'+  writeAbstractCurry opts qmdl'+  -- generate interface file+  let intf = uncurry exportInterface qmdl'+  writeInterface opts (fst mdl') intf+  when withFlat $ do+    ((env, il), mdl'') <- transModule opts qmdl'+    writeFlat opts env (snd mdl'') il+  where+  withFlat = any (`elem` optTargetTypes opts) [ AnnotatedFlatCurry+                                              , TypedFlatCurry+                                              , FlatCurry+                                              ]++loadAndCheckModule :: Options -> ModuleIdent -> FilePath+                   -> CYIO (CompEnv (CS.Module PredType))+loadAndCheckModule opts m fn = do+  ce <- loadModule opts m fn >>= checkModule opts+  warnMessages $ uncurry (warnCheck opts) ce+  return ce++-- ---------------------------------------------------------------------------+-- Loading a module+-- ---------------------------------------------------------------------------++loadModule :: Options -> ModuleIdent -> FilePath+           -> CYIO (CompEnv (CS.Module ()))+loadModule opts m fn = do+  -- parse and check module header+  (toks, mdl) <- parseModule opts m fn+  -- load the imported interfaces into an InterfaceEnv+  let paths = map (addOutDir (optUseOutDir opts) (optOutDir opts))+                  ("." : optImportPaths opts)+  let withPrel = importPrelude opts mdl+  iEnv   <- loadInterfaces paths withPrel+  checkInterfaces opts iEnv+  is     <- importSyntaxCheck iEnv withPrel+  -- add information of imported modules+  cEnv   <- importModules withPrel iEnv is+  return (cEnv { filePath = fn, tokens = toks }, mdl)++parseModule :: Options -> ModuleIdent -> FilePath+            -> CYIO ([(Span, CS.Token)], CS.Module ())+parseModule opts m fn = do+  mbSrc <- liftIO $ readModule fn+  case mbSrc of+    Nothing  -> failMessages [message $ text $ "Missing file: " ++ fn]+    Just src -> do+      ul      <- liftCYM $ CS.unlit fn src+      prepd   <- preprocess (optPrepOpts opts) fn ul+      condC   <- condCompile (optCppOpts opts) fn prepd+      doDump ((optDebugOpts opts) { dbDumpEnv = False })+             (DumpCondCompiled, undefined, condC)+      -- We ignore the warnings issued by the lexer because+      -- they will be issued a second time during parsing.+      spanToks <- liftCYM $ silent $ CS.lexSource fn condC+      ast      <- liftCYM $ CS.parseModule fn condC+      checked  <- checkModuleHeader m fn ast+      return (spanToks, checked)++preprocess :: PrepOpts -> FilePath -> String -> CYIO String+preprocess opts fn src+  | not (ppPreprocess opts) = return src+  | otherwise               = do+    res <- liftIO $ withTempFile $ \ inFn inHdl -> do+      hPutStr inHdl src+      hClose inHdl+      withTempFile $ \ outFn outHdl -> do+        hClose outHdl+        ec <- system $ unwords $+          [ppCmd opts, normalise fn, inFn, outFn] ++ ppOpts opts+        case ec of+          ExitFailure x -> return $ Left [message $ text $+              "Preprocessor exited with exit code " ++ show x]+          ExitSuccess   -> Right `liftM` readFile outFn+    either failMessages ok res++withTempFile :: (FilePath -> Handle -> IO a) -> IO a+withTempFile act = do+  tmp       <- getTemporaryDirectory+  (fn, hdl) <- openTempFile tmp "cymake.curry"+  res       <- act fn hdl+  hClose hdl+  removeFile fn+  return res++checkModuleHeader :: Monad m => ModuleIdent -> FilePath+                  -> CS.Module () -> CYT m (CS.Module ())+checkModuleHeader m fn = checkModuleId m+                       . CS.patchModuleId fn++-- |Check whether the 'ModuleIdent' and the 'FilePath' fit together+checkModuleId :: Monad m => ModuleIdent -> CS.Module () -> CYT m (CS.Module ())+checkModuleId mid m@(CS.Module _ _ _ mid' _ _ _)+  | mid == mid' = ok m+  | otherwise   = failMessages [errModuleFileMismatch mid']++-- An implicit import of the prelude is temporariliy added to the declarations+-- of every module, except for the prelude itself, or when the import is+-- disabled by a compiler option. If no explicit import for the prelude is+-- present, the prelude is imported unqualified,+-- otherwise a qualified import is added.++importPrelude :: Options -> CS.Module () -> CS.Module ()+importPrelude opts m@(CS.Module spi li ps mid es is ds)+    -- the Prelude itself+  | mid == preludeMIdent         = m+    -- disabled by compiler option+  | noImpPrelude                 = m+    -- already imported+  | preludeMIdent `elem` imports = m+    -- let's add it!+  | otherwise                    = CS.Module spi li ps mid es (preludeImp:is) ds+  where+  noImpPrelude = NoImplicitPrelude `elem` optExtensions opts+                 || m `CS.hasLanguageExtension` NoImplicitPrelude+  preludeImp   = CS.ImportDecl NoSpanInfo preludeMIdent+                  False   -- qualified?+                  Nothing -- no alias+                  Nothing -- no selection of types, functions, etc.+  imports      = [imp | (CS.ImportDecl _ imp _ _ _) <- is]++checkInterfaces :: Monad m => Options -> InterfaceEnv -> CYT m ()+checkInterfaces opts iEnv = mapM_ checkInterface (Map.elems iEnv)+  where+  checkInterface intf = do+    let env = importInterfaces intf iEnv+    interfaceCheck opts (env, intf)++importSyntaxCheck :: Monad m => InterfaceEnv -> CS.Module a -> CYT m [CS.ImportDecl]+importSyntaxCheck iEnv (CS.Module _ _ _ _ _ imps _) = mapM checkImportDecl imps+  where+  checkImportDecl (CS.ImportDecl p m q asM is) = case Map.lookup m iEnv of+    Just intf -> CS.ImportDecl p m q asM `liftM` importCheck intf is+    Nothing   -> internalError $ "Modules.importModules: no interface for "+                                    ++ show m++-- ---------------------------------------------------------------------------+-- Checking a module+-- ---------------------------------------------------------------------------++-- TODO: The order of the checks should be improved!+checkModule :: Options -> CompEnv (CS.Module ())+            -> CYIO (CompEnv (CS.Module PredType))+checkModule opts mdl = do+  _   <- dumpCS DumpParsed mdl+  exc <- extensionCheck  opts mdl >>= dumpCS DumpExtensionChecked+  tsc <- typeSyntaxCheck opts exc >>= dumpCS DumpTypeSyntaxChecked+  kc  <- kindCheck       opts tsc >>= dumpCS DumpKindChecked+  sc  <- syntaxCheck     opts kc  >>= dumpCS DumpSyntaxChecked+  pc  <- precCheck       opts sc  >>= dumpCS DumpPrecChecked+  dc  <- deriveCheck     opts pc  >>= dumpCS DumpDeriveChecked+  inc <- instanceCheck   opts dc  >>= dumpCS DumpInstanceChecked+  tc  <- typeCheck       opts inc >>= dumpCS DumpTypeChecked+  ec  <- exportCheck     opts tc  >>= dumpCS DumpExportChecked+  return ec+  where+  dumpCS :: (MonadIO m, Show a) => DumpLevel -> CompEnv (CS.Module a)+         -> m (CompEnv (CS.Module a))+  dumpCS = dumpWith opts CS.showModule pPrint++-- ---------------------------------------------------------------------------+-- Translating a module+-- ---------------------------------------------------------------------------++transModule :: Options -> CompEnv (CS.Module PredType)+            -> CYIO (CompEnv IL.Module, CompEnv (CS.Module Type))+transModule opts mdl = do+  derived    <- dumpCS DumpDerived       $ derive               mdl+  desugared  <- dumpCS DumpDesugared     $ desugar              derived+  dicts      <- dumpCS DumpDictionaries  $ insertDicts    inlDi desugared+  newtypes   <- dumpCS DumpNewtypes      $ removeNewtypes remNT dicts+  simplified <- dumpCS DumpSimplified    $ simplify             newtypes+  lifted     <- dumpCS DumpLifted        $ lift                 simplified+  il         <- dumpIL DumpTranslated    $ ilTrans        remIm lifted+  ilCaseComp <- dumpIL DumpCaseCompleted $ completeCase         il+  return (ilCaseComp, newtypes)+  where+  optOpts = optOptimizations opts+  inlDi = optInlineDictionaries  optOpts+  remIm = optRemoveUnusedImports optOpts+  remNT = optDesugarNewtypes     optOpts+  dumpCS :: Show a => DumpLevel -> CompEnv (CS.Module a)+         -> CYIO (CompEnv (CS.Module a))+  dumpCS = dumpWith opts CS.showModule pPrint+  dumpIL = dumpWith opts IL.showModule IL.ppModule++-- ---------------------------------------------------------------------------+-- Writing output+-- ---------------------------------------------------------------------------++-- The functions \texttt{genFlat} and \texttt{genAbstract} generate+-- flat and abstract curry representations depending on the specified option.+-- If the interface of a modified Curry module did not change, the+-- corresponding file name will be returned within the result of 'genFlat'+-- (depending on the compiler flag "force") and other modules importing this+-- module won't be dependent on it any longer.++writeTokens :: Options -> CompilerEnv -> CYIO ()+writeTokens opts env = when tokTarget $ liftIO $+  writeModule (useSubDir $ tokensName (filePath env))+              (showTokenStream (tokens env))+  where+  tokTarget  = Tokens `elem` optTargetTypes opts+  useSubDir  = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env)++writeComments :: Options -> CompilerEnv -> CYIO ()+writeComments opts env = when tokTarget $ liftIO $+  writeModule (useSubDir $ commentsName (filePath env))+              (showCommentTokenStream $ tokens env)+  where+  tokTarget  = Comments `elem` optTargetTypes opts+  useSubDir  = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env)++-- |Output the parsed 'Module' on request+writeParsed :: Show a => Options -> CompEnv (CS.Module a) -> CYIO ()+writeParsed opts (env, mdl) = when srcTarget $ liftIO $+  writeModule (useSubDir $ sourceRepName (filePath env)) (CS.showModule mdl)+  where+  srcTarget  = Parsed `elem` optTargetTypes opts+  useSubDir  = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env)++writeHtml :: Options -> CompEnv (CS.Module a) -> CYIO ()+writeHtml opts (env, mdl) = when htmlTarget $+  source2html opts (moduleIdent env) (map (\(sp, tok) -> (span2Pos sp, tok)) (tokens env)) mdl+  where htmlTarget = Html `elem` optTargetTypes opts++writeInterface :: Options -> CompilerEnv -> CS.Interface -> CYIO ()+writeInterface opts env intf@(CS.Interface m _ _)+  | optForce opts = outputInterface+  | otherwise     = do+      equal <- liftIO $ C.catch (matchInterface interfaceFile intf)+                        ignoreIOException+      unless equal outputInterface+  where+  ignoreIOException :: C.IOException -> IO Bool+  ignoreIOException _ = return False++  interfaceFile   = interfName (filePath env)+  outputInterface = liftIO $ writeModule+                    (addOutDirModule (optUseOutDir opts) (optOutDir opts) m interfaceFile)+                    (show $ pPrint intf)++matchInterface :: FilePath -> CS.Interface -> IO Bool+matchInterface ifn i = do+  hdl <- openFile ifn ReadMode+  src <- hGetContents hdl+  case runCYMIgnWarn (CS.parseInterface ifn src) of+    Left  _  -> hClose hdl >> return False+    Right i' -> return (i `intfEquiv` fixInterface i')++writeFlat :: Options -> CompilerEnv -> CS.Module Type -> IL.Module -> CYIO ()+writeFlat opts env mdl il = do+  _ <- dumpWith opts show (pPrint . genFlatCurry) DumpTypedFlatCurry (env, afcy)+  when afcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir afcyName) afcy+  when tfcyTarget  $ liftIO $ FC.writeFlatCurry (useSubDir tfcyName)  tfcy+  when fcyTarget $ do+    _ <- dumpWith opts show pPrint DumpFlatCurry (env, fcy)+    liftIO $ FC.writeFlatCurry (useSubDir fcyName) fcy+  writeFlatIntf opts env fcy+  where+  afcy       = genAnnotatedFlatCurry env mdl il+  afcyName   = annotatedFlatName (filePath env)+  afcyTarget = AnnotatedFlatCurry `elem` optTargetTypes opts+  tfcy       = genTypedFlatCurry afcy+  tfcyName   = typedFlatName (filePath env)+  tfcyTarget = TypedFlatCurry `elem` optTargetTypes opts+  fcy        = genFlatCurry afcy+  fcyName    = flatName (filePath env)+  fcyTarget  = FlatCurry `elem` optTargetTypes opts+  useSubDir  = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env)++writeFlatIntf :: Options -> CompilerEnv -> FC.Prog -> CYIO ()+writeFlatIntf opts env prog+  | not (optInterface opts) = return ()+  | optForce opts           = outputInterface+  | otherwise               = do+      mfint <- liftIO $ FC.readFlatInterface targetFile+      let oldInterface = fromMaybe emptyIntf mfint+      when (mfint == mfint) $ return () -- necessary to close file -- TODO+      unless (oldInterface `eqInterface` fint) outputInterface+  where+  targetFile      = flatIntName (filePath env)+  emptyIntf       = FC.Prog "" [] [] [] []+  fint            = genFlatInterface prog+  useSubDir       = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env)+  outputInterface = liftIO $ FC.writeFlatCurry (useSubDir targetFile) fint++writeAbstractCurry :: Options -> CompEnv (CS.Module PredType) -> CYIO ()+writeAbstractCurry opts (env, mdl) = do+  when acyTarget  $ liftIO+                  $ AC.writeCurry (useSubDir $ acyName (filePath env))+                  $ genTypedAbstractCurry env mdl+  when uacyTarget $ liftIO+                  $ AC.writeCurry (useSubDir $ uacyName (filePath env))+                  $ genUntypedAbstractCurry env mdl+  where+  acyTarget  = AbstractCurry        `elem` optTargetTypes opts+  uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts+  useSubDir  = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env)+++writeAST :: Options -> CompEnv (CS.Module ()) -> CYIO ()+writeAST opts (env, mdl) = when astTarget $ liftIO $+  writeModule (useSubDir $ astName (filePath env)) (CS.showModule mdl)+  where+  astTarget  = AST `elem` optTargetTypes opts+  useSubDir  = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env)+++writeShortAST :: Options -> CompEnv (CS.Module ()) -> CYIO ()+writeShortAST opts (env, mdl) = when astTarget $ liftIO $+  writeModule (useSubDir $ shortASTName (filePath env))+              (CS.showModule $ shortenModuleAST mdl)+  where+  astTarget  = ShortAST `elem` optTargetTypes opts+  useSubDir  = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env)+++type Dump = (DumpLevel, CompilerEnv, String)++dumpWith :: MonadIO m+         => Options -> (a -> String) -> (a -> Doc) -> DumpLevel+         -> CompEnv a -> m (CompEnv a)+dumpWith opts rawView view lvl res@(env, mdl) = do+  let str = if dbDumpRaw (optDebugOpts opts) then rawView mdl+                                             else show (view mdl)+  doDump (optDebugOpts opts) (lvl, env, str)+  return res++-- |Translate FlatCurry into the intermediate language 'IL'+-- |The 'dump' function writes the selected information to standard output.+doDump :: MonadIO m => DebugOpts -> Dump -> m ()+doDump opts (level, env, dump)+  = when (level `elem` dbDumpLevels opts) $ liftIO $ do+      putStrLn (heading (capitalize $ lookupHeader dumpLevel) '=')+      when (dbDumpEnv opts) $ do+        putStrLn (heading "Environment" '-')+        putStrLn (showCompilerEnv env (dbDumpAllBindings opts) (dbDumpSimple opts))+      putStrLn (heading "Source Code" '-')+      putStrLn dump+  where+  heading h s = '\n' : h ++ '\n' : replicate (length h) s+  lookupHeader []            = "Unknown dump level " ++ show level+  lookupHeader ((l,_,h):lhs)+    | level == l = h+    | otherwise  = lookupHeader lhs+  capitalize = unwords . map firstUpper . words+  firstUpper ""     = ""+  firstUpper (c:cs) = toUpper c : cs++errModuleFileMismatch :: ModuleIdent -> Message+errModuleFileMismatch mid = posMessage mid $ hsep $ map text+  [ "Module", moduleName mid, "must be in a file"+  , moduleName mid ++ ".(l)curry" ]
− src/Modules.lhs 
@@ -1,700 +0,0 @@--% $Id: Modules.lhs,v 1.84 2004/02/10 17:46:07 wlux Exp $-%-% Copyright (c) 1999-2004, Wolfgang Lux-% See LICENSE for the full license.-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-% March 2007, extensions by Sebastian Fischer (sebf@informatik.uni-kiel.de)-%-\nwfilename{Modules.lhs}-\section{Modules}-This module controls the compilation of modules.--Since this version is only used as a frontend for PAKCS, some of the following -import declarations are commented out-\begin{verbatim}--> module Modules(compileModule,->                importPrelude, patchModuleId,->	         loadInterfaces, transModule,->	         simpleCheckModule, checkModule->	        ) where--> import Text.PrettyPrint.HughesPJ-> import Data.List-> import qualified Data.Map as Map-> import System.IO-> import Data.Maybe-> import Control.Monad--> import Curry.Base.MessageMonad-> import Curry.Base.Position as P-> import Curry.Base.Ident--> import Curry.Files.Filenames-> import Curry.Files.PathUtils--> import Curry.Syntax-> import Curry.Syntax.Utils(isImportDecl)-> import Curry.Syntax.Pretty(ppModule,ppIDecl)-> import Curry.Syntax.ShowModule(showModule)--> import Curry.ExtendedFlat.Type-> import qualified Curry.ExtendedFlat.Type as EF --> import qualified IL.Type as IL-> import IL.CurryToIL(ilTrans)-> import qualified IL.Pretty(ppModule)-> import IL.XML(xmlModule)--> import Base-> import Types-> import KindCheck(kindCheck)-> import SyntaxCheck(syntaxCheck)-> import PrecCheck(precCheck)-> import TypeCheck(typeCheck)-> import WarnCheck(warnCheck)-> import Arity-> import Imports(importInterface,importInterfaceIntf,importUnifyData)-> import Exports(expandInterface,exportInterface)-> import Eval(evalEnv)-> import Qual(qual)-> import Desugar(desugar)-> import Simplify(simplify)-> import Lift(lift)--> import GenFlatCurry (genFlatCurry,genFlatInterface)-> import qualified Curry.AbstractCurry as AC-> import GenAbstractCurry-> import InterfaceCheck-> import CurryEnv--> import CurryCompilerOpts(Options(..),Dump(..))-> import CaseCompletion---> import TypeSubst-> import TopEnv---\end{verbatim}-The function \texttt{compileModule} is the main entry-point of this-module for compiling a Curry source module. Depending on the command-line options it will emit either C code or FlatCurry code (standard -or in XML-representation) or AbtractCurry code (typed, untyped or with type-signatures) for the module. Usually the first step is to-check the module. Then the code is translated into the intermediate-language. If necessary, this phase will also update the module's-interface file. The resulting code then is either written out (in-FlatCurry or XML format) or translated further into C code.-The untyped  AbstractCurry representation is written-out directly after parsing and simple checking the source file. -The typed AbstractCurry code is written out after checking the module.--The compiler automatically loads the prelude when compiling any-module, except for the prelude itself, by adding an appropriate import-declaration to the module. --Since this modified version of the Muenster Curry Compiler is used-as a frontend for PAKCS, all functions for evaluating goals and generating C -code are obsolete and commented out.-\begin{verbatim}--> compileModule :: Options -> FilePath -> IO (Maybe FilePath)-> compileModule opts fn =->   do->     mod <- liftM (importPrelude fn . ok . parseModule likeFlat fn) (readModule fn)->     let m = patchModuleId fn mod->     checkModuleId fn m->     mEnv <- loadInterfaces (importPaths opts) m->     if uacy || src->        then ->          do (tyEnv, tcEnv, aEnv, m', intf, _) <- simpleCheckModule opts mEnv m->             if uacy then genAbstract opts fn tyEnv tcEnv m'->                     else do->                       let outputFile = maybe (sourceRepName fn)->                                              id ->                                              (output opts)->                           outputMod = showModule m'->                       writeModule (writeToSubdir opts) outputFile outputMod->                       return Nothing->        else->          do -- checkModule checks types, and then transModule introduces new->             -- functions (by lambda lifting in 'desugar'). Consequence: The->             -- type of the newly introduced functions are not inferred (hsi)->             (tyEnv, tcEnv, aEnv, m', intf, _) <- checkModule opts mEnv m->             let (il,aEnv',dumps) = transModule fcy False False ->			                         mEnv tyEnv tcEnv aEnv m'->             mapM_ (doDump opts) dumps->	      genCode opts fn mEnv tyEnv tcEnv aEnv' intf m' il->   where acy      = abstract opts->         uacy     = untypedAbstract opts->         fcy      = flat opts->         xml      = flatXml opts->         src      = parseOnly opts->         likeFlat = fcy || xml || acy || uacy || src->	  ->         genCode opts fn mEnv tyEnv tcEnv aEnv intf m il->            | fcy || xml = genFlat opts fn mEnv tyEnv tcEnv aEnv intf m il->            | acy        = genAbstract opts fn tyEnv tcEnv m->            | otherwise  = return Nothing--> loadInterfaces :: [FilePath] -> Module -> IO ModuleEnv-> loadInterfaces paths (Module m _ ds) =->   foldM (loadInterface paths [m]) Map.empty->         [(p,m) | ImportDecl p m _ _ _ <- ds]--> checkModuleId :: Monad m => FilePath -> Module -> m ()-> checkModuleId fn (Module mid _ _)->    | last (moduleQualifiers mid) == takeBaseName fn->      = return ()->    | otherwise->      = error ("module \"" ++ moduleName mid ->	        ++ "\" must be in a file \"" ++ moduleName mid->	        ++ ".curry\"")--> simpleCheckModule :: Options -> ModuleEnv -> Module ->	    -> IO (ValueEnv,TCEnv,ArityEnv,Module,Interface,[WarnMsg])-> simpleCheckModule opts mEnv (Module m es ds) =->   do unless (noWarn opts) (printMessages msgs)->      return (tyEnv'', tcEnv, aEnv'', modul, intf, msgs)->   where (impDs,topDs) = partition isImportDecl ds->         iEnv = foldr bindAlias initIEnv impDs->         (pEnv,tcEnv,tyEnv,aEnv) = importModules mEnv impDs->         msgs = warnCheck m tyEnv impDs topDs->	  withExt = withExtensions opts->         (pEnv',topDs') = precCheck m pEnv ->		           $ syntaxCheck withExt m iEnv aEnv tyEnv tcEnv->			   $ kindCheck m tcEnv topDs->         ds' = impDs ++ qual m tyEnv topDs'->         modul = (Module m es ds') --expandInterface (Module m es ds') tcEnv tyEnv->         (_,tcEnv'',tyEnv'',aEnv'') ->            = qualifyEnv mEnv pEnv' tcEnv tyEnv aEnv->         intf = exportInterface modul pEnv' tcEnv'' tyEnv''--> checkModule :: Options -> ModuleEnv -> Module ->      -> IO (ValueEnv,TCEnv,ArityEnv,Module,Interface,[WarnMsg])-> checkModule opts mEnv (Module m es ds) =->   do unless (noWarn opts) (printMessages msgs)->      when (m == mkMIdent ["field114..."])->           (error (show es))->      return (tyEnv''', tcEnv', aEnv'', modul, intf, msgs)->   where (impDs,topDs) = partition isImportDecl ds->         iEnv = foldr bindAlias initIEnv impDs->         (pEnv,tcEnvI,tyEnvI,aEnv) = importModules mEnv impDs->         tcEnv = if withExtensions opts->	             then fmap (expandRecordTC tcEnvI) tcEnvI->		     else tcEnvI->         lEnv = importLabels mEnv impDs->	  tyEnvL = addImportedLabels m lEnv tyEnvI->	  tyEnv = if withExtensions opts->	             then fmap (expandRecordTypes tcEnv) tyEnvL->		     else tyEnvI->         msgs = warnCheck m tyEnv impDs topDs->	  withExt = withExtensions opts->         -- fre: replaced the argument aEnv by aEnv'' in the->         --      expression below. This fixed a bug that occured->         --      when one imported a module qualified that->         --      exported a function from another module.->         --      However, there is now a cyclic dependecy ->         --      but tests didn't show any problems.->         (pEnv',topDs') = precCheck m pEnv ->		           $ syntaxCheck withExt m iEnv aEnv'' tyEnv tcEnv->			   $ kindCheck m tcEnv topDs->         (tcEnv',tyEnv') = typeCheck m tcEnv tyEnv topDs'->         ds' = impDs ++ qual m tyEnv' topDs'->         modul = expandInterface (Module m es ds') tcEnv' tyEnv'->         (pEnv'',tcEnv'',tyEnv'',aEnv'') ->            = qualifyEnv mEnv pEnv' tcEnv' tyEnv' aEnv->         tyEnvL' = addImportedLabels m lEnv tyEnv''->	  tyEnv''' = if withExtensions opts->	                then fmap (expandRecordTypes tcEnv'') tyEnvL'->		        else tyEnv''->         --tyEnv''' = addImportedLabels m lEnv tyEnv''->         intf = exportInterface modul pEnv'' tcEnv'' tyEnv'''--> transModule :: Bool -> Bool -> Bool -> ModuleEnv -> ValueEnv -> TCEnv->      -> ArityEnv -> Module -> (IL.Module,ArityEnv,[(Dump,Doc)])-> transModule flat debug trusted mEnv tyEnv tcEnv aEnv (Module m es ds) =->     (il',aEnv',dumps)->   where topDs = filter (not . isImportDecl) ds->         evEnv = evalEnv topDs->         (desugared,tyEnv') = desugar tyEnv tcEnv (Module m es topDs)->         (simplified,tyEnv'') = simplify flat tyEnv' evEnv desugared->         (lifted,tyEnv''',evEnv') = lift tyEnv'' evEnv simplified->         aEnv' = bindArities aEnv lifted->         il = ilTrans flat tyEnv''' tcEnv evEnv' lifted->         il' = completeCase mEnv il->         dumps = [(DumpRenamed,ppModule (Module m es ds)),->	           (DumpTypes,ppTypes m (localBindings tyEnv)),->	           (DumpDesugared,ppModule desugared),->                  (DumpSimplified,ppModule simplified),->                  (DumpLifted,ppModule lifted),->                  (DumpIL,IL.Pretty.ppModule il),->	           (DumpCase,IL.Pretty.ppModule il')->	          ]--> qualifyEnv :: ModuleEnv -> PEnv -> TCEnv -> ValueEnv -> ArityEnv->     -> (PEnv,TCEnv,ValueEnv,ArityEnv)-> qualifyEnv mEnv pEnv tcEnv tyEnv aEnv =->   (foldr bindQual pEnv' (localBindings pEnv),->    foldr bindQual tcEnv' (localBindings tcEnv),->    foldr bindGlobal tyEnv' (localBindings tyEnv),->    foldr bindQual aEnv' (localBindings aEnv))->   where (pEnv',tcEnv',tyEnv',aEnv') =->           foldl importInterface initEnvs (Map.toList mEnv)->         importInterface (pEnv,tcEnv,tyEnv,aEnv) (m,ds) =->           importInterfaceIntf (Interface m ds) pEnv tcEnv tyEnv aEnv->         bindQual (_,y) = qualBindTopEnv "Modules.qualifyEnv" (origName y) y->         bindGlobal (x,y)->           | uniqueId x == 0 = bindQual (x,y)->           | otherwise = bindTopEnv "Modules.qualifyEnv" x y--> writeXML :: Bool -> Maybe FilePath -> FilePath -> CurryEnv -> IL.Module -> IO ()-> writeXML sub tfn sfn cEnv il = writeModule sub ofn (showln code)->   where ofn  = fromMaybe (xmlName sfn) tfn->         code = (xmlModule cEnv il)--> writeFlat :: Options -> Maybe FilePath -> FilePath -> CurryEnv -> ModuleEnv ->              -> ValueEnv -> TCEnv -> ArityEnv -> IL.Module -> IO Prog-> writeFlat opts tfn sfn cEnv mEnv tyEnv tcEnv aEnv il->   = writeFlatFile opts (genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv il)->                        (fromMaybe (flatName sfn) tfn)--> writeFlatFile :: Options -> (Prog, [WarnMsg]) -> String -> IO Prog-> writeFlatFile opts@Options{extendedFlat=ext,writeToSubdir=sub} (res,msgs) fname = do->         unless (noWarn opts) (printMessages msgs)->	  if ext then writeExtendedFlat sub fname res->                else writeFlatCurry sub fname res->         return res---> writeTypedAbs :: Bool -> Maybe FilePath -> FilePath -> ValueEnv -> TCEnv -> Module->	           -> IO ()-> writeTypedAbs sub tfn sfn tyEnv tcEnv mod->    = AC.writeCurry sub fname (genTypedAbstract tyEnv tcEnv mod)->  where fname = fromMaybe (acyName sfn) tfn--> writeUntypedAbs :: Bool -> Maybe FilePath -> FilePath -> ValueEnv -> TCEnv  ->	             -> Module -> IO ()-> writeUntypedAbs sub tfn sfn tyEnv tcEnv mod->    = AC.writeCurry sub fname (genUntypedAbstract tyEnv tcEnv mod)->  where fname = fromMaybe (uacyName sfn) tfn--> showln :: Show a => a -> String-> showln x = shows x "\n"--\end{verbatim}--The function \texttt{importModules} brings the declarations of all-imported modules into scope for the current module.-\begin{verbatim}--> importModules :: ModuleEnv -> [Decl] -> (PEnv,TCEnv,ValueEnv,ArityEnv)-> importModules mEnv ds = (pEnv,importUnifyData tcEnv,tyEnv,aEnv)->   where (pEnv,tcEnv,tyEnv,aEnv) = foldl importModule initEnvs ds->         importModule (pEnv,tcEnv,tyEnv,aEnv) (ImportDecl p m q asM is) =->           case Map.lookup m mEnv of->             Just ds -> importInterface p (fromMaybe m asM) q is->                                        (Interface m ds) pEnv tcEnv tyEnv aEnv->             Nothing -> internalError "importModule"->         importModule (pEnv,tcEnv,tyEnv,aEnv) _ = (pEnv,tcEnv,tyEnv,aEnv)--> initEnvs :: (PEnv,TCEnv,ValueEnv,ArityEnv)-> initEnvs = (initPEnv,initTCEnv,initDCEnv,initAEnv)--\end{verbatim}-Unlike unsual identifiers like in functions, types etc. identifiers-of labels are always represented unqualified within the whole context-of compilation. Since the common type environment (type \texttt{ValueEnv})-has some problems with handling imported unqualified identifiers, it is -necessary to add the type information for labels seperately. For this reason-the function \texttt{importLabels} generates an environment containing-all imported labels and the function \texttt{addImportedLabels} adds this-content to a type environment.-\begin{verbatim}--> importLabels :: ModuleEnv -> [Decl] -> LabelEnv-> importLabels mEnv ds = foldl importLabelTypes Map.empty ds->   where->   importLabelTypes lEnv (ImportDecl p m _ asM is) =->     case (Map.lookup m mEnv) of->       Just ds' -> foldl (importLabelType p (fromMaybe m asM) is) lEnv ds'->       Nothing -> internalError "importLabels"->   importLabelTypes lEnv _ = lEnv->		      ->   importLabelType p m is lEnv (ITypeDecl _ r _ (RecordType fs _)) =->     foldl (insertLabelType p m r' (getImportSpec r' is)) lEnv fs->     where r' = qualifyWith m (fromRecordExtId (unqualify r))->   importLabelType _ _ _ lEnv _ = lEnv->			   ->   insertLabelType p m r (Just (ImportTypeAll _)) lEnv ([l],ty) =->     bindLabelType l r (toType [] ty) lEnv->   insertLabelType p m r (Just (ImportTypeWith _ ls)) lEnv ([l],ty)->     | l `elem` ls = bindLabelType l r (toType [] ty) lEnv->     | otherwise   = lEnv->   insertLabelType _ _ _ _ lEnv _ = lEnv->			     ->   getImportSpec r (Just (Importing _ is')) =->     find (isImported (unqualify r)) is'->   getImportSpec r Nothing = Just (ImportTypeAll (unqualify r))->   getImportSpec r _ = Nothing->		->   isImported r (Import r') = r == r'->   isImported r (ImportTypeWith r' _) = r == r'->   isImported r (ImportTypeAll r') = r == r'--> addImportedLabels :: ModuleIdent -> LabelEnv -> ValueEnv -> ValueEnv-> addImportedLabels m lEnv tyEnv = ->   foldr addLabelType tyEnv (concatMap snd (Map.toList lEnv))->   where->   addLabelType (LabelType l r ty) tyEnv = ->     let m' = fromMaybe m (qualidMod r)->     in  importTopEnv m' l ->                      (Label (qualify l) (qualQualify m' r) (polyType ty)) ->	               tyEnv--\end{verbatim}-Fully expand all (imported) record types within the type constructor -environment and the type environment.-Note: the record types for the current module are expanded within the-type check.-\begin{verbatim}--> expandRecordTC :: TCEnv -> TypeInfo -> TypeInfo-> expandRecordTC tcEnv (DataType qid n args) =->   DataType qid n (map (maybe Nothing (Just . (expandData tcEnv))) args)-> expandRecordTC tcEnv (RenamingType qid n (Data id m ty)) =->   RenamingType qid n (Data id m (expandRecords tcEnv ty))-> expandRecordTC tcEnv (AliasType qid n ty) =->   AliasType qid n (expandRecords tcEnv ty)--> expandData :: TCEnv -> Data [Type] -> Data [Type]-> expandData tcEnv (Data id n tys) =->   Data id n (map (expandRecords tcEnv) tys)--> expandRecordTypes :: TCEnv -> ValueInfo -> ValueInfo-> expandRecordTypes tcEnv (DataConstructor qid (ForAllExist n m ty)) =->   DataConstructor qid (ForAllExist n m (expandRecords tcEnv ty))-> expandRecordTypes tcEnv (NewtypeConstructor qid (ForAllExist n m ty)) =->   NewtypeConstructor qid (ForAllExist n m (expandRecords tcEnv ty))-> expandRecordTypes tcEnv (Value qid (ForAll n ty)) =->   Value qid (ForAll n (expandRecords tcEnv ty))-> expandRecordTypes tcEnv (Label qid r (ForAll n ty)) =->   Label qid r (ForAll n (expandRecords tcEnv ty))--> expandRecords :: TCEnv -> Type -> Type-> expandRecords tcEnv (TypeConstructor qid tys) =->   case (qualLookupTC qid tcEnv) of->     [AliasType _ _ rty@(TypeRecord _ _)]->       -> expandRecords tcEnv ->            (expandAliasType (map (expandRecords tcEnv) tys) rty)->     _ -> TypeConstructor qid (map (expandRecords tcEnv) tys)-> expandRecords tcEnv (TypeConstrained tys v) =->   TypeConstrained (map (expandRecords tcEnv) tys) v-> expandRecords tcEnv (TypeArrow ty1 ty2) =->   TypeArrow (expandRecords tcEnv ty1) (expandRecords tcEnv ty2)-> expandRecords tcEnv (TypeRecord fs rv) =->   TypeRecord (map (\ (l,ty) -> (l,expandRecords tcEnv ty)) fs) rv-> expandRecords _ ty = ty--\end{verbatim}-An implicit import of the prelude is added to the declarations of-every module, except for the prelude itself. If no explicit import for-the prelude is present, the prelude is imported unqualified, otherwise-only a qualified import is added.-\begin{verbatim}--> importPrelude :: FilePath -> Module -> Module-> importPrelude fn (Module m es ds) =->   Module m es (if m == preludeMIdent then ds else ds')->   where ids = [decl | decl@(ImportDecl _ _ _ _ _) <- ds]->         ds' = ImportDecl (P.first fn) preludeMIdent->                          (preludeMIdent `elem` map importedModule ids)->                          Nothing Nothing : ds->         importedModule (ImportDecl _ m q asM is) = fromMaybe m asM--\end{verbatim}-If an import declaration for a module is found, the compiler first-checks whether an import for the module is already pending. In this-case the module imports are cyclic which is not allowed in Curry. The-compilation will therefore be aborted. Next, the compiler checks-whether the module has been imported already. If so, nothing needs to-be done, otherwise the interface will be searched in the import paths-and compiled.-\begin{verbatim}--> loadInterface :: [FilePath] -> [ModuleIdent] -> ModuleEnv ->->     (Position,ModuleIdent) -> IO ModuleEnv-> loadInterface paths ctxt mEnv (p,m)->   | m `elem` ctxt = errorAt p (cyclicImport m (takeWhile (/= m) ctxt))->   | isLoaded m mEnv = return mEnv->   | otherwise =->       lookupInterface paths m >>=->       maybe (errorAt p (interfaceNotFound m))->             (compileInterface paths ctxt mEnv m)->   where isLoaded m mEnv = maybe False (const True) (Map.lookup m mEnv)--\end{verbatim}-After reading an interface, all imported interfaces are recursively-loaded and entered into the interface's environment. There is no need-to check FlatCurry-Interfaces, since these files contain automaticaly-generated FlatCurry terms (type \texttt{Prog}).-\begin{verbatim}--> compileInterface :: [FilePath] -> [ModuleIdent] -> ModuleEnv -> ModuleIdent->                  -> FilePath -> IO ModuleEnv-> compileInterface paths ctxt mEnv m fn =->   do->     mintf <- readFlatInterface fn->     let intf = fromMaybe (errorAt (P.first fn) (interfaceNotFound m)) mintf->         (Prog mod _ _ _ _) = intf->         m' = mkMIdent [mod]->     unless (m' == m) (errorAt (P.first fn) (wrongInterface m m'))->     mEnv' <- loadFlatInterfaces paths ctxt mEnv intf->     return (bindFlatInterface intf mEnv')--> --loadIntfInterfaces :: [FilePath] -> [ModuleIdent] -> ModuleEnv -> Interface-> --                   -> IO ModuleEnv-> --loadIntfInterfaces paths ctxt mEnv (Interface m ds) =-> --  foldM (loadInterface paths (m:ctxt)) mEnv [(p,m) | IImportDecl p m <- ds]---> loadFlatInterfaces :: [FilePath] -> [ModuleIdent] -> ModuleEnv -> Prog->                    -> IO ModuleEnv-> loadFlatInterfaces paths ctxt mEnv (Prog m is _ _ _) =->   foldM (loadInterface paths ((mkMIdent [m]):ctxt)) ->         mEnv ->         (map (\i -> (p, mkMIdent [i])) is)->  where p = P.first m---Interface files are updated by the Curry builder when necessary.-(see module \texttt{CurryBuilder}).--\end{verbatim}-The \texttt{doDump} function writes the selected information to the-standard output.-\begin{verbatim}--> doDump :: Options -> (Dump,Doc) -> IO ()-> doDump opts (d,x) =->   when (d `elem` dump opts)->        (print (text hd $$ text (replicate (length hd) '=') $$ x))->   where hd = dumpHeader d--> dumpHeader :: Dump -> String-> dumpHeader DumpRenamed = "Module after renaming"-> dumpHeader DumpTypes = "Types"-> dumpHeader DumpDesugared = "Source code after desugaring"-> dumpHeader DumpSimplified = "Source code after simplification"-> dumpHeader DumpLifted = "Source code after lifting"-> dumpHeader DumpIL = "Intermediate code"-> dumpHeader DumpCase = "Intermediate code after case simplification"---\end{verbatim}-The functions \texttt{genFlat} and \texttt{genAbstract} generate-flat and abstract curry representations depending on the specified option.-If the interface of a modified Curry module did not change, the corresponding -file name will be returned within the result of \texttt{genFlat} (depending-on the compiler flag "force") and other modules importing this module won't-be dependent on it any longer.-\begin{verbatim}--> genFlat :: Options -> FilePath -> ModuleEnv -> ValueEnv -> TCEnv -> ArityEnv ->            -> Interface -> Module -> IL.Module -> IO (Maybe FilePath)-> genFlat opts fname mEnv tyEnv tcEnv aEnv intf mod il->   | flat opts->     = do writeFlat opts Nothing fname cEnv mEnv tyEnv tcEnv aEnv il->          let (flatInterface,intMsgs) = genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv il->          if force opts->            then ->              do writeInterface flatInterface intMsgs->                 return Nothing->            else ->               do mfint <- readFlatInterface fintName->                  let flatIntf = fromMaybe emptyIntf mfint->                  if mfint == mfint  -- necessary to close the file 'fintName'->                        && not (interfaceCheck flatIntf flatInterface)->                     then ->                        do writeInterface flatInterface intMsgs->                           return Nothing->                     else return Nothing->   | flatXml opts->     = writeXML (writeToSubdir opts) (output opts) fname cEnv il >> ->       return Nothing->   | otherwise->     = internalError "@Modules.genFlat: illegal option"->  where->    fintName = flatIntName fname->    cEnv = curryEnv mEnv tcEnv intf mod->    emptyIntf = Prog "" [] [] [] []->    writeInterface intf msgs = do->          unless (noWarn opts) (printMessages msgs)->          writeFlatCurry (writeToSubdir opts) fintName intf---> genAbstract :: Options -> FilePath  -> ValueEnv -> TCEnv -> Module ->                -> IO (Maybe FilePath)-> genAbstract opts@Options{writeToSubdir=sub} fname tyEnv tcEnv mod->    | abstract opts->      = do writeTypedAbs sub Nothing fname tyEnv tcEnv mod ->           return Nothing->    | untypedAbstract opts->      = do writeUntypedAbs sub Nothing fname tyEnv tcEnv mod->           return Nothing->    | otherwise->      = internalError "@Modules.genAbstract: illegal option"--> printMessages :: [WarnMsg] -> IO ()-> printMessages []   = return ()-> printMessages msgs = hPutStrLn stderr $ unlines $ map showWarning msgs--\end{verbatim}-The function \texttt{ppTypes} is used for pretty-printing the types-from the type environment.-\begin{verbatim}--> ppTypes :: ModuleIdent -> [(Ident,ValueInfo)] -> Doc-> ppTypes m = vcat . map (ppIDecl . mkDecl) . filter (isValue . snd)->   where mkDecl (v,Value _ (ForAll _ ty)) =->           IFunctionDecl undefined (qualify v) (arrowArity ty) ->		      (fromQualType m ty)->         isValue (DataConstructor _ _) = False->         isValue (NewtypeConstructor _ _) = False->         isValue (Value _ _) = True->         isValue (Label _ _ _) = False---\end{verbatim}-A module which doesn't contain a \texttt{module ... where} declaration-obtains its filename as module identifier (unlike the definition in-Haskell and original MCC where a module obtains \texttt{main}).-\begin{verbatim}--> patchModuleId :: FilePath -> Module -> Module-> patchModuleId fn (Module mid mexports decls)->    | (moduleName mid) == "main"->      = Module (mkMIdent [takeBaseName fn]) mexports decls->    | otherwise->      = Module mid mexports decls---\end{verbatim}-Error functions.-\begin{verbatim}--> interfaceNotFound :: ModuleIdent -> String-> interfaceNotFound m = "Interface for module " ++ moduleName m ++ " not found"--> cyclicImport :: ModuleIdent -> [ModuleIdent] -> String-> cyclicImport m [] = "Recursive import for module " ++ moduleName m-> cyclicImport m ms =->   "Cyclic import dependency between modules " ++ moduleName m ++->     modules "" ms->   where modules comma [m] = comma ++ " and " ++ moduleName m->         modules _ (m:ms) = ", " ++ moduleName m ++ modules "," ms--> wrongInterface :: ModuleIdent -> ModuleIdent -> String-> wrongInterface m m' =->   "Expected interface for " ++ show m ++ " but found " ++ show m'--\end{verbatim}-----> bindFlatInterface :: Prog -> ModuleEnv -> ModuleEnv-> bindFlatInterface (Prog m imps ts fs os)->    = Map.insert (mkMIdent [m])->      ((map genIImportDecl imps)->       ++ (map genITypeDecl ts')->       ++ (map genIFuncDecl fs)->       ++ (map genIOpDecl os))->  where->  genIImportDecl :: String -> IDecl->  genIImportDecl imp = IImportDecl pos (mkMIdent [imp])->->  genITypeDecl :: TypeDecl -> IDecl->  genITypeDecl (Type qn _ is cs)->     | recordExt `isPrefixOf` localName qn->       = ITypeDecl pos->                   (genQualIdent qn)->	            (map (genVarIndexIdent "a") is)->	            (RecordType (map genLabeledType cs) Nothing)->     | otherwise->       = IDataDecl pos ->                   (genQualIdent qn) ->                   (map (genVarIndexIdent "a") is) ->                   (map (Just . genConstrDecl) cs)->  genITypeDecl (TypeSyn qn _ is t)->     = ITypeDecl pos->                 (genQualIdent qn)->                 (map (genVarIndexIdent "a") is)->                 (genTypeExpr t)->->  genIFuncDecl :: FuncDecl -> IDecl->  genIFuncDecl (Func qn a _ t _) ->     = IFunctionDecl pos (genQualIdent qn) a (genTypeExpr t)->->  genIOpDecl :: OpDecl -> IDecl->  genIOpDecl (Op qn f p) = IInfixDecl pos (genInfix f) p  (genQualIdent qn)->->  genConstrDecl :: ConsDecl -> ConstrDecl->  genConstrDecl (Cons qn _ _ ts)->     = ConstrDecl pos [] (mkIdent (localName qn)) (map genTypeExpr ts)->->  genLabeledType :: EF.ConsDecl -> ([Ident],Curry.Syntax.TypeExpr)->  genLabeledType (Cons qn _ _ [t])->     = ([renameLabel (fromLabelExtId (mkIdent $ localName qn))], genTypeExpr t)->->  genTypeExpr :: EF.TypeExpr -> Curry.Syntax.TypeExpr->  genTypeExpr (TVar i)->     = VariableType (genVarIndexIdent "a" i)->  genTypeExpr (FuncType t1 t2) ->     = ArrowType (genTypeExpr t1) (genTypeExpr t2)->  genTypeExpr (TCons qn ts) ->     = ConstructorType (genQualIdent qn) (map genTypeExpr ts)->->  genInfix :: EF.Fixity -> Infix->  genInfix EF.InfixOp  = Infix->  genInfix EF.InfixlOp = InfixL->  genInfix EF.InfixrOp = InfixR->->  genQualIdent :: EF.QName -> QualIdent->  genQualIdent EF.QName{modName=mod,localName=name} = ->    qualifyWith (mkMIdent [mod]) (mkIdent name)->->  genVarIndexIdent :: String -> Int -> Ident->  genVarIndexIdent v i = mkIdent (v ++ show i)->->  isSpecialPreludeType :: TypeDecl -> Bool->  isSpecialPreludeType (Type EF.QName{modName=mod,localName=name} _ _ _) ->     = (name == "[]" || name == "()") && mod == "Prelude"->  isSpecialPreludeType _ = False->->  pos = P.first m->  ts' = filter (not . isSpecialPreludeType) ts-----\end{verbatim}-The label environment is used to store information of labels.-Unlike unsual identifiers like in functions, types etc. identifiers-of labels are always represented unqualified. Since the common type -environment (type \texttt{ValueEnv}) has some problems with handling -imported unqualified identifiers, it is necessary to process the type -information for labels seperately.-\begin{verbatim}--> data LabelInfo = LabelType Ident QualIdent Type deriving Show--> type LabelEnv = Map.Map Ident [LabelInfo]--> bindLabelType :: Ident -> QualIdent -> Type -> LabelEnv -> LabelEnv-> bindLabelType l r ty = Map.insertWith (++) l [LabelType l r ty]-
− src/NestEnv.lhs 
@@ -1,77 +0,0 @@--% $Id: NestEnv.lhs,v 1.11 2003/10/04 17:04:23 wlux Exp $-%-% Copyright (c) 1999-2003, Wolfgang Lux-% See LICENSE for the full license.-%-\nwfilename{NestEnv.lhs}-\subsection{Nested Environments}-The \texttt{NestEnv} environment type extends top-level environments-(see section~\ref{sec:toplevel-env}) to manage nested scopes. Local-scopes allow only for a single, unambiguous definition.--As a matter of convenience, the module \texttt{TopEnv} is exported by-the module \texttt{NestEnv}.  Thus, only the latter needs to be-imported.-\begin{verbatim}--> module NestEnv(module TopEnv, NestEnv, bindNestEnv,qualBindNestEnv,->                lookupNestEnv,qualLookupNestEnv,->                toplevelEnv,globalEnv,nestEnv) where--> import qualified Data.Map as Map--> import Curry.Base.Ident--> import 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)--> bindNestEnv :: Ident -> a -> NestEnv a -> NestEnv a-> bindNestEnv x y (GlobalEnv env) ->   = GlobalEnv (bindTopEnv "NestEnv.bindNestEnv" x y env)-> bindNestEnv x y (LocalEnv genv env) =->   case Map.lookup x env of->     Just _ -> error "internal error: bindNestEnv"->     Nothing -> LocalEnv genv (Map.insert x y env)--> qualBindNestEnv :: QualIdent -> a -> NestEnv a -> NestEnv a-> qualBindNestEnv x y (GlobalEnv env) ->   = GlobalEnv (qualBindTopEnv "NestEnv.qualBindNestEnv" x y env)-> qualBindNestEnv x y (LocalEnv genv env)->   | isQualified x = error "internal error: qualBindNestEnv"->   | otherwise =->       case Map.lookup x' env of->         Just _ -> error "internal error: qualBindNestEnv"->         Nothing -> LocalEnv genv (Map.insert x' y 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--> toplevelEnv :: NestEnv a -> TopEnv a-> toplevelEnv (GlobalEnv env) = env-> toplevelEnv (LocalEnv genv _) = toplevelEnv genv--> globalEnv :: TopEnv a -> NestEnv a-> globalEnv = GlobalEnv--> nestEnv :: NestEnv a -> NestEnv a-> nestEnv env = LocalEnv env Map.empty--\end{verbatim}
− src/OldScopeEnv.hs 
@@ -1,165 +0,0 @@-module OldScopeEnv (ScopeEnv,-		    newScopeEnv,-		    insertIdent, getIdentLevel,-		    isVisible, isDeclared,-		    beginScope, endScope,-		    getLevel,-		    genIdent, genIdentList) where--import Data.Maybe-import qualified Data.Map as Map--import Curry.Base.Ident-------------------------------------------------------------------------------------- Type for representing an environment containing identifiers in several--- scope levels-type ScopeEnv = (IdEnv, [IdEnv], Int)------------------------------------------------------------------------------------- Generates a new instance of a scope table-newScopeEnv :: ScopeEnv-newScopeEnv = (Map.empty, [], 0)----- Inserts an identifier into the current level of the scope environment-insertIdent :: Ident -> ScopeEnv -> ScopeEnv-insertIdent ident (topleveltab, leveltabs, level)-   = case leveltabs of-       (lt:lts) -> (topleveltab, (insertId level ident lt):lts, level)-       []       -> ((insertId level ident topleveltab), [], 0)----- Returns the declaration level of an identifier if it exists-getIdentLevel :: Ident -> ScopeEnv -> Maybe Int-getIdentLevel ident (topleveltab, leveltabs, _)-   = case leveltabs of-       (lt:_) -> maybe (getIdLevel ident topleveltab) Just (getIdLevel ident lt)-       []     -> getIdLevel ident topleveltab----- Checks whether the specified identifier is visible in the current scope--- (i.e. checks whether the identifier occurs in the scope environment)-isVisible :: Ident -> ScopeEnv -> Bool-isVisible ident (topleveltab, leveltabs, _)-   = case leveltabs of-       (lt:_) -> idExists ident lt || idExists ident topleveltab-       []     -> idExists ident topleveltab----- Checks whether the specified identifier is declared in the--- current scope (i.e. checks whether the identifier occurs in the--- current level of the scope environment)-isDeclared :: Ident -> ScopeEnv -> Bool-isDeclared ident (topleveltab, leveltabs, level)-   = case leveltabs of-       (lt:_) -> maybe False ((==) level) (getIdLevel ident lt)-       []     -> maybe False ((==) 0) (getIdLevel ident topleveltab)----- Increases the level of the scope.-beginScope :: ScopeEnv -> ScopeEnv-beginScope (topleveltab, leveltabs, level)-   = case leveltabs of-       (lt:lts) -> (topleveltab, (lt:lt:lts), level + 1)-       []       -> (topleveltab, [Map.empty], 1)----- Decreases the level of the scope. Identifier from higher levels--- will be lost.-endScope :: ScopeEnv -> ScopeEnv-endScope (topleveltab, leveltabs, level)-   = case leveltabs of-       (_:lts) -> (topleveltab, lts, level - 1)-       []      -> (topleveltab, [], 0)----- Returns the level of the current scope. Top level is 0-getLevel :: ScopeEnv -> Int-getLevel (_, _, level) = level----- Generates a new identifier for the specified name. The new identifier is --- unique within the current scope. If no identifier can be generated for --- 'name' then 'Nothing' will be returned-genIdent :: String -> ScopeEnv -> Maybe Ident-genIdent name (topleveltab, leveltabs, _)-   = case leveltabs of-       (lt:_) -> genId name lt-       []     -> genId name topleveltab----- Generates a list of new identifiers where each identifier has--- the prefix 'name' followed by  an index (i.e. "var3" if 'name' was "var").--- All returned identifiers are unique within the current scope.-genIdentList :: Int -> String -> ScopeEnv -> [Ident]-genIdentList size name scopeenv = p_genIdentList size name scopeenv 0- where-   p_genIdentList s n env i-      | s == 0 -	= []-      | otherwise-	= maybe (p_genIdentList s n env (i + 1))-	        (\ident -> ident:(p_genIdentList (s - 1) -				                 n -				                 (insertIdent ident env) -				                 (i + 1)))-		(genIdent (n ++ (show i)) env)---------------------------------------------------------------------------------------------------------------------------------------------------------------------- Private declarations...--type IdEnv = Map.Map IdRep Int--data IdRep = Name String | Index Int deriving (Eq, Ord)----------------------------------------------------------------------------------------insertId :: Int -> Ident -> IdEnv -> IdEnv-insertId level ident env-   = Map.insert (Name (name ident)) -             level -	     (Map.insert (Index (uniqueId ident)) level env)------idExists :: Ident -> IdEnv -> Bool-idExists ident env = indexExists (uniqueId ident) env------getIdLevel :: Ident -> IdEnv -> Maybe Int-getIdLevel ident env = Map.lookup (Index (uniqueId ident)) env------genId n env-   | nameExists n env = Nothing-   | otherwise        = Just (p_genId (mkIdent n) 0)- where-   p_genId ident index-      | indexExists index env = p_genId ident (index + 1)-      | otherwise             = renameIdent ident index------nameExists :: String -> IdEnv -> Bool-nameExists name env = isJust (Map.lookup (Name name) env)------indexExists :: Int -> IdEnv -> Bool-indexExists index env = isJust (Map.lookup (Index index) env)------------------------------------------------------------------------------------------------------------------------------------------------------------------
− src/PatchPrelude.hs 
@@ -1,40 +0,0 @@-module PatchPrelude where---import Curry.ExtendedFlat.Type----- the prelude has to be extended by data declarations for list and tuples--prelude = "Prelude"--patchPreludeFCY :: Prog -> Prog-patchPreludeFCY (Prog name imports types funcs ops)-   | name == prelude-     = Prog name [] (prelude_types_fcy ++ types) funcs ops-   | otherwise-     = Prog name imports types funcs ops--prelude_types_fcy :: [TypeDecl]-prelude_types_fcy =-  let unit = mkQName (prelude,"()")-      nil  = mkQName (prelude,"[]") in-  [Type unit Public [] [(Cons unit 0 Public [])],-   Type nil Public [0] -        [Cons nil 0 Public [],-         Cons (mkQName (prelude,":")) 2 Public -              [TVar 0, TCons nil [TVar 0]]]] ++-  map tupleType [2..maxTupleArity]--tupleType ar = -  let tuplecons = mkQName (prelude,"("++take (ar-1) (repeat ',')++")") in-  Type tuplecons Public [0..ar-1]-       [Cons tuplecons ar Public (map TVar [0..ar-1])]---- Maximal arity of tuples:-maxTupleArity = 15-------------------------------------------------------------------------------------------------------------------------------------------------------------------
− src/PrecCheck.lhs 
@@ -1,461 +0,0 @@--% $Id: PrecCheck.lhs,v 1.21 2004/02/15 22:10:34 wlux Exp $-%-% Copyright (c) 2001-2004, Wolfgang Lux-% See LICENSE for the full license.-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-%-\nwfilename{PrecCheck.lhs}-\section{Checking Precedences of Infix Operators}-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.-\begin{verbatim}--> module PrecCheck(precCheck) where--> import Data.List--> import Curry.Base.Position-> import Curry.Base.Ident-> import Curry.Syntax-> import Curry.Syntax.Utils--> import Base--\end{verbatim}-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.-\begin{verbatim}--> bindPrecs :: ModuleIdent -> [Decl] -> PEnv -> PEnv-> bindPrecs m ds pEnv =->   case findDouble ops of->     Nothing ->->       case [ op | op <- ops, op `notElem` bvs] of->         [] -> foldr bindPrec pEnv fixDs->         op : _ -> errorAt' (undefinedOperator op)->     Just op -> errorAt' (duplicatePrecedence op)->   where (fixDs,nonFixDs) = partition isInfixDecl ds->         bvs = concatMap boundValues nonFixDs->         ops = [ op | InfixDecl p _ _ ops <- fixDs, op <- ops]->         bindPrec (InfixDecl _ fix pr ops) pEnv->           | p == defaultP = pEnv->           | otherwise = foldr (flip (bindP m) p) pEnv ops->           where p = OpPrec fix pr--> boundValues :: Decl -> [Ident]-> boundValues (DataDecl _ _ _ cs) = map constr cs->   where constr (ConstrDecl _ _ c _) = c->         constr (ConOpDecl _ _ _ op _) = op-> boundValues (NewtypeDecl _ _ _ (NewConstrDecl _ _ c _)) = [c]-> boundValues (FunctionDecl _ f _) = [f]-> boundValues (ExternalDecl _ _ _ f _) = [f]-> boundValues (FlatExternalDecl _ fs) = fs-> boundValues (PatternDecl _ t _) = bv t-> boundValues (ExtraVariables _ vs) = vs-> boundValues _ = []--\end{verbatim}-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.-\begin{verbatim}--> precCheck :: ModuleIdent -> PEnv -> [Decl] -> (PEnv,[Decl])-> precCheck = checkDecls--> checkDecls :: ModuleIdent -> PEnv -> [Decl] -> (PEnv,[Decl])-> checkDecls m pEnv ds = pEnv' `seq` (pEnv',ds')->   where pEnv' = bindPrecs m ds pEnv->         ds' = map (checkDecl m pEnv') ds--> checkDecl :: ModuleIdent -> PEnv -> Decl -> Decl-> checkDecl m pEnv (FunctionDecl p f eqs) =->   FunctionDecl p f (map (checkEqn m pEnv) eqs)-> checkDecl m pEnv (PatternDecl p t rhs) =->   PatternDecl p (checkConstrTerm pEnv t) (checkRhs m pEnv rhs)-> checkDecl _ _ d = d--> checkEqn :: ModuleIdent -> PEnv -> Equation -> Equation-> checkEqn m pEnv (Equation p lhs rhs) =->   Equation p (checkLhs pEnv lhs) (checkRhs m pEnv rhs)--> checkLhs :: PEnv -> Lhs -> Lhs-> checkLhs pEnv (FunLhs f ts) = FunLhs f (map (checkConstrTerm pEnv) ts)-> checkLhs pEnv (OpLhs t1 op t2) = t1' `seq` t2' `seq` OpLhs t1' op t2'->   where t1' = checkOpL pEnv op (checkConstrTerm pEnv t1)->         t2' = checkOpR pEnv op (checkConstrTerm pEnv t2)-> checkLhs pEnv (ApLhs lhs ts) =->   ApLhs (checkLhs pEnv lhs) (map (checkConstrTerm pEnv) ts)--> checkConstrTerm :: PEnv -> ConstrTerm -> ConstrTerm-> checkConstrTerm _ (LiteralPattern l) = LiteralPattern l-> checkConstrTerm _ (NegativePattern op l) = NegativePattern op l-> checkConstrTerm _ (VariablePattern v) = VariablePattern v-> checkConstrTerm pEnv (ConstructorPattern c ts) =->   ConstructorPattern c (map (checkConstrTerm pEnv) ts)-> checkConstrTerm pEnv (InfixPattern t1 op t2) =->   fixPrecT pEnv InfixPattern->	 (checkConstrTerm pEnv t1) op (checkConstrTerm pEnv t2)-> checkConstrTerm pEnv (ParenPattern t) =->   ParenPattern (checkConstrTerm pEnv t)-> checkConstrTerm pEnv (TuplePattern p ts) =->   TuplePattern p (map (checkConstrTerm pEnv) ts)-> checkConstrTerm pEnv (ListPattern p ts) =->   ListPattern p (map (checkConstrTerm pEnv) ts)-> checkConstrTerm pEnv (AsPattern v t) =->   AsPattern v (checkConstrTerm pEnv t)-> checkConstrTerm pEnv (LazyPattern p t) =->   LazyPattern p (checkConstrTerm pEnv t)-> checkConstrTerm pEnv (FunctionPattern f ts) =->   FunctionPattern f (map (checkConstrTerm pEnv) ts)-> checkConstrTerm pEnv (InfixFuncPattern t1 op t2) =->   fixPrecT pEnv InfixFuncPattern ->	 (checkConstrTerm pEnv t1) op (checkConstrTerm pEnv t2)-> checkConstrTerm pEnv (RecordPattern fs r) =->   RecordPattern (map (checkFieldPattern pEnv) fs)->	          (maybe Nothing (Just . checkConstrTerm pEnv) r)--> checkFieldPattern :: PEnv -> Field ConstrTerm -> Field ConstrTerm-> checkFieldPattern pEnv (Field p label patt) =->     Field p label (checkConstrTerm pEnv patt)--> checkRhs :: ModuleIdent -> PEnv -> Rhs -> Rhs-> checkRhs m pEnv (SimpleRhs p e ds) = SimpleRhs p (checkExpr m pEnv' e) ds'->   where (pEnv',ds') = checkDecls m pEnv ds-> checkRhs m pEnv (GuardedRhs es ds) =->   GuardedRhs (map (checkCondExpr m pEnv') es) ds'->   where (pEnv',ds') = checkDecls m pEnv ds--> checkCondExpr :: ModuleIdent -> PEnv -> CondExpr -> CondExpr-> checkCondExpr m pEnv (CondExpr p g e) =->   CondExpr p (checkExpr m pEnv g) (checkExpr m pEnv e)--> checkExpr :: ModuleIdent -> PEnv -> Expression -> Expression-> checkExpr _ _ (Literal l) = Literal l-> checkExpr _ _ (Variable v) = Variable v-> checkExpr _ _ (Constructor c) = Constructor c-> checkExpr m pEnv (Paren e) = Paren (checkExpr m  pEnv e)-> checkExpr m pEnv (Typed e ty) = Typed (checkExpr m  pEnv e) ty-> checkExpr m pEnv (Tuple p es) = Tuple p (map (checkExpr m  pEnv) es)-> checkExpr m pEnv (List p es) = List p (map (checkExpr m  pEnv) es)-> checkExpr m pEnv (ListCompr p e qs) = ListCompr p (checkExpr m  pEnv' e) qs'->   where (pEnv',qs') = mapAccumL (checkStmt m ) pEnv qs-> checkExpr m pEnv (EnumFrom e) = EnumFrom (checkExpr m pEnv e)-> checkExpr m pEnv (EnumFromThen e1 e2) =->   EnumFromThen (checkExpr m pEnv e1) (checkExpr m pEnv e2)-> checkExpr m pEnv (EnumFromTo e1 e2) =->   EnumFromTo (checkExpr m pEnv e1) (checkExpr m pEnv e2)-> checkExpr m pEnv (EnumFromThenTo e1 e2 e3) =->   EnumFromThenTo (checkExpr m pEnv e1)->                  (checkExpr m pEnv e2)->                  (checkExpr m pEnv e3)-> checkExpr m pEnv (UnaryMinus op e) = UnaryMinus op (checkExpr m pEnv e)-> checkExpr m pEnv (Apply e1 e2) =->   Apply (checkExpr m pEnv e1) (checkExpr m pEnv e2)-> checkExpr m pEnv (InfixApply e1 op e2) =->   fixPrec pEnv (checkExpr m pEnv e1) op (checkExpr m pEnv e2)-> checkExpr m pEnv (LeftSection e op) =->   checkLSection pEnv op (checkExpr m pEnv e)-> checkExpr m pEnv (RightSection op e) =->   checkRSection pEnv op (checkExpr m pEnv e)-> checkExpr m pEnv (Lambda r ts e) =->   Lambda r (map (checkConstrTerm pEnv) ts) (checkExpr m pEnv e)-> checkExpr m pEnv (Let ds e) = Let ds' (checkExpr m pEnv' e)->   where (pEnv',ds') = checkDecls m pEnv ds-> checkExpr m pEnv (Do sts e) = Do sts' (checkExpr m pEnv' e)->   where (pEnv',sts') = mapAccumL (checkStmt m ) pEnv sts-> checkExpr m pEnv (IfThenElse r e1 e2 e3) =->   IfThenElse r (checkExpr m pEnv e1)->              (checkExpr m pEnv e2)->              (checkExpr m pEnv e3)-> checkExpr m pEnv (Case r e alts) =->   Case r (checkExpr m pEnv e) (map (checkAlt m pEnv) alts)-> checkExpr m pEnv (RecordConstr fs) =->   RecordConstr (map (checkFieldExpr m pEnv) fs)-> checkExpr m pEnv (RecordSelection e label) =->   RecordSelection (checkExpr m pEnv e) label-> checkExpr m pEnv (RecordUpdate fs e) =->   RecordUpdate (map (checkFieldExpr m pEnv) fs) (checkExpr m pEnv e)--> checkFieldExpr :: ModuleIdent -> PEnv -> Field Expression -> Field Expression-> checkFieldExpr m pEnv (Field p label e) =->   Field p label (checkExpr m  pEnv e)--> checkStmt :: ModuleIdent -> PEnv -> Statement -> (PEnv,Statement)-> checkStmt m pEnv (StmtExpr p e) = (pEnv,StmtExpr p (checkExpr m pEnv e))-> checkStmt m pEnv (StmtDecl ds) = pEnv' `seq` (pEnv',StmtDecl ds')->   where (pEnv',ds') = checkDecls m pEnv ds-> checkStmt m pEnv (StmtBind p t e) =->   (pEnv,StmtBind p (checkConstrTerm pEnv t) (checkExpr m pEnv e))--> checkAlt :: ModuleIdent -> PEnv -> Alt -> Alt-> checkAlt m pEnv (Alt p t rhs) =->   Alt p (checkConstrTerm pEnv t) (checkRhs m pEnv rhs)--\end{verbatim}-The functions \texttt{fixPrec}, \texttt{fixUPrec}, and-\texttt{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. \emph{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 \texttt{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-\texttt{fixUPrec}. In any case, the function \texttt{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-\texttt{fixPrec} is called.-\begin{verbatim}--> fixPrec :: PEnv -> Expression -> InfixOp -> Expression->         -> Expression-> fixPrec pEnv (UnaryMinus uop e1) op e2->   | pr < 6 || pr == 6 && fix == InfixL =->       fixRPrec pEnv (UnaryMinus uop e1) op e2->   | pr > 6 = fixUPrec pEnv uop e1 op e2->   | otherwise = errorAt' $ ambiguousParse "unary" (qualify uop) (opName op)->   where OpPrec fix pr = opPrec op pEnv-> fixPrec pEnv e1 op e2 = fixRPrec pEnv e1 op e2--> fixUPrec :: PEnv -> Ident -> Expression -> InfixOp -> Expression->          -> Expression-> fixUPrec pEnv uop  _ op (UnaryMinus _ _) =->   errorAt' $ ambiguousParse "operator" (opName op) (qualify uop)-> fixUPrec pEnv uop e1 op1 (InfixApply e2 op2 e3)->   | pr2 < 6 || pr2 == 6 && fix2 == InfixL =->       InfixApply (fixUPrec pEnv uop e1 op1 e2) op2 e3->   | pr2 > 6 = UnaryMinus uop (fixRPrec pEnv e1 op1 (InfixApply e2 op2 e3))->   | otherwise = errorAt' $ ambiguousParse "unary" (qualify uop) (opName op2)->   where OpPrec fix2 pr2 = opPrec op2 pEnv-> fixUPrec _ uop e1 op e2 = UnaryMinus uop (InfixApply e1 op e2)--> fixRPrec :: PEnv -> Expression -> InfixOp -> Expression->          -> Expression-> fixRPrec pEnv e1 op (UnaryMinus uop e2)->   | pr < 6 = InfixApply e1 op (UnaryMinus uop e2)->   | otherwise =->       errorAt' $ ambiguousParse "operator" (opName op) (qualify uop)->   where OpPrec _ pr = opPrec op pEnv-> fixRPrec pEnv e1 op1 (InfixApply e2 op2 e3)->   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR =->       InfixApply e1 op1 (InfixApply e2 op2 e3)->   | pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL =->       InfixApply (fixPrec pEnv e1 op1 e2) op2 e3->   | otherwise =->       errorAt' $ ambiguousParse "operator" (opName op1) (opName op2)->   where OpPrec fix1 pr1 = opPrec op1 pEnv->         OpPrec fix2 pr2 = opPrec op2 pEnv-> fixRPrec _ e1 op e2 = InfixApply e1 op e2--\end{verbatim}-The functions \texttt{checkLSection} and \texttt{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.-\begin{verbatim}--> checkLSection :: PEnv -> InfixOp -> Expression -> Expression-> checkLSection pEnv op e@(UnaryMinus uop _)->   | pr < 6 || pr == 6 && fix == InfixL = LeftSection e op->   | otherwise = errorAt' $ ambiguousParse "unary" (qualify uop) (opName op)->   where OpPrec fix pr = opPrec op pEnv-> checkLSection pEnv op1 e@(InfixApply _ op2 _)->   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL =->       LeftSection e op1->   | otherwise =->       errorAt' $ ambiguousParse "operator" (opName op1) (opName op2)->   where OpPrec fix1 pr1 = opPrec op1 pEnv->         OpPrec fix2 pr2 = opPrec op2 pEnv-> checkLSection _ op e = LeftSection e op--> checkRSection :: PEnv -> InfixOp -> Expression -> Expression-> checkRSection pEnv op e@(UnaryMinus uop _)->   | pr < 6 = RightSection op e->   | otherwise = errorAt' $ ambiguousParse "unary" (qualify uop) (opName op)->   where OpPrec _ pr = opPrec op pEnv-> checkRSection pEnv op1 e@(InfixApply _ op2 _)->   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR =->       RightSection op1 e->   | otherwise =->       errorAt' $ ambiguousParse "operator" (opName op1) (opName op2)->   where OpPrec fix1 pr1 = opPrec op1 pEnv->         OpPrec fix2 pr2 = opPrec op2 pEnv-> checkRSection _ op e = RightSection op e--\end{verbatim}-The functions \texttt{fixPrecT} and \texttt{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. \emph{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.-\begin{verbatim}--> fixPrecT ::  PEnv ->             -> (ConstrTerm -> QualIdent -> ConstrTerm -> ConstrTerm)->	      -> ConstrTerm -> QualIdent -> ConstrTerm  ->             -> ConstrTerm-> fixPrecT pEnv infixpatt t1@(NegativePattern uop l) op t2->   | pr < 6 || pr == 6 && fix == InfixL ->     = fixRPrecT pEnv infixpatt t1 op t2->   | otherwise ->     = errorAt' $ invalidParse "unary" uop op->   where OpPrec fix pr = prec op pEnv-> fixPrecT pEnv infixpatt t1 op t2 ->   = fixRPrecT pEnv infixpatt t1 op t2--> fixRPrecT :: PEnv ->              -> (ConstrTerm -> QualIdent -> ConstrTerm -> ConstrTerm)->              -> ConstrTerm  -> QualIdent -> ConstrTerm->              -> ConstrTerm-> fixRPrecT pEnv infixpatt t1 op t2@(NegativePattern uop l)->   | pr < 6    = infixpatt t1 op t2->   | otherwise = errorAt' $ invalidParse "unary" uop op->   where OpPrec _ pr = prec op pEnv-> fixRPrecT pEnv infixpatt t1 op1 (InfixPattern t2 op2 t3)->   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR->     = infixpatt t1 op1 (InfixPattern t2 op2 t3)->   | pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL->     = InfixPattern (fixPrecT pEnv infixpatt t1 op1 t2) op2 t3->   | otherwise ->     = errorAt' $ ambiguousParse "operator" op1 op2->   where OpPrec fix1 pr1 = prec op1 pEnv->         OpPrec fix2 pr2 = prec op2 pEnv-> fixRPrecT pEnv infixpatt t1 op1 (InfixFuncPattern t2 op2 t3)->   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR->     = infixpatt t1 op1 (InfixFuncPattern t2 op2 t3)->   | pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL->     = InfixFuncPattern (fixPrecT pEnv infixpatt t1 op1 t2) op2 t3->   | otherwise ->     = errorAt' $ ambiguousParse "operator" op1 op2->   where OpPrec fix1 pr1 = prec op1 pEnv->         OpPrec fix2 pr2 = prec op2 pEnv-> fixRPrecT _ infixpatt t1 op t2 = infixpatt t1 op t2--> {-fixPrecT :: Position -> PEnv -> ConstrTerm -> QualIdent -> ConstrTerm->          -> ConstrTerm-> fixPrecT p pEnv t1@(NegativePattern uop l) op t2->   | pr < 6 || pr == 6 && fix == InfixL = fixRPrecT p pEnv t1 op t2->   | otherwise = errorAt p $ invalidParse "unary" uop op->   where OpPrec fix pr = prec op pEnv-> fixPrecT p pEnv t1 op t2 = fixRPrecT p pEnv t1 op t2-}--> {-fixRPrecT :: Position -> PEnv -> ConstrTerm -> QualIdent -> ConstrTerm->           -> ConstrTerm-> fixRPrecT p pEnv t1 op t2@(NegativePattern uop l)->   | pr < 6 = InfixPattern t1 op t2->   | otherwise = errorAt p $ invalidParse "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 $ ambiguousParse "operator" op1 op2->   where OpPrec fix1 pr1 = prec op1 pEnv->         OpPrec fix2 pr2 = prec op2 pEnv-> fixRPrecT _ _ t1 op t2 = InfixPattern t1 op t2-}--\end{verbatim}-The functions \texttt{checkOpL} and \texttt{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.-\begin{verbatim}--> checkOpL :: PEnv -> Ident -> ConstrTerm -> ConstrTerm-> checkOpL pEnv op t@(NegativePattern uop l)->   | pr < 6 || pr == 6 && fix == InfixL = t->   | otherwise = errorAt' $ invalidParse "unary" uop (qualify op)->   where OpPrec fix pr = prec (qualify op) pEnv-> checkOpL pEnv op1 t@(InfixPattern _ op2 _)->   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL = t->   | otherwise = errorAt' $ invalidParse "operator" op1 op2->   where OpPrec fix1 pr1 = prec (qualify op1) pEnv->         OpPrec fix2 pr2 = prec op2 pEnv-> checkOpL _ _ t = t--> checkOpR :: PEnv -> Ident -> ConstrTerm -> ConstrTerm-> checkOpR pEnv op t@(NegativePattern uop l)->   | pr < 6 = t->   | otherwise = errorAt' $ invalidParse "unary" uop (qualify op)->   where OpPrec _ pr = prec (qualify op) pEnv-> checkOpR pEnv op1 t@(InfixPattern _ op2 _)->   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR = t->   | otherwise = errorAt' $ invalidParse "operator" op1 op2->   where OpPrec fix1 pr1 = prec (qualify op1) pEnv->         OpPrec fix2 pr2 = prec op2 pEnv-> checkOpR _ _ t = t--\end{verbatim}-The functions \texttt{opPrec} and \texttt{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.-\begin{verbatim}--> opPrec :: InfixOp -> PEnv -> OpPrec-> opPrec op = prec (opName op)--> prec :: QualIdent -> PEnv -> OpPrec-> prec op env =->   case qualLookupP op env of->     [] -> defaultP->     PrecInfo _ p : _ -> p--\end{verbatim}-Error messages.-\begin{verbatim}--> undefinedOperator :: Ident -> (Position,String)-> undefinedOperator op = ->  (positionOfIdent op,->   "no definition for " ++ name op ++ " in this scope")--> duplicatePrecedence :: Ident -> (Position,String)-> duplicatePrecedence op = ->  (positionOfIdent op,->   "More than one fixity declaration for " ++ name op)--> invalidParse :: String -> Ident -> QualIdent -> (Position,String)-> invalidParse what op1 op2 =->  (positionOfIdent op1,->   "Invalid use of " ++ what ++ " " ++ name op1 ++ " with " ++ qualName op2 ++->   (showLine $ positionOfQualIdent op2))--> ambiguousParse :: String -> QualIdent -> QualIdent -> (Position,String)-> ambiguousParse what op1 op2 =->  (positionOfQualIdent op1,->   "Ambiguous use of " ++ what ++ " " ++ qualName op1 ++->   " with " ++ qualName op2 ++ (showLine $ positionOfQualIdent op2))--\end{verbatim}
− src/Qual.lhs 
@@ -1,165 +0,0 @@--% $Id: Qual.lhs,v 1.18 2004/02/15 22:10:36 wlux Exp $-%-% Copyright (c) 2001-2004, Wolfgang Lux-% See LICENSE for the full license.-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-%-\nwfilename{Qual.lhs}-\section{Proper Qualification}-After checking the module and before starting the translation into the-intermediate language, the compiler properly qualifies all-constructors and (global) functions occurring in a pattern or-expression such that their module prefix matches the module of their-definition. This is done also for functions and constructors declared-in the current module. Only functions and variables declared in local-declarations groups as well as function arguments remain unchanged.--\em{Note:} The modified version also qualifies type constructors-\begin{verbatim}--> module Qual(qual) where--> import Curry.Base.Ident-> import Curry.Syntax--> import Base-> import TopEnv--> qual :: ModuleIdent -> ValueEnv -> [Decl] -> [Decl]-> qual m tyEnv ds = map (qualDecl m tyEnv) ds--> qualDecl :: ModuleIdent -> ValueEnv -> Decl -> Decl-> qualDecl m tyEnv (FunctionDecl p f eqs) =->   FunctionDecl p f (map (qualEqn m tyEnv) eqs)-> qualDecl m tyEnv (PatternDecl p t rhs) =->   PatternDecl p (qualTerm m tyEnv t) (qualRhs m tyEnv rhs)-> qualDecl _ _ d = d--> qualEqn :: ModuleIdent -> ValueEnv -> Equation -> Equation-> qualEqn m tyEnv (Equation p lhs rhs) =->   Equation p (qualLhs m tyEnv lhs) (qualRhs m tyEnv rhs)--> qualLhs :: ModuleIdent -> ValueEnv -> Lhs -> Lhs-> qualLhs m tyEnv (FunLhs f ts) = FunLhs f (map (qualTerm m tyEnv) ts)-> qualLhs m tyEnv (OpLhs t1 op t2) =->   OpLhs (qualTerm m tyEnv t1) op (qualTerm m tyEnv t2)-> qualLhs m tyEnv (ApLhs lhs ts) =->   ApLhs (qualLhs m tyEnv lhs) (map (qualTerm m tyEnv) ts)--> qualTerm :: ModuleIdent -> ValueEnv -> ConstrTerm -> ConstrTerm-> qualTerm _ _ (LiteralPattern l) = LiteralPattern l-> qualTerm _ _ (NegativePattern op l) = NegativePattern op l-> qualTerm _ _ (VariablePattern v) = VariablePattern v-> qualTerm m tyEnv (ConstructorPattern c ts) =->   ConstructorPattern (qualIdent m tyEnv c) (map (qualTerm m tyEnv) ts)-> qualTerm m tyEnv (InfixPattern t1 op t2) =->   InfixPattern (qualTerm m tyEnv t1) ->                (qualIdent m tyEnv op) ->                (qualTerm m tyEnv t2)-> qualTerm m tyEnv (ParenPattern t) = ParenPattern (qualTerm m tyEnv t)-> qualTerm m tyEnv (TuplePattern p ts) = TuplePattern p (map (qualTerm m tyEnv) ts)-> qualTerm m tyEnv (ListPattern p ts) = ListPattern p (map (qualTerm m tyEnv) ts)-> qualTerm m tyEnv (AsPattern v t) = AsPattern v (qualTerm m tyEnv t)-> qualTerm m tyEnv (LazyPattern p t) = LazyPattern p (qualTerm m tyEnv t)-> qualTerm m tyEnv (FunctionPattern f ts) =->   FunctionPattern (qualIdent m tyEnv f) (map (qualTerm m tyEnv) ts)-> qualTerm m tyEnv (InfixFuncPattern t1 op t2) =->   InfixFuncPattern (qualTerm m tyEnv t1) ->		     (qualIdent m tyEnv op) ->	             (qualTerm m tyEnv t2)-> qualTerm m tyEnv (RecordPattern fs rt) =->   RecordPattern (map (qualFieldPattern m tyEnv) fs)->	          (maybe Nothing (Just . qualTerm m tyEnv) rt)--> qualFieldPattern :: ModuleIdent -> ValueEnv -> Field ConstrTerm->	           -> Field ConstrTerm-> qualFieldPattern m tyEnv (Field p l t) = Field p l (qualTerm m tyEnv t)--> qualRhs :: ModuleIdent -> ValueEnv -> Rhs -> Rhs-> qualRhs m tyEnv (SimpleRhs p e ds) =->   SimpleRhs p (qualExpr m tyEnv e) (map (qualDecl m tyEnv) ds) -> qualRhs m tyEnv (GuardedRhs es ds) =->   GuardedRhs (map (qualCondExpr m tyEnv) es) (map (qualDecl m tyEnv) ds)--> qualCondExpr :: ModuleIdent -> ValueEnv -> CondExpr -> CondExpr-> qualCondExpr m tyEnv (CondExpr p g e) =->   CondExpr p (qualExpr m tyEnv g) (qualExpr m tyEnv e)--> qualExpr :: ModuleIdent -> ValueEnv -> Expression -> Expression-> qualExpr _ _ (Literal l) = Literal l-> qualExpr m tyEnv (Variable v) = Variable (qualIdent m tyEnv v)-> qualExpr m tyEnv (Constructor c) = Constructor (qualIdent m tyEnv c)-> qualExpr m tyEnv (Paren e) = Paren (qualExpr m tyEnv e)-> qualExpr m tyEnv (Typed e ty) = Typed (qualExpr m tyEnv e) ty-> qualExpr m tyEnv (Tuple p es) = Tuple p (map (qualExpr m tyEnv) es)-> qualExpr m tyEnv (List p es) = List p (map (qualExpr m tyEnv) es)-> qualExpr m tyEnv (ListCompr p e qs) =->   ListCompr p (qualExpr m tyEnv e) (map (qualStmt m tyEnv) qs)-> qualExpr m tyEnv (EnumFrom e) = EnumFrom (qualExpr m tyEnv e)-> qualExpr m tyEnv (EnumFromThen e1 e2) =->   EnumFromThen (qualExpr m tyEnv e1) (qualExpr m tyEnv e2)-> qualExpr m tyEnv (EnumFromTo e1 e2) =->   EnumFromTo (qualExpr m tyEnv e1) (qualExpr m tyEnv e2)-> qualExpr m tyEnv (EnumFromThenTo e1 e2 e3) =->   EnumFromThenTo (qualExpr m tyEnv e1) ->                  (qualExpr m tyEnv e2) ->                  (qualExpr m tyEnv e3)-> qualExpr m tyEnv (UnaryMinus op e) = UnaryMinus op (qualExpr m tyEnv e)-> qualExpr m tyEnv (Apply e1 e2) = ->   Apply (qualExpr m tyEnv e1) (qualExpr m tyEnv e2)-> qualExpr m tyEnv (InfixApply e1 op e2) =->   InfixApply (qualExpr m tyEnv e1) (qualOp m tyEnv op) (qualExpr m tyEnv e2)-> qualExpr m tyEnv (LeftSection e op) =->   LeftSection (qualExpr m tyEnv e) (qualOp m tyEnv op)-> qualExpr m tyEnv (RightSection op e) =->   RightSection (qualOp m tyEnv op) (qualExpr m tyEnv e)-> qualExpr m tyEnv (Lambda r ts e) =->   Lambda r (map (qualTerm m tyEnv) ts) (qualExpr m tyEnv e)-> qualExpr m tyEnv (Let ds e) = ->   Let (map (qualDecl m tyEnv) ds) (qualExpr m tyEnv e)-> qualExpr m tyEnv (Do sts e) = ->   Do (map (qualStmt m tyEnv) sts) (qualExpr m tyEnv e)-> qualExpr m tyEnv (IfThenElse r e1 e2 e3) =->   IfThenElse r (qualExpr m tyEnv e1) ->              (qualExpr m tyEnv e2) ->              (qualExpr m tyEnv e3)-> qualExpr m tyEnv (Case r e alts) =->   Case r (qualExpr m tyEnv e) (map (qualAlt m tyEnv) alts)-> qualExpr m tyEnv (RecordConstr fs) =->   RecordConstr (map (qualFieldExpr m tyEnv) fs)-> qualExpr m tyEnv (RecordSelection e l) =->   RecordSelection (qualExpr m tyEnv e) l-> qualExpr m tyEnv (RecordUpdate fs e) =->   RecordUpdate (map (qualFieldExpr m tyEnv) fs) (qualExpr m tyEnv e)--> qualStmt :: ModuleIdent -> ValueEnv -> Statement -> Statement-> qualStmt m tyEnv (StmtExpr p e) = StmtExpr p (qualExpr m tyEnv e)-> qualStmt m tyEnv (StmtBind p t e) =->   StmtBind p (qualTerm m tyEnv t) (qualExpr m tyEnv e)-> qualStmt m tyEnv (StmtDecl ds) = StmtDecl (map (qualDecl m tyEnv) ds)--> qualAlt :: ModuleIdent -> ValueEnv -> Alt -> Alt-> qualAlt m tyEnv (Alt p t rhs) = ->   Alt p (qualTerm m tyEnv t) (qualRhs m tyEnv rhs)--> qualFieldExpr :: ModuleIdent -> ValueEnv -> Field Expression->	        -> Field Expression-> qualFieldExpr m tyEnv (Field p l e) = Field p l (qualExpr m tyEnv e)--> qualOp :: ModuleIdent -> ValueEnv -> InfixOp -> InfixOp-> qualOp m tyEnv (InfixOp op) = InfixOp (qualIdent m tyEnv op)-> qualOp m tyEnv (InfixConstr op) = InfixConstr (qualIdent m tyEnv op)--> qualIdent :: ModuleIdent -> ValueEnv -> QualIdent -> QualIdent-> qualIdent m tyEnv x->   | not (isQualified x) && uniqueId (unqualify x) /= 0 = x->   | otherwise =->       case (qualLookupValue x tyEnv) of->         [y] -> origName y->         vs  -> case (qualLookupValue (qualQualify m x) tyEnv) of->                  [y] -> origName y->                  _ -> qualQualify m x -- internalError ("qualIdent: " ++ show x)--\end{verbatim}
− src/SCC.lhs 
@@ -1,60 +0,0 @@--% $Id: SCC.lhs,v 1.3 2003/04/30 21:29:06 wlux Exp $-%-% Copyright (c) 2000,2002-2003, Wolfgang Lux-% See LICENSE for the full license.-%-\nwfilename{SCC.lhs}-\section{Computing strongly connected components}-At various places in the compiler we had to partition a list of-declarations into strongly connected components. The function-\texttt{scc} computes this relation in two steps. First, the list is-topologically sorted ``downwards'' using the \emph{defs} relation.-Then the resulting list is sorted ``upwards'' using the \emph{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.-\begin{verbatim}--> module SCC(scc) where--> import qualified Data.Set as Set--> 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--> 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 x = filter (any (`elem` fvs x) . 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 x = filter (any (`elem` bvs x) . fvs) xs--\end{verbatim}
− src/ScopeEnv.hs 
@@ -1,175 +0,0 @@---------------------------------------------------------------------------------------------------------------------------------------------------------------------- ScopeEnv - provides functions and data types for dealing with nested---            scope environments to store data from nested scopes------ This module should be imported using "import qualified" to avoid name--- clashes------ November 2005,--- Martin Engelke (men@informatik.uni-kiel.de)----module ScopeEnv (ScopeEnv,-		 new, insert, update, modify, lookup, sureLookup,-		 level, exists, beginScope, endScope, endScopeUp,-		 toList, toLevelList, currentLevel) where--import qualified Data.Map as Map-import Prelude hiding (lookup)--------------------------------------------------------------------------------------------------------------------------------------------------------------------- Data type for representing information in nested scopes.-data ScopeEnv a b = ScopeEnv Int (Map.Map a (b,Int)) [Map.Map a (b,Int)]-		    deriving Show--------------------------------------------------------------------------------------------------------------------------------------------------------------------- Returns an empty scope environment-new :: Ord a => ScopeEnv a b-new = ScopeEnv 0 Map.empty []----- Inserts a value under a key into the environment of the current scope-insert :: Ord a => a -> b -> ScopeEnv a b -> ScopeEnv a b-insert key val env = modifySE insertLev env- where- insertLev lev local = Map.insert key (val,lev) local----- Updates the value stored under an existing key in the environment of --- the current scope-update :: Ord a => a -> b -> ScopeEnv a b -> ScopeEnv a b-update key val env = modifySE updateLev env- where- updateLev lev local = maybe local -		             (\ (_,lev') ->  Map.insert key (val,lev') local)-			     (Map.lookup key local)---- Modifies the value of an existing key by applying the function 'fun'--- in the environment of the current scope-modify :: Ord a => (b -> b) -> a -> ScopeEnv a b -> ScopeEnv a b-modify fun key env = modifySE modifyLev env- where- modifyLev lev local -    = maybe local-            (\ (val',lev') -> Map.insert key (fun val', lev') local)-	    (Map.lookup key local)----- Looks up the value which is stored under a key from the environment of--- the current scope-lookup :: Ord a => a -> ScopeEnv a b -> Maybe b-lookup key env = selectSE lookupLev env- where- lookupLev lev local = maybe Nothing (Just . fst) (Map.lookup key local)----- Similar to 'lookup', but returns an alternative value, if the key--- doesn't exist in the environment of the current scope-sureLookup :: Ord a => a -> b -> ScopeEnv a b -> b-sureLookup key alt env = maybe alt id (lookup key env)----- Returns the level of the last insertion of a key-level :: Ord a => a -> ScopeEnv a b -> Int-level key env = selectSE levelLev env- where- levelLev lev local = maybe (-1) snd (Map.lookup key local)----- Checks, whether a key exists in the environment of the current scope-exists :: Ord a => a -> ScopeEnv a b -> Bool-exists key env = selectSE existsLev env- where- existsLev lev local = maybe False (const True) (Map.lookup key local)----- Switches to the next scope (i.e. pushes the environment of the current--- scope onto the top of an scope stack and increments the level counter)-beginScope :: Ord a => ScopeEnv a b -> ScopeEnv a b-beginScope (ScopeEnv lev top [])-   = ScopeEnv (lev + 1) top [top]-beginScope (ScopeEnv lev top (local:locals))-   = ScopeEnv (lev + 1) top (local:local:locals)----- Switches to the previous scope (i.e. pops the environment from the top--- of the scope stack and decrements the level counter)-endScope :: Ord a => ScopeEnv a b -> ScopeEnv a b-endScope (ScopeEnv _ top [])-   = ScopeEnv 0 top []-endScope (ScopeEnv lev top (_:locals))-   = ScopeEnv (lev - 1) top locals----- Behaves like 'endScope' but additionally updates the environment of--- the previous scope by updating all keys with the corresponding values--- from the poped environment-endScopeUp :: Ord a => ScopeEnv a b -> ScopeEnv a b-endScopeUp (ScopeEnv _ top [])-   = ScopeEnv 0 top []-endScopeUp (ScopeEnv lev top (local:[]))-   = ScopeEnv 0 (foldr (updateSE local) top (Map.toList top)) []-endScopeUp (ScopeEnv lev top (local:local':locals))-   = ScopeEnv (lev - 1) -              top -	      ((foldr (updateSE local) local' (Map.toList local')):locals)----- Returns the environment of current scope as a (key,value) list-toList :: Ord a => ScopeEnv a b -> [(a,b)]-toList env = selectSE toListLev env- where- toListLev lev local = map (\ (key,(val,_)) -> (key,val)) (Map.toList local)----- Returns all (key,value) pairs from the environment of the current scope --- which has been inserted in the current level-toLevelList :: Ord a => ScopeEnv a b -> [(a,b)]-toLevelList env = selectSE toLevelListLev env- where- toLevelListLev lev local-    = map (\ (key,(val,_)) -> (key,val))-          (filter (\ (_,(_,lev')) -> lev' == lev) (Map.toList local))----- Returns the current level-currentLevel :: Ord a => ScopeEnv a b -> Int-currentLevel env = selectSE const env--------------------------------------------------------------------------------------------------------------------------------------------------------------------- Privates...-----modifySE :: (Int -> Map.Map a (b,Int) -> Map.Map a (b,Int)) -> ScopeEnv a b -          -> ScopeEnv a b-modifySE f (ScopeEnv _ top []) -   = ScopeEnv 0 (f 0 top) []-modifySE f (ScopeEnv lev top (local:locals))-   = ScopeEnv lev top ((f lev local):locals)-----selectSE :: (Int -> Map.Map a (b,Int) -> c) -> ScopeEnv a b -> c-selectSE f (ScopeEnv _ top [])        = f 0 top-selectSE f (ScopeEnv lev _ (local:_)) = f lev local-----updateSE :: Ord a => Map.Map a (b,Int) -> (a,(b,Int)) ->  Map.Map a (b,Int) -          -> Map.Map a (b,Int)-updateSE local (key,(_,lev)) local'-   = maybe local' -           (\ (val',lev') -	    -> if lev == lev' then Map.insert key (val',lev) local' -                              else local')-	   (Map.lookup key local)-------------------------------------------------------------------------------------------------------------------------------------------------------------------
− src/Simplify.lhs 
@@ -1,475 +0,0 @@-% $Id: Simplify.lhs,v 1.10 2004/02/13 14:02:58 wlux Exp $-%-% Copyright (c) 2003, Wolfgang Lux-% See LICENSE for the full license.-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-%-\nwfilename{Simplify.lhs}-\section{Optimizing the Desugared Code}\label{sec:simplify}-After desugaring the source code, but before lifting local-declarations, the compiler performs a few simple optimizations to-improve the efficiency of the generated code. In addition, the-optimizer replaces pattern bindings with simple variable bindings and-selector functions.--Currently, the following optimizations are implemented:-\begin{itemize}-\item Remove unused declarations.-\item Inline simple constants.-\item Compute minimal binding groups.-\item Under certain conditions, inline local function definitions.-\end{itemize}-\begin{verbatim}--> module Simplify(simplify) where--> import Control.Monad.Reader as R-> import Control.Monad.State as S-> import qualified Data.Map as Map--> import Curry.Base.Position-> import Curry.Base.Ident-> import Curry.Syntax-> import Curry.Syntax.Utils--> import Types-> import Base-> import SCC-> import Typing---> type SimplifyState a = S.StateT ValueEnv (ReaderT EvalEnv (S.State Int)) a-> type InlineEnv = Map.Map Ident Expression-> type SimplifyFlags = Bool- -> flatFlag :: SimplifyFlags -> Bool-> flatFlag   x = x--> simplify :: SimplifyFlags -> ValueEnv -> EvalEnv -> Module -> (Module,ValueEnv)-> simplify flags tyEnv evEnv m ->   = S.evalState (R.runReaderT (S.evalStateT (simplifyModule flags m) tyEnv) evEnv) 1--> simplifyModule :: SimplifyFlags -> Module -> SimplifyState (Module,ValueEnv)-> simplifyModule flat (Module m es ds) =->   do->     ds' <- mapM (simplifyDecl flat m Map.empty) ds->     tyEnv <- S.get->     return (Module m es ds',tyEnv)--> simplifyDecl :: SimplifyFlags -> ModuleIdent -> InlineEnv -> Decl -> SimplifyState Decl-> simplifyDecl flat m env (FunctionDecl p f eqs) =->   liftM (FunctionDecl p f . concat) (mapM (simplifyEquation flat m env) eqs)-> simplifyDecl flat m env (PatternDecl p t rhs) =->   liftM (PatternDecl p t) (simplifyRhs flat m env rhs)-> simplifyDecl _ _ _ d = return d--\end{verbatim}-After simplifying the right hand side of an equation, the compiler-transforms declarations of the form-\begin{quote}\tt-  $f\;t_1\dots t_{k-k'}\;x_{k-k'+1}\dots x_{k}$ =-    let $f'\;t'_1\dots t'_{k'}$ = $e$ in-    $f'\;x_1\dots x_{k'}$-\end{quote}-into the equivalent definition-\begin{quote}\tt-  $f\;t_1\dots t_{k-k'}\;(x_{k-k'+1}$@$t'_1)\dots(x_k$@$t'_{k'})$ = $e$-\end{quote}-where the arities of $f$ and $f'$ are $k$ and $k'$, respectively, and-$x_{k-k'+1},\dots,x_{k}$ are variables. This optimization was-introduced in order to avoid an auxiliary function being generated for-definitions whose right-hand side is a $\lambda$-expression, e.g.,-\verb|f . g = \x -> f (g x)|. This declaration is transformed into-\verb|(.) f g x = let lambda x = f (g x) in lambda x| by desugaring-and in turn is optimized into \verb|(.) f g x = f (g x)|, here. The-transformation can obviously be generalized to the case where $f'$ is-defined by more than one equation. However, we must be careful not to-change the evaluation mode of arguments. Therefore, the transformation-is applied only if $f$ and $f'$ use them same evaluation mode or all-of the arguments $t'_1,\dots,t'_k$ are variables. Actually, the-transformation could be applied to the case where the arguments-$t_1,\dots,t_{k-k'}$ are all variables as well, but in this case the-evaluation mode of $f$ may have to be changed to match that of $f'$.--We have to be careful with this optimization in conjunction with-newtype constructors. It is possible that the local function is-applied only partially, e.g., for-\begin{verbatim}-  newtype ST s a = ST (s -> (a,s))-  returnST x = ST (\s -> (x,s))-\end{verbatim}-the desugared code is equivalent to-\begin{verbatim}-  returnST x = let lambda1 s = (x,s) in lambda1-\end{verbatim}-We must not ``optimize'' this into \texttt{returnST x s = (x,s)}-because the compiler assumes that \texttt{returnST} is a unary-function.--Note that this transformation is not strictly semantic preserving as-the evaluation order of arguments can be changed. This happens if $f$-is defined by more than one rule with overlapping patterns and the-local functions of each rule have disjoint patterns. As an example,-consider the function-\begin{verbatim}-  f (Just x) _ = let g (Left z)  = x + z in g-  f _ (Just y) = let h (Right z) = y + z in h-\end{verbatim}-The definition of \texttt{f} is non-deterministic because of the-overlapping patterns in the first and second argument. However, the-optimized definition-\begin{verbatim}-  f (Just x) _ (Left z)  = x + z-  f _ (Just y) (Right z) = y + z-\end{verbatim}-is deterministic. It will evaluate and match the third argument first,-whereas the original definition is going to evaluate the first or the-second argument first, depending on the non-deterministic branch-chosen. As such definitions are presumably rare, and the optimization-avoids a non-deterministic split of the computation, we put up with-the change of evaluation order.--This transformation is actually just a special case of inlining a-(local) function definition. We are unable to handle the general case-because it would require to represent the pattern matching code-explicitly in a Curry expression.-\begin{verbatim}--> simplifyEquation :: SimplifyFlags -> ModuleIdent -> InlineEnv -> Equation->                  -> SimplifyState [Equation]-> simplifyEquation flat m env (Equation p lhs rhs) =->   do->     rhs' <- simplifyRhs flat m env rhs->     tyEnv <- S.get->     evEnv <- S.lift R.ask->     return (inlineFun flat m tyEnv evEnv p lhs rhs')--> inlineFun :: SimplifyFlags -> ModuleIdent -> ValueEnv -> EvalEnv -> Position -> Lhs -> Rhs->           -> [Equation]-> inlineFun flags m tyEnv evEnv p (FunLhs f ts)->           (SimpleRhs _ (Let [FunctionDecl _ f' eqs'] e) _)->   | True -- False -- inlining of functions is deactivated (hsi)->    && f' `notElem` qfv m eqs' && e' == Variable (qualify f') &&->     n == arrowArity (funType m tyEnv (qualify f')) &&->     (evMode evEnv f == evMode evEnv f' ||->      and [all isVarPattern ts | Equation _ (FunLhs _ ts) _ <- eqs']) =->     map (mergeEqns p f ts' vs') eqs'->   where n :: Int                      -- type signature necessary for nhc->         (n,vs',ts',e') = etaReduce 0 [] (reverse ts) e->         mergeEqns p f ts vs (Equation _ (FunLhs _ ts') rhs) =->           Equation p (FunLhs f (ts ++ zipWith AsPattern vs ts')) rhs->         etaReduce n vs (VariablePattern v : ts) (Apply e (Variable v'))->           | qualify v == v' = etaReduce (n+1) (v:vs) ts e->         etaReduce n vs ts e = (n,vs,reverse ts,e)-> inlineFun _ _ _ _ p lhs rhs = [Equation p lhs rhs]--> simplifyRhs :: SimplifyFlags -> ModuleIdent -> InlineEnv -> Rhs -> SimplifyState Rhs-> simplifyRhs flat m env (SimpleRhs p e _) =->   do->     e' <- simplifyExpr flat m env e->     return (SimpleRhs p e' [])--\end{verbatim}-Variables that are bound to (simple) constants and aliases to other-variables are substituted. In terms of conventional compiler-technology these optimizations correspond to constant folding and copy-propagation, respectively. The transformation is applied recursively-to a substituted variable in order to handle chains of variable-definitions.--The bindings of a let expression are sorted topologically in-order to split them into minimal binding groups. In addition,-local declarations occurring on the right hand side of a pattern-declaration are lifted into the enclosing binding group using the-equivalence (modulo $\alpha$-conversion) of \texttt{let}-$x$~=~\texttt{let} \emph{decls} \texttt{in} $e_1$ \texttt{in} $e_2$-and \texttt{let} \emph{decls}\texttt{;} $x$~=~$e_1$ \texttt{in} $e_2$.-This transformation avoids the creation of some redundant lifted-functions in later phases of the compiler.-\begin{verbatim}--> simplifyExpr :: SimplifyFlags -> ModuleIdent -> InlineEnv -> Expression->              -> SimplifyState Expression-> simplifyExpr _ _ _ (Literal l) = return (Literal l)-> simplifyExpr flat m env (Variable v)->   | isQualified v = return (Variable v)->   | otherwise = maybe (return (Variable v)) (simplifyExpr flat m env)->                       (Map.lookup (unqualify v) env)-> simplifyExpr _ _ _ (Constructor c) = return (Constructor c)-> simplifyExpr flags m env (Apply (Let ds e1) e2) ->   = simplifyExpr flags m env (Let ds (Apply e1 e2))-> simplifyExpr flags m env (Apply (Case r e1 alts) e2) ->   = simplifyExpr flags m env (Case r e1 (map (applyToAlt e2) alts))->   where applyToAlt e (Alt p t rhs) = Alt p t (applyRhs rhs e)->         applyRhs (SimpleRhs p e1 _) e2 = SimpleRhs p (Apply e1 e2) []-> simplifyExpr flat m env (Apply e1 e2) =->   do->     e1' <- simplifyExpr flat m env e1->     e2' <- simplifyExpr flat m env e2->     return (Apply e1' e2')-> simplifyExpr flags m env (Let ds e) =->   do->     tyEnv <- S.get->     dss' <- mapM (sharePatternRhs m tyEnv) ds->     simplifyLet flags m env->       (scc bv (qfv m) (foldr (hoistDecls flags) [] (concat dss'))) e-> simplifyExpr flat m env (Case r e alts) =->   do->     e' <- simplifyExpr flat m env e->     alts' <- mapM (simplifyAlt flat m env) alts->     return (Case r e' alts')-> --> simplifyAlt :: SimplifyFlags -> ModuleIdent -> InlineEnv -> Alt -> SimplifyState Alt-> simplifyAlt flat m env (Alt p t rhs) =->   liftM (Alt p t) (simplifyRhs flat m env rhs)--> hoistDecls :: SimplifyFlags -> Decl -> [Decl] -> [Decl]-> hoistDecls flags (PatternDecl p t (SimpleRhs p' (Let ds e) _)) ds' ->  = foldr (hoistDecls flags) ds' (PatternDecl p t (SimpleRhs p' e []) : ds)-> hoistDecls _ d ds = d : ds--\end{verbatim}-The declaration groups of a let expression are first processed from-outside to inside, simplifying the right hand sides and collecting-inlineable expressions on the fly. At present, only simple constants-and aliases to other variables are inlined. A constant is considered-simple if it is either a literal, a constructor, or a non-nullary-function. Note that it is not possible to define nullary functions in-local declarations in Curry. Thus, an unqualified name always refers-to either a variable or a non-nullary function.  Applications of-constructors and partial applications of functions to at least one-argument are not inlined because the compiler has to allocate space-for them, anyway. In order to prevent non-termination, recursive-binding groups are not processed.--With the list of inlineable expressions, the body of the let is-simplified and then the declaration groups are processed from inside-to outside to construct the simplified, nested let expression. In-doing so unused bindings are discarded. In addition, all pattern-bindings are replaced by simple variable declarations using selector-functions to access the pattern variables.-\begin{verbatim}--> simplifyLet :: SimplifyFlags -> ModuleIdent -> InlineEnv -> [[Decl]] -> Expression->             -> SimplifyState Expression-> simplifyLet flat m env [] e = simplifyExpr flat m env e-> simplifyLet flags m env (ds:dss) e =->   do->     ds' <- mapM (simplifyDecl flags m env) ds->     tyEnv <- S.get->     e' <- simplifyLet flags m (inlineVars flags m tyEnv ds' env) dss e->     dss'' <-->       mapM (expandPatternBindings flags m tyEnv (qfv m ds' ++ qfv m e')) ds'->     return (foldr (mkLet flags m) e' ->                   (scc bv (qfv m) (concat dss'')))--> inlineVars :: SimplifyFlags -> ModuleIdent -> ValueEnv -> [Decl] -> InlineEnv -> InlineEnv-> inlineVars flags m tyEnv [PatternDecl _ (VariablePattern v) (SimpleRhs _ e _)] env->   | canInline e = Map.insert v e env->   where->   canInline (Literal _) = True->   canInline (Constructor _) = True->   canInline _ = False -- inlining of variables is deactivated (hsi)->   canInline (Variable v')->       | isQualified v' = arrowArity (funType m tyEnv v') > 0->       | otherwise = v /= unqualify v'->   canInline _ = False-> inlineVars _ _ _ _ env = env--> mkLet :: SimplifyFlags -> ModuleIdent -> [Decl] -> Expression -> Expression-> mkLet flags m [ExtraVariables p vs] e->   | null vs' = e->   | otherwise = Let [ExtraVariables p vs'] e->   where vs' = filter (`elem` qfv m e) vs-> mkLet flags m [PatternDecl _ (VariablePattern v) (SimpleRhs _ e _)] (Variable v')->   | v' == qualify v && v `notElem` qfv m e = e-> mkLet flags m ds e->   | null (filter (`elem` qfv m e) (bv ds)) = e->   | otherwise = Let ds e--\end{verbatim}-\label{pattern-binding}-In order to implement lazy pattern matching in local declarations,-pattern declarations $t$~\texttt{=}~$e$ where $t$ is not a variable-are transformed into a list of declarations-$v_0$~\texttt{=}~$e$\texttt{;} $v_1$~\texttt{=}~$f_1$~$v_0$\texttt{;}-\dots{} $v_n$~\texttt{=}~$f_n$~$v_0$ where $v_0$ is a fresh variable,-$v_1,\dots,v_n$ are the variables occurring in $t$ and the auxiliary-functions $f_i$ are defined by $f_i$~$t$~\texttt{=}~$v_i$ (see also-appendix D.8 of the Curry report~\cite{Hanus:Report}). The bindings-$v_0$~\texttt{=}~$e$ are introduced before splitting the declaration-groups of the enclosing let expression (cf. the \texttt{Let} case in-\texttt{simplifyExpr} above) so that they are placed in their own-declaration group whenever possible. In particular, this ensures that-the new binding is discarded when the expression $e$ is itself a-variable.--Unfortunately, this transformation introduces a well-known space-leak~\cite{Wadler87:Leaks,Sparud93:Leaks} because the matched-expression cannot be garbage collected until all of the matched-variables have been evaluated. Consider the following function:-\begin{verbatim}-  f x | all (' ' ==) cs = c where (c:cs) = x-\end{verbatim}-One might expect the call \verb|f (replicate 10000 ' ')| to execute in-constant space because (the tail of) the long list of blanks is-consumed and discarded immediately by \texttt{all}. However, the-application of the selector function that extracts the head of the-list is not evaluated until after the guard has succeeded and thus-prevents the list from being garbage collected.--In order to avoid this space leak we use the approach-from~\cite{Sparud93:Leaks} and update all pattern variables when one-of the selector functions has been evaluated. Therefore all pattern-variables except for the matched one are passed as additional-arguments to each of the selector functions. Thus, each of these-variables occurs twice in the argument list of a selector function,-once in the first argument and also as one of the remaining arguments.-This duplication of names is used by the compiler to insert the code-that updates the variables when generating abstract machine code.--By its very nature, this transformation introduces cyclic variable-bindings. Since cyclic bindings are not supported by PAKCS, we revert-to a simpler translation when generating FlatCurry output.--We will add only those pattern variables as additional arguments which-are actually used in the code. This reduces the number of auxiliary-variables and can prevent the introduction of a recursive binding-group when only a single variable is used. It is also the reason for-performing this transformation here instead of in the \texttt{Desugar}-module. The selector functions are defined in a local declaration on-the right hand side of a projection declaration so that there is-exactly one declaration for each used variable.--Another problem of the translation scheme is the handling of pattern-variables with higher-order types, e.g.,-\begin{verbatim}-  strange :: [a->a] -> Maybe (a->a)-  strange xs = Just x-    where (x:_) = xs-\end{verbatim}-By reusing the types of the pattern variables, the selector function-\verb|f (x:_) = x| has type \texttt{[a->a] -> a -> a} and therefore-seems to be binary function. Thus, in the goal \verb|strange []| the-selector is only applied partially and not evaluated. Note that this-goal will fail without the type annotation. In order to ensure that a-selector function is always evaluated when the corresponding variable-is used, we assume that the projection declarations -- ignoring the-additional arguments to prevent the space leak -- are actually defined-by $f_i$~$t$~\texttt{= I}~$v_i$, using a private renaming type-\begin{verbatim}-  newtype Identity a = I a-\end{verbatim}-As newtype constructors are completely transparent to the compiler,-this does not change the generated code, but only the types of the-selector functions.-\begin{verbatim}--> sharePatternRhs :: ModuleIdent -> ValueEnv -> Decl -> SimplifyState [Decl]-> sharePatternRhs m tyEnv (PatternDecl p t rhs) =->   case t of->     VariablePattern _ -> return [PatternDecl p t rhs]->     _ -> ->       do->         v0 <- freshIdent m patternId (monoType (typeOf tyEnv t))->         let v = addRefId (srcRefOf p) v0->         return [PatternDecl p t (SimpleRhs p (mkVar v) []),->                 PatternDecl p (VariablePattern v) rhs]->   where patternId n = mkIdent ("_#pat" ++ show n)-> sharePatternRhs _ _ d = return [d]--> expandPatternBindings :: SimplifyFlags -> ModuleIdent -> ValueEnv -> [Ident] ->    -> Decl -> SimplifyState [Decl]->-> expandPatternBindings flags m tyEnv fvs (PatternDecl p t (SimpleRhs p' e _)) =->   case t of->     VariablePattern _ -> return [PatternDecl p t (SimpleRhs p' e [])]->     _->       | flatFlag flags ->->           do->             fs <- sequence (zipWith getId tys vs)->             return (zipWith (flatProjectionDecl p t e) fs vs)->       | otherwise ->->           do->             fs <- mapM (freshIdent m fpSelectorId . selectorType ty)->                        (shuffle tys)->             return (zipWith (projectionDecl p t e) fs (shuffle vs))->->       where getId t v = freshIdent m ->                            (\ i -> updIdentName ( ++'#':name v) (fpSelectorId i))->                            (flatSelectorType ty t)->             ->             vs = filter (`elem` fvs) (bv t)->             ty = typeOf tyEnv t->             tys = map (typeOf tyEnv) vs->             selectorType ty0 (ty:tys) =->               polyType (foldr TypeArrow (identityType ty) (ty0:tys))->->             selectorDecl p f t (v:vs) =->               funDecl p f (t:map VariablePattern vs) (mkVar v)->             projectionDecl p t e f (v:vs) =->               varDecl p v (Let [selectorDecl p f t (v:vs)]->                                (foldl applyVar (Apply (mkVar f) e) vs))->->             flatSelectorType ty0 ty =->               polyType (TypeArrow ty0 (identityType ty))->             flatSelectorDecl p f t v = funDecl p f [t] (mkVar v)->             flatProjectionDecl p t e f v =->               varDecl p v (Let [flatSelectorDecl p f t v] (Apply (mkVar f) e))->-> expandPatternBindings _ _ _ _ d = return [d]--\end{verbatim}-Auxiliary functions-\begin{verbatim}--> isVarPattern :: ConstrTerm -> Bool-> isVarPattern (VariablePattern _) = True-> isVarPattern (AsPattern _ t) = isVarPattern t-> isVarPattern (ConstructorPattern _ _) = False-> isVarPattern (LiteralPattern _) = False--> funType :: ModuleIdent -> ValueEnv -> QualIdent -> Type-> funType m tyEnv f =->   case (qualLookupValue f tyEnv) of->     [Value _ (ForAll _ ty)] -> ty->     vs -> case (qualLookupValue (qualQualify m f) tyEnv) of->             [Value _ (ForAll _ ty)] -> ty->             _ -> internalError ("funType " ++ show f)--> evMode :: EvalEnv -> Ident -> Maybe EvalAnnotation-> evMode evEnv f = Map.lookup f evEnv--> freshIdent :: ModuleIdent -> (Int -> Ident) -> TypeScheme->            -> SimplifyState Ident-> freshIdent m f ty =->   do->     x <- liftM f (S.lift (R.lift ( S.modify succ >> S.get)))->     S.modify (bindFun m x ty)->     return x--> shuffle :: [a] -> [[a]]-> shuffle xs = shuffle id xs->   where shuffle _ [] = []->         shuffle f (x:xs) = (x : f xs) : shuffle (f . (x:)) xs--> mkVar :: Ident -> Expression-> mkVar = Variable . qualify--> applyVar :: Expression -> Ident -> Expression-> applyVar e v = Apply e (mkVar v)--> varDecl :: Position -> Ident -> Expression -> Decl-> varDecl p v e = PatternDecl p (VariablePattern v) (SimpleRhs p e [])--> funDecl :: Position -> Ident -> [ConstrTerm] -> Expression -> Decl-> funDecl p f ts e =->   FunctionDecl p f [Equation p (FunLhs f ts) (SimpleRhs p e [])]--> identityType :: Type -> Type-> identityType = TypeConstructor qIdentityId . return->   where qIdentityId = qualify (mkIdent "Identity")--\end{verbatim}
− src/Subst.lhs 
@@ -1,124 +0,0 @@-% Copyright (c) 2002, Wolfgang Lux-% See LICENSE for the full license.-%-\nwfilename{Subst.lhs}-\section{Substitutions}-The module {\tt Subst} implements substitutions. A substitution-$\sigma = \left\{x_1\mapsto t_1,\dots,x_n\mapsto t_n\right\}$ is a-finite mapping from (finitely many) variables $x_1,\dots,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).-\begin{verbatim}--> module Subst where--> import qualified Data.Map as Map--> data Subst a b = Subst Bool (Map.Map a b) deriving Show--> idSubst :: Ord a => Subst a b-> idSubst = Subst False Map.empty--> substToList :: Ord v => Subst v e -> [(v,e)]-> substToList (Subst _ sigma) = Map.toList sigma--> bindSubst :: Ord v => v -> e -> Subst v e -> Subst v e-> bindSubst v e (Subst comp sigma) = Subst comp (Map.insert v e sigma)--> unbindSubst :: Ord v => v -> Subst v e -> Subst v e-> unbindSubst v (Subst comp sigma) = Subst comp (Map.delete v sigma)--\end{verbatim}-For any substitution we have the following definitions:-\begin{displaymath}-  \begin{array}{l}-    \sigma(x) = \left\{\begin{array}{ll}-        t_i&\mbox{if $x=x_i$}\\-        x&\mbox{otherwise}\end{array}\right. \\-    \mathop{{\mathcal D}om}(\sigma) = \left\{x_1,\dots,x_n\right\} \\-    \mathop{{\mathcal C}odom}(\sigma) = \left\{t_1,\dots,t_n\right\}-  \end{array}  -\end{displaymath}-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:-\begin{verbatim}--class Ord v => Subst v e where-  var :: v -> e-  subst :: Subst v e -> e -> e--\end{verbatim}-With the help of the injection \texttt{var}, we can then compute the-substitution for a variable $\sigma(v)$ and also the composition of-two substitutions-$(\sigma_1 \circ \sigma_2)(e) \mathop{:=} \sigma_1(\sigma_2(e))$. A-naive implementation of the composition were-\begin{verbatim}-  compose sigma sigma' =-    foldr (uncurry bindSubst) sigma (substToList (fmap (subst sigma) sigma'))-\end{verbatim}-However, such an implementation is very inefficient because the-number of substiutions applied to a variable increases in-$\mathcal{O}(n)$ of the number of compositions.--A more efficient implementation is to apply \texttt{subst} again to-the value substituted for a variable in-$\mathop{{\mathcal D}om}(\sigma)$. However, this is correct only as-long as the result of the substitution does not include any variables-which are in $\mathop{{\mathcal D}om}(\sigma)$. For instance, it is-impossible to implement simple variable renamings in this way.--Therefore we use the simple strategy to apply \texttt{subst} again-only in case of a substitution which was returned from \texttt{compose}.-\begin{verbatim}--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 :: (Show v,Ord v,Show e) => Subst v e -> Subst v e -> Subst v e-> compose sigma sigma' =->   composed (foldr (uncurry bindSubst) sigma' (substToList sigma))->   where dom = domain sigma->         dom' = domain sigma'->         domain = map fst . substToList->         composed (Subst _ sigma) = Subst True sigma--\end{verbatim}-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-\texttt{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 \texttt{IntSubst} for substitution whose-domain are integer numbers.-\begin{verbatim}--> 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--> class IntSubst e where->   ivar :: Int -> e->   isubst :: Subst Int e -> e -> e--> isubstVar :: IntSubst e => Subst Int e -> Int -> e-> isubstVar = substVar' ivar isubst--\end{verbatim}-The function \texttt{restrictSubstTo} implements the restriction of a-substitution to a given subset of its domain.-\begin{verbatim}--> 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))--\end{verbatim}
− src/SyntaxCheck.lhs 
@@ -1,1149 +0,0 @@--% $Id: SyntaxCheck.lhs,v 1.53 2004/02/15 22:10:37 wlux Exp $-%-% Copyright (c) 1999-2004, Wolfgang Lux-% See LICENSE for the full license.-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-%-\nwfilename{SyntaxCheck.lhs}-\section{Syntax Checks}-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 unique-key.\footnote{Actually, all variables defined in the same scope share-the same key.} Finally, all (adjacent) equations of a function are-merged into a single definition.-\begin{verbatim}--> module SyntaxCheck(syntaxCheck) where--> import Data.Maybe-> import Data.List-> import qualified Data.Map as Map-> import Control.Monad.State as S--> import Curry.Syntax-> import Curry.Syntax.Utils-> import Types-> import Curry.Base.Position-> import Curry.Base.Ident-> import Base-> import NestEnv-> import Utils--\end{verbatim}-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.-\begin{verbatim}--> syntaxCheck :: Bool -> ModuleIdent -> ImportEnv -> ArityEnv -> ValueEnv -> TCEnv -> [Decl] -> [Decl]-> syntaxCheck withExt m iEnv aEnv tyEnv tcEnv ds =->   case findDouble (concatMap constrs tds) of->     --Nothing -> tds ++ run (checkModule withExt m env vds)->     Nothing -> map (checkTypeDecl withExt m) tds->	        ++ run (checkModule withExt m env2 vds)->     Just c -> errorAt' (duplicateData c)->   where (tds,vds) = partition isTypeDecl ds->	  (rs, tds') = partition isRecordDecl tds->         env1 = foldr (bindTypes m) -- (bindConstrs m) ->	               (globalEnv (fmap (renameInfo tcEnv iEnv aEnv) tyEnv)) ->	               tds'->	  env2 = foldr (bindTypes m) env1 rs--\end{verbatim}-A global state transformer is used for generating fresh integer keys-by which the variables get renamed.-\begin{verbatim}--> type RenameState a = S.State Int a--> run :: RenameState a -> a-> run m = S.evalState m (globalKey + 1)--> newId :: RenameState Int-> newId = S.modify succ >> S.get--\end{verbatim}-\ToDo{Probably the state transformer should use an \texttt{Integer} -counter.}--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--\em{Note:} the function \texttt{qualLookupVar} has been extended to-allow the usage of the qualified list constructor \texttt{(prelude.:)}.-\begin{verbatim}--> type RenameEnv = NestEnv RenameInfo-> data RenameInfo = Constr Int ->                 | GlobalVar Int QualIdent ->                 | LocalVar Int Ident->	          | RecordLabel QualIdent [Ident]->	    deriving (Eq,Show)--> globalKey :: Int-> globalKey = uniqueId (mkIdent "")--> renameInfo :: TCEnv -> ImportEnv -> ArityEnv -> ValueInfo -> RenameInfo-> renameInfo tcEnv iEnv aEnv (DataConstructor _ (ForAllExist _ _ ty)) ->    = Constr (arrowArity ty)-> renameInfo tcEnv iEnv aEnv (NewtypeConstructor _ _) ->    = Constr 1-> renameInfo tcEnv iEnv aEnv (Value qid _)->    = let (mmid, id) = (qualidMod qid, qualidId qid)->          qid' = maybe qid ->	                (\mid -> maybe qid ->		                       (\mid' -> qualifyWith mid' id)->				       (lookupAlias mid iEnv))->		        mmid->      in case (lookupArity id aEnv) of->	    [ArityInfo _ arity] -> GlobalVar arity qid->           rs -> case (qualLookupArity qid' aEnv) of->	            [ArityInfo _ arity] -> GlobalVar arity qid->	            _ -> maybe (internalError "renameInfo: missing arity")->	                       (\ (ArityInfo _ arity) -> GlobalVar arity qid)->		               (find (\ (ArityInfo qid'' _) ->			              -> qid'' == qid) rs)-> renameInfo tcEnv iEnv aEnv (Label l r _)->    = case (qualLookupTC r tcEnv) of->        [AliasType _ _ (TypeRecord fs _)] ->->          RecordLabel r (map fst fs)->        _ -> internalError "renameInfo: no record"--\end{verbatim}-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.-\begin{verbatim}--> bindTypes :: ModuleIdent -> Decl -> RenameEnv -> RenameEnv-> bindTypes m (DataDecl _ tc _ cs) env = foldr (bindConstr m) env cs-> bindTypes m (NewtypeDecl _ tc _ nc) env = bindNewConstr m nc env-> bindTypes m (TypeDecl _ t _ (RecordType fs r)) env =->    -- - | isJust r = internalError "bindTypes: illegal record declaration"->    -- - | null fs = errorAt (positionOfIdent t) emptyRecord->    -- - | otherwise =->      case (qualLookupVar (qualifyWith m t) env) of->        [] -> foldr (bindRecordLabel m t (concatMap fst fs)) env fs->        rs | any isConstr rs -> errorAt' (illegalRecordId t)->           | otherwise->             -> foldr (bindRecordLabel m t (concatMap fst fs)) env fs-> bindTypes _ _ env = env--> bindRecordLabel :: ModuleIdent -> Ident -> [Ident] ->	             -> ([Ident],TypeExpr) -> RenameEnv -> RenameEnv-> bindRecordLabel m t labels (ls,_) env = ->     foldr (\l -> case (lookupVar l env) of->                    [] -> bindGlobal m l->                             (RecordLabel (qualifyWith m t) labels)->                    _  -> errorAt' (duplicateDefinition l)->	    ) env ls--> --bindConstrs :: ModuleIdent -> Decl -> RenameEnv -> RenameEnv-> --bindConstrs m (DataDecl _ tc _ cs) env = foldr (bindConstr m) env cs-> --bindConstrs m (NewtypeDecl _ tc _ nc) env = bindNewConstr m nc env-> --bindConstrs _ _ env = env--> bindConstr :: ModuleIdent -> ConstrDecl -> RenameEnv -> RenameEnv-> bindConstr m (ConstrDecl _ _ c tys) = bindGlobal m c (Constr (length tys))-> bindConstr m (ConOpDecl _ _ _ op _) = bindGlobal m op (Constr 2)--> bindNewConstr :: ModuleIdent -> NewConstrDecl -> RenameEnv -> RenameEnv-> bindNewConstr m (NewConstrDecl _ _ c _) = bindGlobal m c (Constr 1)--> bindFuncDecl :: ModuleIdent -> Decl -> RenameEnv -> RenameEnv-> bindFuncDecl m (FunctionDecl _ id equs) env->    | null equs = internalError "bindFuncDecl: missing equations"->    | otherwise = let (_,ts) = getFlatLhs (head equs)->		   in  bindGlobal m ->	                          id ->			          (GlobalVar (length ts) (qualifyWith m id))->	                          env-> bindFuncDecl m (ExternalDecl _ _ _ id texpr) env->    = bindGlobal m id (GlobalVar (typeArity texpr) (qualifyWith m id)) env-> bindFuncDecl m (TypeSig _ ids texpr) env->    = foldr bindTS env (map (qualifyWith m) ids)->  where->  bindTS qid env ->     | null (qualLookupVar qid env)->       = bindGlobal m (unqualify qid) (GlobalVar (typeArity texpr) qid) env->     | otherwise->       = env-> bindFuncDecl _ _ env = env--> bindVarDecl :: Decl -> RenameEnv -> RenameEnv-> bindVarDecl (FunctionDecl _ id equs) env->    | null equs ->      = internalError "bindFuncDecl: missing equations"->    | otherwise ->      = let (_,ts) = getFlatLhs (head equs)->	 in  bindLocal (unRenameIdent id) (LocalVar (length ts) id) env-> bindVarDecl (PatternDecl p t _) env->    = foldr bindVar env (bv t)-> bindVarDecl (ExtraVariables p vs) env->    = foldr bindVar env vs -> bindVarDecl _ env = env--> bindVar :: Ident -> RenameEnv -> RenameEnv-> bindVar v env->   | v' == anonId = env->   | otherwise = bindLocal v' (LocalVar 0 v) env->   where v' = unRenameIdent v--> bindGlobal :: ModuleIdent -> Ident -> RenameInfo -> RenameEnv -> RenameEnv-> bindGlobal m c r = bindNestEnv c r . qualBindNestEnv (qualifyWith m c) r--> bindLocal :: Ident -> RenameInfo -> RenameEnv -> RenameEnv-> bindLocal f r = bindNestEnv f r--> 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)--> qualLookupListCons :: QualIdent -> RenameEnv -> [RenameInfo]-> qualLookupListCons v env->    | (isJust mmid) && ((fromJust mmid) == preludeMIdent) && (ident == consId)->       = qualLookupNestEnv (qualify ident) env->    | otherwise = []->  where (mmid, ident) = (qualidMod v, qualidId v)--> lookupTupleConstr :: Ident -> [RenameInfo]-> lookupTupleConstr v->   | isTupleId v = [Constr (tupleArity v)]->   | otherwise = []--\end{verbatim}-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.-\begin{verbatim}--> checkModule :: Bool -> ModuleIdent -> RenameEnv -> [Decl] -> RenameState [Decl]-> checkModule withExt m env ds = liftM snd (checkTopDecls withExt m env ds)--> checkTopDecls :: Bool -> ModuleIdent -> RenameEnv -> [Decl]->               -> RenameState (RenameEnv,[Decl])-> checkTopDecls withExt m env ds = ->   checkDeclGroup (bindFuncDecl m) withExt m globalKey env ds--> checkTypeDecl :: Bool -> ModuleIdent -> Decl -> Decl-> checkTypeDecl withExt m d@(TypeDecl p r tvs (RecordType fs rty))->   | not withExt = errorAt (positionOfIdent r) noRecordExt->   | isJust rty = internalError "checkTypeDecl - illegal record type"->   | null fs = errorAt (positionOfIdent r) emptyRecord->   | otherwise = TypeDecl p r tvs (RecordType fs Nothing)-> checkTypeDecl _ _ d = d--\end{verbatim}-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 \texttt{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 \verb|where Just x = y|-because the parser cannot distinguish nullary constructors and-functions. Note that pattern declarations are not allowed on the-top-level.-\begin{verbatim}--> checkLocalDecls :: Bool -> ModuleIdent -> RenameEnv -> [Decl] ->                  -> RenameState (RenameEnv,[Decl])-> checkLocalDecls withExt m env ds =->   newId >>= \k -> checkDeclGroup bindVarDecl withExt m k (nestEnv env) ds--> checkDeclGroup :: (Decl -> RenameEnv -> RenameEnv) -> Bool -> ModuleIdent->                 -> Int -> RenameEnv -> [Decl] ->                 -> RenameState (RenameEnv,[Decl])-> checkDeclGroup bindDecl withExt m k env ds =->   mapM (checkDeclLhs withExt k m env) ds' >>=->   checkDecls bindDecl withExt m env . joinEquations->  where ds' = sortFuncDecls ds--> checkDeclLhs :: Bool -> Int -> ModuleIdent -> RenameEnv -> Decl -> RenameState Decl-> checkDeclLhs withExt k _ _ (InfixDecl p fix pr ops) =->   return (InfixDecl p fix pr (map (flip renameIdent k) ops))-> checkDeclLhs withExt k _ env (TypeSig p vs ty) =->   return (TypeSig p (map (checkVar "type signature" k env) vs) ty)-> checkDeclLhs withExt k _ env (EvalAnnot p fs ev) =->   return (EvalAnnot p (map (checkVar "evaluation annotation" k env) fs) ev)-> checkDeclLhs withExt k m env (FunctionDecl p _ eqs) = ->   checkEquationLhs withExt k m env p eqs-> checkDeclLhs withExt k _ env (ExternalDecl p cc ie f ty) =->   return (ExternalDecl p cc ie (checkVar "external declaration" k env f) ty)-> checkDeclLhs withExt k _ env (FlatExternalDecl p fs) =->   return (FlatExternalDecl p->             (map (checkVar "external declaration" k env) fs))-> checkDeclLhs withExt k m env (PatternDecl p t rhs) =->   do->     t' <- checkConstrTerm withExt k p m env t->     return (PatternDecl p t' rhs)-> checkDeclLhs withExt k _ env (ExtraVariables p vs) =->   return (ExtraVariables p->             (map (checkVar "free variables declaration" k env) vs))-> checkDeclLhs _ _ _ _ d = return d--> checkEquationLhs :: Bool -> Int -> ModuleIdent -> RenameEnv -> Position ->	           -> [Equation] -> RenameState Decl-> checkEquationLhs withExt k m env p [Equation p' lhs rhs] =->   either (return . funDecl) (checkDeclLhs withExt k m env . patDecl)->          (checkEqLhs m k env p' lhs)->   where funDecl (f,lhs) = FunctionDecl p f [Equation p' lhs rhs]->         patDecl t->           | k == globalKey = errorAt p noToplevelPattern->           | otherwise = PatternDecl p' t rhs-> checkEquationLhs _ _ _ _ _ _ = internalError "checkEquationLhs"--> checkEqLhs :: ModuleIdent -> Int -> RenameEnv -> Position -> Lhs->            -> Either (Ident,Lhs) ConstrTerm-> checkEqLhs m k env _ (FunLhs f ts)->   | isDataConstr f env->     = if k /= globalKey->       then Right (ConstructorPattern (qualify f) ts)->       else if null (qualLookupVar (qualifyWith m f) env)->            then Left (f',FunLhs f' ts)->	     else errorAt (positionOfIdent f) noToplevelPattern->   | otherwise = Left (f',FunLhs f' ts)->   where f' = renameIdent f k-> checkEqLhs m k env p (OpLhs t1 op t2)->   | isDataConstr op env ->     = if k /= globalKey->       then checkOpLhs k env (infixPattern t1 (qualify op)) t2->       else if null (qualLookupVar (qualifyWith m op) env)->            then Left (op',OpLhs t1 op' t2)->	     else errorAt p noToplevelPattern->   | otherwise = Left (op',OpLhs t1 op' t2)->   where op' = renameIdent op k->         infixPattern (InfixPattern t1 op1 t2) op2 t3 =->           InfixPattern t1 op1 (infixPattern t2 op2 t3)->         infixPattern t1 op t2 = InfixPattern t1 op t2-> checkEqLhs m k env p (ApLhs lhs ts) =->   case checkEqLhs m k env p lhs of->     Left (f',lhs') -> Left (f',ApLhs lhs' ts)->     Right _ -> errorAt' $ nonVariable "curried definition" f->   where (f,_) = flatLhs lhs--> checkOpLhs :: Int -> RenameEnv -> (ConstrTerm -> ConstrTerm) -> ConstrTerm->            -> Either (Ident,Lhs) ConstrTerm-> 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') = (qualidMod op, qualidId op)->         op'' = renameIdent op' k-> checkOpLhs _ _ f t = Right (f t)--> checkVar :: String -> Int -> RenameEnv -> Ident -> Ident-> checkVar what k env v ->   | False && isDataConstr v env = errorAt' (nonVariable what v)---------------->   | otherwise = renameIdent v k---> checkDecls :: (Decl -> RenameEnv -> RenameEnv) -> Bool -> ModuleIdent->	        -> RenameEnv -> [Decl] -> RenameState (RenameEnv,[Decl])-> checkDecls bindDecl withExt m env ds = ->   case findDouble bvs of->     Nothing ->->       case findDouble tys of->         Nothing ->->           case findDouble evs of->             Nothing ->->               case filter (`notElem` tys) fs' of->                 [] -> liftM ((,) env') ->		              (mapM (checkDeclRhs withExt bvs m env'') ds)->                 f : _ -> errorAt' (noTypeSig f)->             Just v -> errorAt' (duplicateEvalAnnot v)->         Just v -> errorAt' (duplicateTypeSig v)->     Just v -> errorAt' (duplicateDefinition v)->   where vds = filter isValueDecl ds->	  tds = filter isTypeSig ds->         bvs = concat (map vars vds)->         tys = concat (map vars tds)->         evs = concat (map vars (filter isEvalAnnot ds))->         fs' = [f | FlatExternalDecl _ fs <- ds, f <- fs]->         env' = foldr bindDecl env vds->         env'' = foldr bindDecl env' tds--> checkDeclRhs :: Bool -> [Ident] -> ModuleIdent -> RenameEnv -> Decl ->              -> RenameState Decl-> checkDeclRhs withExt bvs _ _ (TypeSig p vs ty) =->   return (TypeSig p (map (checkLocalVar bvs ) vs) ty)-> checkDeclRhs withExt bvs _ _ (EvalAnnot p vs ev) =->   return (EvalAnnot p (map (checkLocalVar bvs ) vs) ev)-> checkDeclRhs withExt _ m env (FunctionDecl p f eqs) =->   liftM (FunctionDecl p f) (mapM (checkEquation withExt m env) eqs)-> checkDeclRhs withExt _ m env (PatternDecl p t rhs) =->   liftM (PatternDecl p t) (checkRhs withExt m env rhs)-> checkDeclRhs _ _ _ _ d = return d--> checkLocalVar :: [Ident] -> Ident -> Ident-> checkLocalVar bvs v->   | v `elem` bvs = v->   | otherwise = errorAt' (noBody v)--> joinEquations :: [Decl] -> [Decl]-> joinEquations [] = []-> joinEquations (FunctionDecl p f eqs : FunctionDecl p' f' [eq] : ds)->   | f == f' =->       if arity (head eqs) == arity eq then->         joinEquations (FunctionDecl p f (eqs ++ [eq]) : ds)->       else->         errorAt' (differentArity f)->   where arity (Equation _ lhs _) = length $ snd $ flatLhs lhs-> joinEquations (d : ds) = d : joinEquations ds--> checkEquation :: Bool -> ModuleIdent -> RenameEnv -> Equation -> RenameState Equation-> checkEquation withExt m env (Equation p lhs rhs) =->   do->     (env',lhs') <- checkLhs withExt p m env lhs->     rhs' <- checkRhs withExt m env' rhs->     return (Equation p lhs' rhs')--> checkLhs :: Bool -> Position -> ModuleIdent -> RenameEnv -> Lhs ->             -> RenameState (RenameEnv,Lhs)-> checkLhs withExt p m env lhs =->   newId >>= \k ->->   checkLhsTerm withExt k p m env lhs >>=->   return . checkConstrTerms withExt (nestEnv env)--> checkLhsTerm :: Bool -> Int -> Position -> ModuleIdent -> RenameEnv -> Lhs ->                 -> RenameState Lhs-> checkLhsTerm withExt k p m env (FunLhs f ts) =->   do->     ts' <- mapM (checkConstrTerm withExt k p m env) ts->     return (FunLhs f ts')-> checkLhsTerm withExt k p m env (OpLhs t1 op t2) =->   let wrongCalls = concatMap (checkParenConstrTerm (Just (qualify op)))->                               [t1,t2] in->   if not (null wrongCalls)->     then errorAt (positionOfIdent op) ->                  (infixWithoutParens wrongCalls)->     else  do->       t1' <- checkConstrTerm withExt k p m env t1->       t2' <- checkConstrTerm withExt k p m env t2 ->       return (OpLhs t1' op t2')->-> checkLhsTerm withExt k p m env (ApLhs lhs ts) =->   do->     lhs' <- checkLhsTerm withExt k p m env lhs->     ts' <- mapM (checkConstrTerm withExt k p m env) ts->     return (ApLhs lhs' ts')--> checkArgs :: Bool -> Position -> ModuleIdent -> RenameEnv -> [ConstrTerm]->           -> RenameState (RenameEnv,[ConstrTerm])-> checkArgs withExt p m env ts =->   newId >>= \k ->->   mapM (checkConstrTerm withExt k p m env) ts >>=->   return . checkConstrTerms withExt (nestEnv env)--> checkConstrTerms :: QuantExpr t => Bool -> RenameEnv -> t->                  -> (RenameEnv,t)-> checkConstrTerms withExt env ts =->   case findDouble bvs of->     Nothing -> (foldr bindVar env bvs,ts)->     Just v -> errorAt' (duplicateVariable v)->   where bvs = bv ts--> checkConstrTerm :: Bool -> Int -> Position -> ModuleIdent -> RenameEnv->	             -> ConstrTerm -> RenameState ConstrTerm-> checkConstrTerm _ _ _ _ _ (LiteralPattern l) =->   liftM LiteralPattern (renameLiteral l)-> checkConstrTerm _ _ _ _ _ (NegativePattern op l) =->   liftM (NegativePattern op) (renameLiteral l)-> checkConstrTerm withExt k p m env (VariablePattern v)->   | v == anonId ->     = liftM (VariablePattern . renameIdent anonId) newId->   | otherwise ->     = checkConstrTerm withExt k p m env (ConstructorPattern (qualify v) [])-> checkConstrTerm withExt k p m env (ConstructorPattern c ts) =->   case qualLookupVar c env of->     [Constr n]->       | n == n' ->->           liftM (ConstructorPattern c) ->	          (mapM (checkConstrTerm withExt k p m env) ts)->       | otherwise -> errorAt' (wrongArity c n n')->       where n' = length ts->     [r]->       | null ts && not (isQualified c) ->->	    return (VariablePattern (renameIdent (varIdent r) k))->       | withExt ->->           do ts' <- mapM (checkConstrTerm withExt k p m env) ts->	       if n' > n->	          then let (ts1,ts2) = splitAt n ts'->	               in  return (genFuncPattAppl ->			             (FunctionPattern (qualVarIdent r) ->				                      ts1) ->	                             ts2)->	          else return (FunctionPattern (qualVarIdent r) ts')->       | otherwise -> errorAt (positionOfQualIdent c) noFuncPattExt  ->	where n = arity r->	      n' = length ts->     rs -> case (qualLookupVar (qualQualify m c) env) of->             []->               | null ts && not (isQualified c) ->->	            return (VariablePattern (renameIdent (unqualify c) k))->	        | null rs -> errorAt' (undefinedData c)->		| otherwise -> errorAt' (ambiguousData c)->             [Constr n]->               | n == n' ->->                   liftM (ConstructorPattern (qualQualify m c)) ->                         (mapM (checkConstrTerm withExt k p m env) ts)->               | otherwise -> errorAt' (wrongArity c n n')->               where n' = length ts->	      [r]->	        | null ts && not (isQualified c) ->->                   return (VariablePattern (renameIdent (varIdent r) k))->               | withExt ->->	            do ts' <- mapM (checkConstrTerm withExt k p m env) ts->	               if n' > n->	                  then let (ts1,ts2) = splitAt n ts'->	                       in  return ->			             (genFuncPattAppl ->			                (FunctionPattern (qualVarIdent r) ts1) ->	                                ts2)->	                  else return (FunctionPattern (qualVarIdent r) ts')->	        | otherwise -> errorAt (positionOfQualIdent c) noFuncPattExt->               where n = arity r->		      n' = length ts->             _ -> errorAt' (ambiguousData c)-> checkConstrTerm withExt k p m env (InfixPattern t1 op t2) =->   case (qualLookupVar op env) of->     [Constr n]->       | n == 2 ->->           do t1' <- checkConstrTerm withExt k p m env t1->	       t2' <- checkConstrTerm withExt k p m env t2->              return (InfixPattern t1' op t2') ->       | otherwise -> errorAt' (wrongArity op n 2)->     [r]->       | withExt ->->           do t1' <- checkConstrTerm withExt k p m env t1->	       t2' <- checkConstrTerm withExt k p m env t2->              return (InfixFuncPattern t1' op t2')->       | otherwise -> errorAt p noFuncPattExt    ->     rs -> case (qualLookupVar (qualQualify m op) env) of->             [] | null rs -> errorAt' (undefinedData op)->                | otherwise -> errorAt' (ambiguousData op)->             [Constr n]->               | n == 2 ->->                   do t1' <- checkConstrTerm withExt k p m env t1->	               t2' <- checkConstrTerm withExt k p m env t2->                      return (InfixPattern t1' (qualQualify m op) t2') ->               | otherwise -> errorAt' (wrongArity op n 2)->	      [r]->               | withExt ->->	            do t1' <- checkConstrTerm withExt k p m env t1->	               t2' <- checkConstrTerm withExt k p m env t2->		       return (InfixFuncPattern t1' (qualQualify m op) t2')->	        | otherwise -> errorAt p noFuncPattExt->             _ -> errorAt' (ambiguousData op)-> checkConstrTerm withExt k p m env (ParenPattern t) =->   liftM ParenPattern (checkConstrTerm withExt k p m env t)-> checkConstrTerm withExt k p m env (TuplePattern pos ts) =->   liftM (TuplePattern pos) (mapM (checkConstrTerm withExt k p m env) ts)-> checkConstrTerm withExt k p m env (ListPattern pos ts) =->   liftM (ListPattern pos) (mapM (checkConstrTerm withExt k p m env) ts)-> checkConstrTerm withExt k p m env (AsPattern v t) =->   liftM (AsPattern (checkVar "@ pattern" k env v))->         (checkConstrTerm withExt k p m env t)-> checkConstrTerm withExt k p m env (LazyPattern pos t) =->   liftM (LazyPattern pos) (checkConstrTerm withExt k p m env t)-> checkConstrTerm withExt k p m env (RecordPattern fs t)->   | not withExt = errorAt p noRecordExt->   | not (null fs) =->     let (Field _ label _) = head fs->     in  case (lookupVar label env) of->           [] -> errorAt' (undefinedLabel label)->           [RecordLabel r ls]->             | not (null duplicates) ->->	        errorAt' (duplicateLabel (head duplicates))->	      | isNothing t && not (null missings) ->->	        errorAt (positionOfIdent label) ->                       (missingLabel (head missings) r "record pattern")->             | maybe True ((==) (VariablePattern anonId)) t ->->	        do fs' <- mapM (checkFieldPatt withExt k m r env) fs->	           t'  <- maybe (return Nothing)->	                        (\t' -> checkConstrTerm withExt k p m env t'->			                >>= return . Just)->			        t->	           return (RecordPattern fs' t')->	      | otherwise -> errorAt p illegalRecordPatt->            where ls' = map fieldLabel fs->                  duplicates = maybeToList (dup ls')->		   missings = ls \\ ls'->	    [_] -> errorAt' (notALabel label)->	    _ -> errorAt' (duplicateDefinition label)->   | otherwise = errorAt p emptyRecord--> checkFieldPatt :: Bool -> Int -> ModuleIdent -> QualIdent -> RenameEnv->	            -> Field ConstrTerm -> RenameState (Field ConstrTerm)-> checkFieldPatt withExt k m r env (Field p l t)->    = case (lookupVar l env) of->        [] -> errorAt' (undefinedLabel l)->        [RecordLabel r' _]->          | r == r' -> do t' <- checkConstrTerm withExt k ->                                   (positionOfIdent l) m env t->		           return (Field p l t')->          | otherwise -> errorAt' (illegalLabel l r)->        [_] -> errorAt' (notALabel l)->	 _ -> errorAt' (duplicateDefinition l)--> checkRhs :: Bool -> ModuleIdent -> RenameEnv -> Rhs -> RenameState Rhs-> checkRhs withExt m env (SimpleRhs p e ds) =->   do->     (env',ds') <- checkLocalDecls withExt m env ds->     e' <- checkExpr withExt p m env' e->     return (SimpleRhs p e' ds')-> checkRhs withExt m env (GuardedRhs es ds) =->   do->     (env',ds') <- checkLocalDecls withExt m env ds->     es' <- mapM (checkCondExpr withExt m env') es->     return (GuardedRhs es' ds')--> checkCondExpr :: Bool -> ModuleIdent -> RenameEnv -> CondExpr -> RenameState CondExpr-> checkCondExpr withExt m env (CondExpr p g e) =->   do->     g' <- checkExpr withExt p m env g->     e' <- checkExpr withExt p m env e->     return (CondExpr p g' e')--> checkExpr :: Bool -> Position -> ModuleIdent -> RenameEnv -> Expression ->           -> RenameState Expression-> checkExpr _ _ _ _ (Literal l) = liftM Literal (renameLiteral l)-> checkExpr withExt _ m env (Variable v) =->   case (qualLookupVar v env) of->     [] ->  errorAt' (undefinedVariable v)->     [Constr _] -> return (Constructor v)->     [GlobalVar _ _] -> return (Variable v)->     [LocalVar _ v'] -> return (Variable (qualify v'))->     rs -> case (qualLookupVar (qualQualify m v) env) of->             [] -> errorAt' (ambiguousIdent rs v)->             [Constr _] -> return (Constructor v)->             [GlobalVar _ _] -> return (Variable v)->             [LocalVar _ v'] -> return (Variable (qualify v'))->             rs' -> errorAt' (ambiguousIdent rs' v)-> checkExpr withExt p m env (Constructor c) = ->   checkExpr withExt p m env (Variable c)-> checkExpr withExt p m env (Paren e) = ->   liftM Paren (checkExpr withExt p m env e)-> checkExpr withExt p m env (Typed e ty) = ->   liftM (flip Typed ty) (checkExpr withExt p m env e)-> checkExpr withExt p m env (Tuple pos es) = ->   liftM (Tuple pos) (mapM (checkExpr withExt p m env) es)-> checkExpr withExt p m env (List pos es) = ->   liftM (List pos) (mapM (checkExpr withExt p m env) es)-> checkExpr withExt p m env (ListCompr pos e qs) =->   do->     (env',qs') <- mapAccumM (checkStatement withExt p m) env qs->     e' <- checkExpr withExt p m env' e->     return (ListCompr pos e' qs')-> checkExpr withExt p m env (EnumFrom e) = ->   liftM EnumFrom (checkExpr withExt p m env e)-> checkExpr withExt p m env (EnumFromThen e1 e2) =->   do->     e1' <- checkExpr withExt p m env e1->     e2' <- checkExpr withExt p m env e2->     return (EnumFromThen e1' e2')-> checkExpr withExt p m env (EnumFromTo e1 e2) =->   do->     e1' <- checkExpr withExt p m env e1->     e2' <- checkExpr withExt p m env e2->     return (EnumFromTo e1' e2')-> checkExpr withExt p m env (EnumFromThenTo e1 e2 e3) =->   do->     e1' <- checkExpr withExt p m env e1->     e2' <- checkExpr withExt p m env e2->     e3' <- checkExpr withExt p m env e3->     return (EnumFromThenTo e1' e2' e3')-> checkExpr withExt p m env (UnaryMinus op e) = ->   liftM (UnaryMinus op) (checkExpr withExt p m env e)-> checkExpr withExt p m env (Apply e1 e2) =->   do->     e1' <- checkExpr withExt p m env e1->     e2' <- checkExpr withExt p m env e2->     return (Apply e1' e2')-> checkExpr withExt p m env (InfixApply e1 op e2) =->   do->     e1' <- checkExpr withExt p m env e1->     e2' <- checkExpr withExt p m env e2->     return (InfixApply e1' (checkOp m env op) e2')-> checkExpr withExt p m env (LeftSection e op) =->   liftM (flip LeftSection (checkOp m env op)) (checkExpr withExt p m env e)-> checkExpr withExt p m env (RightSection op e) =->   liftM (RightSection (checkOp m env op)) (checkExpr withExt p m env e)-> checkExpr withExt p m env (Lambda r ts e) =->   do->     (env',ts') <- checkArgs withExt p m env ts->     e' <- checkExpr withExt p m env' e->     return (Lambda r ts' e')-> checkExpr withExt p m env (Let ds e) =->   do->     (env',ds') <- checkLocalDecls withExt m env ds->     e' <- checkExpr withExt p m env' e->     return (Let ds' e')-> checkExpr withExt p m env (Do sts e) =->   do->     (env',sts') <- mapAccumM (checkStatement withExt p m) env sts->     e' <- checkExpr withExt p m env' e->     return (Do sts' e')-> checkExpr withExt p m env (IfThenElse r e1 e2 e3) =->   do->     e1' <- checkExpr withExt p m env e1->     e2' <- checkExpr withExt p m env e2->     e3' <- checkExpr withExt p m env e3->     return (IfThenElse r e1' e2' e3')-> checkExpr withExt p m env (Case r e alts) =->   do->     e' <- checkExpr withExt p m env e->     alts' <- mapM (checkAlt withExt m env) alts->     return (Case r e' alts')-> checkExpr withExt p m env (RecordConstr fs)->   | not withExt = errorAt p noRecordExt->   | not (null fs) = ->     let (Field _ label _) = head fs->     in  case (lookupVar label env) of->           [] -> errorAt' (undefinedLabel label)->	    [RecordLabel r ls]->              | not (null duplicates) ->->                errorAt' (duplicateLabel (head duplicates))->              | not (null missings) ->->	         errorAt (positionOfIdent label) ->                        (missingLabel (head missings) r "record construction")->	       | otherwise ->->	         do fs' <- mapM (checkFieldExpr withExt m r env) fs->	            return (RecordConstr fs')->	      where ls' = map fieldLabel fs->	            duplicates = maybeToList (dup ls')->		    missings = ls \\ ls'->           [_] -> errorAt' (notALabel label)->	    _ -> errorAt' (duplicateDefinition label)->   | otherwise = errorAt p emptyRecord-> checkExpr withExt p m env (RecordSelection e l)->   | not withExt = errorAt p noRecordExt->   | otherwise =->     case (lookupVar l env) of->       [] -> errorAt' (undefinedLabel l)->       [RecordLabel r ls] ->->         do e' <- checkExpr withExt p m env e->            return (RecordSelection e' l)->       [_] -> errorAt' (notALabel l)->       _ -> errorAt' (duplicateDefinition l)-> checkExpr withExt p m env (RecordUpdate fs e)->   | not withExt = errorAt p noRecordExt->   | not (null fs) =->     let (Field _ label _) = head fs->     in  case (lookupVar label env) of->           [] -> errorAt' (undefinedLabel label)->	    [RecordLabel r ls]->             | not (null duplicates) ->->	        errorAt' (duplicateLabel (head duplicates))->	      | otherwise ->->	        do fs' <- mapM (checkFieldExpr withExt m r env) fs->	           e' <- checkExpr withExt (positionOfIdent label) m env e->	           return (RecordUpdate fs' e')->	      where duplicates = maybeToList (dup (map fieldLabel fs))->	    [_] -> errorAt' (notALabel label)->	    _ -> errorAt' (duplicateDefinition label)->   | otherwise = errorAt p emptyRecord--> checkStatement :: Bool -> Position -> ModuleIdent -> RenameEnv -> Statement->                -> RenameState (RenameEnv,Statement)-> checkStatement withExt p m env (StmtExpr pos e) =->   do->     e' <- checkExpr withExt p m env e->     return (env,StmtExpr pos e')-> checkStatement withExt p m env (StmtBind pos t e) =->   do->     e' <- checkExpr withExt p m env e->     (env',[t']) <- checkArgs withExt p m env [t]->     return (env',StmtBind pos t' e')-> checkStatement withExt _ m env (StmtDecl ds) =->   do->     (env',ds') <- checkLocalDecls withExt m env ds->     return (env',StmtDecl ds')--> checkAlt :: Bool -> ModuleIdent -> RenameEnv -> Alt -> RenameState Alt-> checkAlt withExt m env (Alt p t rhs) =->   do->     (env',[t']) <- checkArgs withExt p m env [t]->     rhs' <- checkRhs withExt m env' rhs->     return (Alt p t' rhs')--> checkFieldExpr :: Bool -> ModuleIdent -> QualIdent -> RenameEnv ->	            -> Field Expression -> RenameState (Field Expression)-> checkFieldExpr withExt m r env (Field p l e)->    = case (lookupVar l env) of->        [] -> errorAt' (undefinedLabel l)->        [RecordLabel r' _]->          | r == r' -> do e' <- checkExpr withExt (positionOfIdent l) m env e->		           return (Field p l e')->          | otherwise -> errorAt' (illegalLabel l r)->        [_] -> errorAt' (notALabel l)->	 _ -> errorAt' (duplicateDefinition l)---> checkOp :: ModuleIdent -> RenameEnv -> InfixOp -> InfixOp-> checkOp m env op =->   case (qualLookupVar v env) of->     [] -> errorAt' (undefinedVariable v)->     [Constr _] -> InfixConstr v->     [GlobalVar _ _] -> InfixOp v->     [LocalVar _ v'] -> InfixOp (qualify v')->     rs -> case (qualLookupVar (qualQualify m v) env) of->             [] -> errorAt' (ambiguousIdent rs v)->             [Constr _] -> InfixConstr v->             [GlobalVar _ _] -> InfixOp v->             [LocalVar _ v'] -> InfixOp (qualify v')->             rs' -> errorAt' (ambiguousIdent rs' v)->   where v = opName op--\end{verbatim}-Auxiliary definitions.-\begin{verbatim}--> constrs :: Decl -> [Ident]-> constrs (DataDecl _ _ _ cs) = map constr cs->   where constr (ConstrDecl _ _ c _) = c->         constr (ConOpDecl _ _ _ op _) = op-> constrs (NewtypeDecl _ _ _ (NewConstrDecl _ _ c _)) = [c]-> constrs _ = []--> vars :: Decl -> [Ident]-> vars (TypeSig p fs _) = fs-> vars (EvalAnnot p fs _) = fs-> vars (FunctionDecl p f _) = [f]-> vars (ExternalDecl p _ _ f _) = [f]-> vars (FlatExternalDecl p fs) = fs-> vars (PatternDecl p t _) = (bv t)-> vars (ExtraVariables p vs) = vs-> vars _ = []--> renameLiteral :: Literal -> RenameState Literal-> renameLiteral (Int v i) = liftM (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 Map.empty [] decls->  where->  sortFD env res [] = reverse res->  sortFD env res (decl:decls)->     = case decl of->	  FunctionDecl _ ident _->	     | isJust (Map.lookup ident env)->	       -> sortFD env (insertBy cmpFuncDecl decl res) decls->	     | otherwise->              -> sortFD (Map.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 decl1 decl2 = GT--cmpPos :: Position -> Position -> Ordering-cmpPos p1 p2 | lp1 < lp2  = LT-             | lp1 == lp2 = EQ-             | otherwise  = GT- where lp1 = line p1-       lp2 = line p2---\end{verbatim}-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:-\begin{enumerate}-\item Handle the identifier as a data constructor if at least one of-  the imported names is a data constructor.-\item Handle the identifier as a data constructor only if all imported-  entities are data constructors.-\end{enumerate}-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.-\begin{verbatim}--> 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--> varIdent :: RenameInfo -> Ident-> varIdent (GlobalVar _ v) = unqualify v-> varIdent (LocalVar _ v) =  v-> varIdent _ = internalError "not a variable"--> qualVarIdent :: RenameInfo -> QualIdent-> qualVarIdent (GlobalVar _ v) = v-> qualVarIdent (LocalVar _ v) = qualify v-> qualVarIdent _ = internalError "not a qualified variable"--> arity :: RenameInfo -> Int-> arity (Constr n) = n-> arity (GlobalVar n _) = n-> arity (LocalVar n _) = n-> arity (RecordLabel _ ls) = length ls--\end{verbatim}-Unlike expressions, constructor terms have no possibility to represent-over-applications in function patterns. Therefore it is necessary to-transform them to nested-function patterns using the prelude function \texttt{apply}. E.g. the-the function pattern \texttt{(id id 10)} is transformed to-\texttt{(apply (id id) 10)}-\begin{verbatim}--> genFuncPattAppl :: ConstrTerm -> [ConstrTerm] -> ConstrTerm-> genFuncPattAppl term [] = term-> genFuncPattAppl term (t:ts) ->    = FunctionPattern qApplyId [genFuncPattAppl term ts, t]->  where->  qApplyId = qualifyWith preludeMIdent (mkIdent "apply")--\end{verbatim}-Miscellaneous functions.-\begin{verbatim}--> typeArity :: TypeExpr -> Int-> typeArity (ArrowType _ t2) = 1 + typeArity t2-> typeArity _                = 0--> getFlatLhs :: Equation -> (Ident,[ConstrTerm])-> getFlatLhs (Equation  _ lhs _) = flatLhs lhs--> dup :: Eq a => [a] -> Maybe a-> dup [] = Nothing-> dup (x:xs) | elem x xs = Just x->            | otherwise = dup xs--\end{verbatim}-Error messages.-\begin{verbatim}--> undefinedVariable :: QualIdent -> (Position,String)-> undefinedVariable v = ->     (positionOfQualIdent v,->      qualName v ++ " is undefined")--> undefinedData :: QualIdent -> (Position,String)-> undefinedData c =  ->     (positionOfQualIdent c,->      "Undefined data constructor " ++ qualName c)--> undefinedLabel :: Ident -> (Position,String)-> undefinedLabel l =   ->     (positionOfIdent l,->      "Undefined record label `" ++ name l ++ "`")--> ambiguousIdent :: [RenameInfo] -> QualIdent -> (Position,String)-> ambiguousIdent rs->   | any isConstr rs = ambiguousData->   | otherwise = ambiguousVariable--> ambiguousVariable :: QualIdent -> (Position,String)-> ambiguousVariable v =  ->     (positionOfQualIdent v,->      "Ambiguous variable " ++ qualName v)--> ambiguousData :: QualIdent -> (Position,String)-> ambiguousData c =  ->     (positionOfQualIdent c,->      "Ambiguous data constructor " ++ qualName c)--> duplicateDefinition :: Ident -> (Position,String)-> duplicateDefinition v =->     (positionOfIdent v,->      "More than one definition for `" ++ name v ++ "`")--> duplicateVariable :: Ident -> (Position,String)-> duplicateVariable v = ->     (positionOfIdent v,->      name v ++ " occurs more than once in pattern")--> duplicateData :: Ident -> (Position,String)-> duplicateData c = ->     (positionOfIdent c,->      "More than one definition for data constructor `"->	            ++ name c ++ "`")--> duplicateTypeSig :: Ident -> (Position,String)-> duplicateTypeSig v =  ->     (positionOfIdent v,->      "More than one type signature for `" ++ name v ++ "`")--> duplicateEvalAnnot :: Ident -> (Position,String)-> duplicateEvalAnnot v =   ->     (positionOfIdent v,->      "More than one eval annotation for `" ++ name v ++ "`")--> duplicateLabel :: Ident -> (Position,String)-> duplicateLabel l =   ->     (positionOfIdent l,->      "Multiple occurrence of record label `" ++ name l ++ "`")--> missingLabel :: Ident -> QualIdent -> String -> String -> missingLabel l r what = ->     "Missing label `" ++ name l ->     ++ "` in the " ++ what ++ " of `" ->     ++ name (unqualify r) ++ "`" --qualName r---> illegalLabel :: Ident -> QualIdent -> (Position,String)-> illegalLabel l r =   ->     (positionOfIdent l,->      "Label `" ++ name l ++ "` is not defined in record `" ->	     ++ name (unqualify r) ++ "`") --qualName r--> illegalRecordId :: Ident -> (Position,String)-> illegalRecordId r = ->    (positionOfIdent r,->     "Record identifier `" ++ name r ->	      ++ "` already assigned to a data constructor")--> nonVariable :: String -> Ident -> (Position,String)-> nonVariable what c = ->  (positionOfIdent c,     ->   "Data constructor `" ++ name c ++ "` in left hand side of " ++ what)--> noBody :: Ident -> (Position,String)-> noBody v = ->  (positionOfIdent v,     ->   "No body for `" ++ name v ++ "`")--> noTypeSig :: Ident -> (Position,String)-> noTypeSig f = ->  (positionOfIdent f,     ->   "No type signature for external function `" ++ name f ++ "`")--> noToplevelPattern :: String-> noToplevelPattern = "Pattern declaration not allowed at top-level"--> notALabel :: Ident -> (Position,String)-> notALabel l =  ->  (positionOfIdent l,     ->   "`" ++ name l ++ "` is not a record label")--> emptyRecord :: String-> emptyRecord = "empty records are not allowed"--> differentArity :: Ident -> (Position,String)-> differentArity f =   ->  (positionOfIdent f,     ->   "Equations for `" ++ name f ++ "` have different arities")--> wrongArity :: QualIdent -> Int -> Int -> (Position,String)-> wrongArity c arity argc =  ->  (positionOfQualIdent c,    ->   "Data constructor " ++ qualName c ++ " expects " ++ arguments arity ++->   " but is applied to " ++ show argc)->   where arguments 0 = "no arguments"->         arguments 1 = "1 argument"->         arguments n = show n ++ " arguments"--> illegalRecordPatt :: String-> illegalRecordPatt = "Expexting `_` after `|` in the record pattern"--> noFuncPattExt :: String-> noFuncPattExt = "function patterns are not supported in standard curry"->	        ++ extMessage--> noRecordExt :: String-> noRecordExt = "records are not supported in standard curry"->             ++ extMessage--> extMessage :: String-> extMessage = "\n(Use flag -e to enable extended curry)"--> infixWithoutParens :: [(QualIdent,QualIdent)] -> String-> infixWithoutParens calls =->     "Missing parens in infix patterns: \n" ++->     unlines (map (\(q1,q2) -> show q1 ++ " " ++ ->                               showLine (positionOfQualIdent q1) ++ ->                               "calls " ++ show q2 ++ " " ++ ->                               showLine (positionOfQualIdent q2)) calls)--\end{verbatim}--checkParen -@param Aufrufende InfixFunktion-@param ConstrTerm-@return Liste mit fehlerhaften Funktionsaufrufen-\begin{verbatim}--> checkParenConstrTerm :: (Maybe QualIdent) -> ConstrTerm -> [(QualIdent,QualIdent)]-> checkParenConstrTerm _ (LiteralPattern _) = []-> checkParenConstrTerm _ (NegativePattern _ _) = []-> checkParenConstrTerm _ (VariablePattern _) = []-> checkParenConstrTerm _ (ConstructorPattern qualIdent constrTerms) =->     concatMap (checkParenConstrTerm Nothing) constrTerms-> checkParenConstrTerm mCaller (InfixPattern constrTerm1 qualIdent constrTerm2) =->     maybe [] (\c -> [(c,qualIdent)]) mCaller ++->     checkParenConstrTerm Nothing constrTerm1 ++->     checkParenConstrTerm Nothing constrTerm2-> checkParenConstrTerm _ (ParenPattern constrTerm) =->     checkParenConstrTerm Nothing constrTerm-> checkParenConstrTerm _ (TuplePattern _ constrTerms) =->     concatMap (checkParenConstrTerm Nothing) constrTerms-> checkParenConstrTerm _ (ListPattern _ constrTerms) =->     concatMap (checkParenConstrTerm Nothing) constrTerms-> checkParenConstrTerm mCaller (AsPattern _ constrTerm) =->     checkParenConstrTerm mCaller constrTerm-> checkParenConstrTerm mCaller (LazyPattern _ constrTerm) =->     checkParenConstrTerm mCaller constrTerm-> checkParenConstrTerm _ (FunctionPattern _ constrTerms) =->     concatMap (checkParenConstrTerm Nothing) constrTerms-> checkParenConstrTerm mCaller (InfixFuncPattern constrTerm1 qualIdent constrTerm2) =->     maybe [] (\c -> [(c,qualIdent)]) mCaller ++->     checkParenConstrTerm Nothing constrTerm1 ++->     checkParenConstrTerm Nothing constrTerm2-> checkParenConstrTerm _ (RecordPattern fieldConstrTerms mConstrTerm) =  ->     maybe [] (checkParenConstrTerm Nothing) mConstrTerm ++->     concatMap (\(Field _ _ constrTerm) -> checkParenConstrTerm Nothing constrTerm) ->               fieldConstrTerms--\end{verbatim}
− src/SyntaxColoring.hs 
@@ -1,800 +0,0 @@-module SyntaxColoring (Program,Code(..),TypeKind(..),ConstructorKind(..),-                       IdentifierKind(..),FunctionKind(..), genProgram,-                       code2string,getQualIdent, position2code,-                       area2codes) where--import Debug.Trace-import Data.Function(on)--import Data.Maybe-import Data.Either-import Data.List-import Data.Char hiding(Space)--import Curry.Base.Position-import Curry.Base.Ident-import Curry.Base.MessageMonad-import Curry.Syntax -import Curry.Syntax.Lexer----debug = False -- mergen von Token und Codes--trace' s x = if debug then trace s x else x---debug' = False -- messages--trace'' s x = if debug' then trace s x else x--type Program = [(Int,Int,Code)] --data Code =  Keyword String-           | Space Int-           | NewLine-           | ConstructorName  ConstructorKind QualIdent-           | TypeConstructor  TypeKind QualIdent-           | Function FunctionKind QualIdent-           | ModuleName ModuleIdent-           | Commentary String-           | NumberCode String-           | StringCode String-           | CharCode String-           | Symbol String-           | Identifier IdentifierKind QualIdent-           | CodeWarning [WarnMsg] Code-           | NotParsed String-             deriving Show-           -data TypeKind = TypeDecla-              | TypeUse-              | TypeExport deriving Show          --data ConstructorKind = ConstrPattern-                     | ConstrCall-                     | ConstrDecla-                     | OtherConstrKind deriving Show-                     -data IdentifierKind = IdDecl-                    | IdOccur-                    | UnknownId  deriving Show         -                      -data FunctionKind = InfixFunction-                  | TypSig-                  | FunDecl-                  | FunctionCall-                  | OtherFunctionKind deriving Show      -                  -                  -     -        ---- @param plaintext---- @param list with parse-Results with descending quality  e.g. [typingParse,fullParse,parse]                                        ---- @param lex-Result---- @return program-genProgram :: String -> [MsgMonad Module] -> MsgMonad [(Position,Token)] -> Program       -genProgram plainText parseResults m-    = case runMsg m of-        (Left e, msgs) -> buildMessagesIntoPlainText (e : msgs) plainText-        (Right posNtokList, mess) -            -> let messages = (prepareMessages (concatMap getMessages parseResults ++ mess))-                   mergedMessages = (mergeMessages' (trace' ("Messages: " ++ show messages) messages) posNtokList)-                   (nameList,codes) = catIdentifiers parseResults-               in tokenNcodes2codes nameList 1 1 mergedMessages codes--    ---- @param Program---- @param line---- @param col---- @return Code at this Position                  -position2code :: Program -> Int -> Int -> Maybe Code                 -position2code []  _ _ = Nothing-position2code [_] _ _ = Nothing-position2code ((l,c,code):xs@((_,c2,_):_)) line col-     | line == l && col >= c && col < c2 = Just code-     | l > line = Nothing-     | otherwise = position2code xs line col-     -area2codes :: Program -> Position -> Position -> [Code]     -area2codes [] _ _ = []-area2codes xxs@((l,c,code):xs) p1@Position{file=file} p2 -     | p1 > p2 = area2codes xxs p2 p1-     | posEnd >= p1 && posBegin <= p2  = code : area2codes xs p1 p2-     | posBegin > p2 = []-     | otherwise = area2codes xs p1 p2-   where-      posBegin = Position file l c noRef-      posEnd   = Position file l (c + length (code2string code)) noRef-                  -  ---- @param code---- @return qualIdent if available                   -getQualIdent :: Code -> Maybe QualIdent-getQualIdent (ConstructorName _ qualIdent) = Just qualIdent-getQualIdent (Function _ qualIdent) = Just qualIdent-getQualIdent (Identifier _ qualIdent) = Just qualIdent                      -getQualIdent (TypeConstructor _ qualIdent) = Just qualIdent-getQualIdent  _ = Nothing                  -                  -                    --- DEBUGGING----------- wird bald nicht mehr gebraucht--setMessagePosition :: WarnMsg -> WarnMsg-setMessagePosition m@(WarnMsg (Just p) _) = trace'' ("pos:" ++ show p ++ ":" ++ show m) m-setMessagePosition (WarnMsg _ m) = -        let mes@(WarnMsg pos _) =  (WarnMsg (getPositionFromString m) m) in-        trace'' ("pos:" ++ show pos ++ ":" ++ show mes) mes--getPositionFromString :: String -> Maybe Position-getPositionFromString message =-     if line > 0 && col > 0 -          then Just Position{file=file,line=line,column=col,astRef=noRef}-          else Nothing-  where-      file = takeWhile (/= '"') (tail (dropWhile (/= '"') message))-      line = readInt (takeWhile (/= '.') (drop 7 (dropWhile (/= ',') message)))-      col = readInt (takeWhile (/= ':') (tail (dropWhile (/= '.') (drop 7 (dropWhile (/= ',') message)))))-      -     -readInt :: String -> Int -readInt s = -      let onlyNum = filter isDigit s in-      if null onlyNum-         then 0-         else read onlyNum :: Int---- ---------------------------  ---- ----------------------------flatCode :: Code -> Code-flatCode (CodeWarning _ code) = code-flatCode code = code-             --                 --- ----------Message---------------------------------------                  -                  --getMessages :: MsgMonad a -> [WarnMsg]-getMessages = snd . runMsg --(Result mess _) = mess--- getMessages (Failure mess) = mess--lessMessage :: WarnMsg -> WarnMsg -> Bool-lessMessage (WarnMsg mPos1 _) (WarnMsg mPos2 _) = mPos1 < mPos2--nubMessages :: [WarnMsg] -> [WarnMsg] -nubMessages = nubBy eqMessage--eqMessage :: WarnMsg -> WarnMsg -> Bool-eqMessage (WarnMsg p1 s1) (WarnMsg p2 s2) = (p1 == p2) && (s1 == s2)--prepareMessages :: [WarnMsg] -> [WarnMsg]   -prepareMessages = qsort lessMessage . map setMessagePosition . nubMessages---buildMessagesIntoPlainText :: [WarnMsg] -> String -> Program-buildMessagesIntoPlainText messages text = -    buildMessagesIntoPlainText' messages (lines text) [] 1- where-    buildMessagesIntoPlainText' :: [WarnMsg] -> [String] -> [String] -> Int -> Program-    buildMessagesIntoPlainText' _ [] [] _ = -          []-    buildMessagesIntoPlainText' _ [] postStrs line = -          [(line,1,NotParsed (unlines postStrs))]    -    buildMessagesIntoPlainText' [] preStrs postStrs line = -          [(line,1,NotParsed (unlines (preStrs ++ postStrs)))]  -            -    buildMessagesIntoPlainText' messages (str:preStrs) postStrs ln = -          let (pre,post) = partition isLeq messages in-          if null pre -             then buildMessagesIntoPlainText' post preStrs (postStrs ++ [str]) (ln + 1)-             else (ln,1,NotParsed (unlines postStrs)) : -                  (ln,1,CodeWarning pre (NotParsed str)) :-                  (ln,1,NewLine) :-                  buildMessagesIntoPlainText' post preStrs [] (ln + 1)-      where -         isLeq (WarnMsg (Just p) _) = line p <= ln -         isLeq _ = True-                -        -        --     ---- @param parse-Modules  [typingParse,fullParse,parse] -catIdentifiers :: [MsgMonad Module] -> ([(ModuleIdent,ModuleIdent)],[Code])-catIdentifiers = catIds . rights_sc . map (fst . runMsg)-    where -      catIds [] = ([],[])-      catIds [m] =-          catIdentifiers' m Nothing-      catIds rs@(m:y:ys) =  -          catIdentifiers' (last rs) (Just m)-    --- not in base befoer base4--rights_sc  xs = [ x | Right x <- xs]----- @param parse-Module---- @param Maybe betterParse-Module    -catIdentifiers' :: Module -> Maybe Module -> ([(ModuleIdent,ModuleIdent)],[Code])-catIdentifiers' (Module moduleIdent maybeExportSpec decls)-                Nothing =-      let codes = (concatMap decl2codes (qsort lessDecl decls)) in-      (concatMap renamedImports decls,      -      ModuleName moduleIdent :-       maybe [] exportSpec2codes maybeExportSpec ++ codes)-catIdentifiers' (Module moduleIdent maybeExportSpec1 _)-                (Just (Module _ maybeExportSpec2 decls)) =-      let codes = (concatMap decl2codes (qsort lessDecl decls)) in-      (concatMap renamedImports decls,-      replaceFunctionCalls $ -        map (addModuleIdent moduleIdent)-          ([ModuleName moduleIdent] ++-           mergeExports2codes  -              (maybe [] (\(Exporting _ i) -> i)  maybeExportSpec1)-              (maybe [] (\(Exporting _ i) -> i)  maybeExportSpec2) ++-           codes))     -  -     -renamedImports :: Decl -> [(ModuleIdent,ModuleIdent)]-renamedImports decl =-    case decl of-        (ImportDecl _ oldName _ (Just newName) _) -> [(oldName,newName)]-        _ -> []-   -                      -replaceFunctionCalls :: [Code] -> [Code]                  -replaceFunctionCalls codes = map (idOccur2functionCall qualIdents) codes-   where-      qualIdents = findFunctionDecls codes-                                              --findFunctionDecls :: [Code] -> [QualIdent]-findFunctionDecls  =  mapMaybe getQualIdent . -                      filter isFunctionDecl .                       -                      map flatCode                   --isFunctionDecl  :: Code -> Bool-isFunctionDecl  (Function FunDecl _)  = True-isFunctionDecl  _ = False  --idOccur2functionCall :: [QualIdent] -> Code -> Code-idOccur2functionCall qualIdents ide@(Identifier IdOccur qualIdent)  -   | isQualified qualIdent = Function FunctionCall qualIdent-   | elem qualIdent qualIdents = Function FunctionCall qualIdent-   | otherwise = ide-idOccur2functionCall qualIdents (CodeWarning mess code) =-       CodeWarning mess (idOccur2functionCall qualIdents code)-idOccur2functionCall _ code = code-  --addModuleIdent :: ModuleIdent -> Code -> Code-addModuleIdent moduleIdent c@(Function x qualIdent) -    | uniqueId (unqualify qualIdent) == 0 =-        Function x (qualQualify moduleIdent qualIdent)-    | otherwise = c-addModuleIdent moduleIdent cn@(ConstructorName x qualIdent) -    | not $ isQualified qualIdent =-        ConstructorName x (qualQualify moduleIdent qualIdent)-    | otherwise = cn       -addModuleIdent moduleIdent tc@(TypeConstructor TypeDecla qualIdent) -    | not $ isQualified qualIdent =-        TypeConstructor TypeDecla (qualQualify moduleIdent qualIdent)-    | otherwise = tc         -addModuleIdent moduleIdent (CodeWarning mess code) =-    CodeWarning mess (addModuleIdent moduleIdent code)-addModuleIdent _ c = c-                        --- ------------------------------------------mergeMessages' :: [WarnMsg] -> [(Position,Token)] -> [([WarnMsg],Position,Token)]-mergeMessages' _ [] = []-mergeMessages' [] ((p,t):ps) = ([],p,t) : mergeMessages' [] ps-mergeMessages' mss@(m@(WarnMsg mPos x):ms) ((p,t):ps)  -    | mPos <= Just p = trace' (show mPos ++ " <= " ++ show (Just p) ++ " Message: " ++ x) ([m],p,t) : mergeMessages' ms ps -    | otherwise = ([],p,t) : mergeMessages' mss ps---tokenNcodes2codes :: [(ModuleIdent,ModuleIdent)] -> Int -> Int -> [([WarnMsg],Position,Token)] -> [Code] -> [(Int,Int,Code)]-tokenNcodes2codes _ _ _ [] _ = []          -tokenNcodes2codes nameList currLine currCol toks@((messages,pos@Position{line=line,column=col},token):ts) codes -    | currLine < line = -           trace' " NewLine: "-           ((currLine,currCol,NewLine) :-           tokenNcodes2codes nameList (currLine + 1) 1 toks codes)-    | currCol < col =  -           trace' (" Space " ++ show (col - currCol))-           ((currLine,currCol,Space (col - currCol)) :         -           tokenNcodes2codes nameList currLine col toks codes)-    | isTokenIdentifier token && null codes =    -           trace' ("empty Code-List, Token: " ++ show (line,col) ++ show token)-           (addMessage [(currLine,currCol,NotParsed tokenStr)] ++ tokenNcodes2codes nameList newLine newCol ts codes)-    | not (isTokenIdentifier token) = -           trace' (" Token ist kein Identifier: " ++ tokenStr ) -           (addMessage [(currLine,currCol,token2code token)] ++ tokenNcodes2codes nameList newLine newCol ts codes) -    | tokenStr == code2string (head codes) =-           trace' (" Code wird genommen: " ++ show (head codes) )-           (addMessage [(currLine,currCol,head codes)] ++ tokenNcodes2codes nameList newLine newCol ts (tail codes)) -    | tokenStr == code2qualString (renameModuleIdents nameList (head codes)) =-           let mIdent = maybe Nothing rename (getModuleIdent (head codes)) -               lenMod = maybe 0 (length . moduleName) mIdent-               startPos = maybe currCol (const (currCol + lenMod + 1)) mIdent-               symbol = [(currLine,currCol + lenMod,Symbol ".")]               -               prefix = maybe [] -                              ( (: symbol) . -                                ( \i -> (currLine,-                                         currCol,-                                         ModuleName i))) -                              mIdent in-           trace' (" Code wird genommen: " ++ show (head codes) )-           (addMessage (prefix ++ [(currCol,startPos,head codes)]) ++ tokenNcodes2codes nameList newLine newCol ts (tail codes))           -    | elem tokenStr (codeQualifiers (head codes)) =-           trace' (" Token: "++ tokenStr ++" ist Modulname von: " ++ show (head codes) )-           (addMessage [(currLine,currCol,ModuleName (mkMIdent [tokenStr]))] ++ -                    tokenNcodes2codes nameList newLine newCol ts codes)                  -    | otherwise = -           trace' (" Token: "++ -                   tokenStr ++-                   ",Code faellt weg:" ++ -                   code2string (head codes) ++ -                   "|" ++ -                   code2qualString (head codes))-           (tokenNcodes2codes nameList currLine currCol toks (tail codes))-  where-      tokenStr = token2string token            -      newLine  = (currLine + length (lines tokenStr)) - 1 -      newCol   = currCol + length tokenStr   --      rename mid = Just $ fromMaybe mid (lookup mid nameList)--      addMessage [] = []-      addMessage ((l,c,code):cs)-         | null messages = (l,c,code):cs-         | otherwise = trace' ("Warning bei code: " ++ show codes ++ ":" ++ show messages) -                              ((l,c,CodeWarning messages code): addMessage cs)-      -      -renameModuleIdents :: [(ModuleIdent,ModuleIdent)] -> Code -> Code-renameModuleIdents nameList c =-    case c of-        Function x qualIdent -> Function x (rename qualIdent (qualidMod qualIdent))-        Identifier x qualIdent -> Identifier x (rename qualIdent (qualidMod qualIdent))-        _ -> c-  where-    rename x (Nothing) = x-    rename x (Just m) = maybe x (\ m' -> qualifyWith m' (qualidId x)) (lookup m nameList)-           -{--codeWithoutUniqueID ::  Code -> String-codeWithoutUniqueID code = maybe (code2string code) (name . unqualify) $ getQualIdent code-     --codeUnqualify :: Code -> Code-codeUnqualify code = maybe code (setQualIdent code . qualify . unqualify)  $ getQualIdent code  --}  -          -codeQualifiers :: Code -> [String]-codeQualifiers = maybe [] moduleQualifiers . getModuleIdent--getModuleIdent :: Code -> Maybe ModuleIdent-getModuleIdent (ConstructorName _ qualIdent) = qualidMod qualIdent-getModuleIdent (Function _ qualIdent) = qualidMod qualIdent-getModuleIdent (ModuleName moduleIdent) = Just moduleIdent-getModuleIdent (Identifier _ qualIdent) = qualidMod qualIdent                     -getModuleIdent (TypeConstructor _ qualIdent) = qualidMod qualIdent-getModuleIdent _ = Nothing---  -{--setQualIdent :: Code -> QualIdent -> Code-setQualIdent (Keyword str) _ = (Keyword str)-setQualIdent (Space i) _ = (Space i)-setQualIdent NewLine _ = NewLine-setQualIdent (ConstructorName kind _) qualIdent = (ConstructorName kind qualIdent)-setQualIdent (Function kind _) qualIdent = (Function kind qualIdent)-setQualIdent (ModuleName moduleIdent) _ = (ModuleName moduleIdent)-setQualIdent (Commentary str) _ = (Commentary str)-setQualIdent (NumberCode str) _ = (NumberCode str)-setQualIdent (Symbol str) _ = (Symbol str)-setQualIdent (Identifier kind _) qualIdent = (Identifier kind qualIdent)                      -setQualIdent (TypeConstructor kind _) qualIdent = (TypeConstructor kind qualIdent)-setQualIdent (StringCode str) _ = (StringCode str)                                 -setQualIdent (CharCode str) _ = (CharCode str)             --}-                  -code2string (Keyword str) = str-code2string (Space i)= concat (replicate i " ")-code2string NewLine = "\n"-code2string (ConstructorName _ qualIdent) = name $ unqualify qualIdent-code2string (Function _ qualIdent) = name $ unqualify qualIdent-code2string (ModuleName moduleIdent) = moduleName moduleIdent-code2string (Commentary str) = str-code2string (NumberCode str) = str-code2string (Symbol str) = str-code2string (Identifier _ qualIdent) = name $ unqualify qualIdent                      -code2string (TypeConstructor _ qualIdent) = name $ unqualify qualIdent-code2string (StringCode str) = str                                 -code2string (CharCode str) = str-code2string (NotParsed str) = str-code2string _ = "" -- error / warning- -code2qualString (ConstructorName _ qualIdent) = qualName qualIdent-code2qualString (Function _ qualIdent) = qualName qualIdent-code2qualString (Identifier _ qualIdent) = qualName qualIdent                      -code2qualString (TypeConstructor _ qualIdent) = qualName qualIdent-code2qualString x = code2string x----token2code :: Token -> Code-token2code tok@(Token cat _)-    | elem cat [IntTok,FloatTok,IntegerTok]-         = NumberCode (token2string tok)-    | elem cat [KW_case,KW_choice,KW_data,KW_do,KW_else,KW_eval,KW_external,-                KW_free,KW_if,KW_import,KW_in,KW_infix,KW_infixl,KW_infixr,-                KW_let,KW_module,KW_newtype,KW_of,KW_rigid,KW_then,KW_type,-                KW_where,Id_as,Id_ccall,Id_forall,Id_hiding,Id_interface,Id_primitive,-                Id_qualified]-         =  Keyword (token2string tok)-    | elem cat [LeftParen,RightParen,Semicolon,LeftBrace,RightBrace,LeftBracket,-                RightBracket,Comma,Underscore,Backquote,-                At,Colon,DotDot,DoubleColon,Equals,Backslash,Bar,LeftArrow,RightArrow,-                Tilde]-         = Symbol (token2string tok)-    | elem cat [LineComment, NestedComment]-         = Commentary (token2string tok)-    | isTokenIdentifier tok-         = Identifier UnknownId $ qualify $ mkIdent $ token2string tok-    | cat == StringTok -         = StringCode (token2string tok)-    | cat == CharTok-         = CharCode (token2string tok)          -    | elem cat [EOF,VSemicolon,VRightBrace] = Space 0 -    -isTokenIdentifier :: Token -> Bool-isTokenIdentifier (Token cat _) = -  elem cat [Id,QId,Sym,QSym,Sym_Dot,Sym_Minus,Sym_MinusDot]-    --- DECL Position--getPosition :: Decl -> Position-getPosition (ImportDecl pos _ _ _ _) = pos     -getPosition (InfixDecl pos _ _ _) = pos     -getPosition (DataDecl pos _ _ _) = pos     -getPosition (NewtypeDecl pos _ _ _) = pos-getPosition (TypeDecl pos _ _ _) = pos   -getPosition (TypeSig pos _ _) = pos    -getPosition (EvalAnnot pos _ _) = pos-getPosition (FunctionDecl pos _ _) = pos    -getPosition (ExternalDecl pos _ _ _ _) = pos-getPosition (FlatExternalDecl pos _) = pos    -getPosition (PatternDecl pos _ _) = pos    -getPosition (ExtraVariables pos _) = pos-             --lessDecl :: Decl -> Decl -> Bool-lessDecl = (<) `on` getPosition--qsort _ []     = []-qsort less (x:xs) = qsort less [y | y <- xs, less y x] ++ [x] ++ qsort less [y | y <- xs, not $ less y x]------ DECL TO CODE -------------------------------------------------------------------- ----exportSpec2codes ::  ExportSpec -> [Code]-exportSpec2codes (Exporting _ exports) = concatMap (export2codes [])  exports----- @param parse-Exports---- @param betterParse-Exports-mergeExports2codes :: [Export] -> [Export]  -> [Code]-mergeExports2codes [] _ = []-mergeExports2codes (e:es) xs = concatMap (export2codes xs)  (e:es)---export2codes :: [Export] -> Export -> [Code]-export2codes exports e@(Export qualIdent) -    | length (filter checkDouble exports) /= 1 =      -       [Identifier UnknownId qualIdent]-    | otherwise =-       let [export] = (filter checkDouble exports) in-       export2c export     -  where    -    checkDouble (ExportTypeWith q _) = eqQualIdent qualIdent q-    checkDouble (Export q) = eqQualIdent qualIdent q-    checkDouble _ = False-    -    eqQualIdent q1 q2 -      | q1 == q2 = True-      | not (isQualified q1) = unqualify q1 == unqualify q2-      | otherwise = False-      -    export2c (Export qualIdent) = -         [Function OtherFunctionKind qualIdent]-    export2c _ = -         [TypeConstructor TypeExport qualIdent]-         -    -    -       -export2codes _ (ExportTypeWith qualIdent idents) = -     TypeConstructor TypeExport qualIdent : map (Function OtherFunctionKind . qualify) idents-export2codes _ (ExportTypeAll  qualIdent) = -     [TypeConstructor TypeExport qualIdent]  -export2codes _ (ExportModule moduleIdent) = -     [ModuleName moduleIdent]--decl2codes :: Decl -> [Code]            -decl2codes (ImportDecl _ moduleIdent xQualified mModuleIdent importSpec) = -     [ModuleName moduleIdent] ++-     maybe [] ((:[]) . ModuleName) mModuleIdent ++-     maybe [] (importSpec2codes moduleIdent)  importSpec-decl2codes (InfixDecl _ _ _ idents) =-     map (Function InfixFunction . qualify) idents-decl2codes (DataDecl _ ident idents constrDecls) =-     TypeConstructor TypeDecla (qualify ident) : -     map (Identifier UnknownId . qualify) idents ++-     concatMap constrDecl2codes constrDecls-decl2codes (NewtypeDecl xPosition xIdent yIdents xNewConstrDecl) =-     []-decl2codes (TypeDecl _ ident idents typeExpr) =-     TypeConstructor TypeDecla (qualify ident) : -     map (Identifier UnknownId . qualify) idents ++ -     typeExpr2codes typeExpr-decl2codes (TypeSig _ idents typeExpr) =-     map (Function TypSig . qualify) idents ++ typeExpr2codes typeExpr   -decl2codes (EvalAnnot xPosition idents xEvalAnnotation) =-     map (Function FunDecl . qualify) idents-decl2codes (FunctionDecl _ _ equations) =-     concatMap equation2codes equations  -decl2codes (ExternalDecl xPosition xCallConv xString xIdent xTypeExpr) =-     []-decl2codes (FlatExternalDecl _ idents) =-     map (Function FunDecl . qualify) idents   -decl2codes (PatternDecl xPosition constrTerm rhs) =-     constrTerm2codes constrTerm ++ rhs2codes rhs-decl2codes (ExtraVariables _ idents) =-     map (Identifier IdDecl . qualify) idents-  -equation2codes :: Equation -> [Code]-equation2codes (Equation _ lhs rhs) =-     lhs2codes lhs ++ rhs2codes rhs-     -lhs2codes :: Lhs -> [Code]-lhs2codes (FunLhs ident constrTerms) =-    Function FunDecl (qualify ident) : concatMap constrTerm2codes constrTerms-lhs2codes (OpLhs constrTerm1 ident constrTerm2) =-    constrTerm2codes constrTerm1 ++ [Function FunDecl $ qualify ident] ++ constrTerm2codes constrTerm2-lhs2codes (ApLhs lhs constrTerms) =-    lhs2codes lhs ++ concatMap constrTerm2codes constrTerms     --rhs2codes :: Rhs -> [Code]-rhs2codes (SimpleRhs _ expression decls) =-    expression2codes expression ++ concatMap decl2codes decls-rhs2codes (GuardedRhs condExprs decls) =-    concatMap condExpr2codes condExprs ++ concatMap decl2codes decls-    -condExpr2codes :: CondExpr -> [Code]-condExpr2codes (CondExpr _ expression1 expression2) =   -   expression2codes expression1 ++ expression2codes expression2    -    -constrTerm2codes :: ConstrTerm -> [Code]-constrTerm2codes (LiteralPattern literal) = []-constrTerm2codes (NegativePattern ident literal) = []-constrTerm2codes (VariablePattern ident) = [Identifier IdDecl (qualify ident)]-constrTerm2codes (ConstructorPattern qualIdent constrTerms) =-    ConstructorName ConstrPattern qualIdent : concatMap constrTerm2codes constrTerms-constrTerm2codes (InfixPattern constrTerm1 qualIdent constrTerm2) =-    constrTerm2codes constrTerm1 ++ [ConstructorName ConstrPattern qualIdent] ++ constrTerm2codes constrTerm2-constrTerm2codes (ParenPattern constrTerm) = constrTerm2codes constrTerm-constrTerm2codes (TuplePattern _ constrTerms) = concatMap constrTerm2codes constrTerms-constrTerm2codes (ListPattern _ constrTerms) = concatMap constrTerm2codes constrTerms-constrTerm2codes (AsPattern ident constrTerm) =-    Function OtherFunctionKind (qualify ident) : constrTerm2codes constrTerm-constrTerm2codes (LazyPattern _ constrTerm) = constrTerm2codes constrTerm-constrTerm2codes (FunctionPattern qualIdent constrTerms) = -    Function OtherFunctionKind qualIdent : concatMap constrTerm2codes constrTerms-constrTerm2codes (InfixFuncPattern constrTerm1 qualIdent constrTerm2) =-    constrTerm2codes constrTerm1 ++ [Function InfixFunction qualIdent] ++ constrTerm2codes constrTerm2-   -expression2codes :: Expression -> [Code]-expression2codes (Literal literal) = []-expression2codes (Variable qualIdent) = -    [Identifier IdOccur qualIdent]-expression2codes (Constructor qualIdent) = -    [ConstructorName ConstrCall qualIdent]-expression2codes (Paren expression) = -    expression2codes expression-expression2codes (Typed expression typeExpr) = -    expression2codes expression ++ typeExpr2codes typeExpr-expression2codes (Tuple _ expressions) = -    concatMap expression2codes expressions-expression2codes (List _ expressions) = -    concatMap expression2codes expressions-expression2codes (ListCompr _ expression statements) = -    expression2codes expression ++ concatMap statement2codes statements-expression2codes (EnumFrom expression) = -    expression2codes expression-expression2codes (EnumFromThen expression1 expression2) = -    expression2codes expression1 ++ expression2codes expression2-expression2codes (EnumFromTo expression1 expression2) = -    expression2codes expression1 ++ expression2codes expression2-expression2codes (EnumFromThenTo expression1 expression2 expression3) = -    expression2codes expression1 ++ -    expression2codes expression2 ++ -    expression2codes expression3-expression2codes (UnaryMinus ident expression) = -    Symbol (name ident) : expression2codes expression -expression2codes (Apply expression1 expression2) = -    expression2codes expression1 ++ expression2codes expression2-expression2codes (InfixApply expression1 infixOp expression2) = -    expression2codes expression1 ++ infixOp2codes infixOp ++ expression2codes expression2-expression2codes (LeftSection expression infixOp) = -    expression2codes expression ++ infixOp2codes infixOp-expression2codes (RightSection infixOp expression) = -    infixOp2codes infixOp ++ expression2codes expression-expression2codes (Lambda _ constrTerms expression) = -    concatMap constrTerm2codes constrTerms ++ expression2codes expression-expression2codes (Let decls expression) = -    concatMap decl2codes decls ++ expression2codes expression-expression2codes (Do statements expression) = -    concatMap statement2codes statements ++ expression2codes expression-expression2codes (IfThenElse _ expression1 expression2 expression3) = -    expression2codes expression1 ++ expression2codes expression2 ++ expression2codes expression3-expression2codes (Case _ expression alts) = -    expression2codes expression ++ concatMap alt2codes alts-    -infixOp2codes :: InfixOp -> [Code]-infixOp2codes (InfixOp qualIdent) = [Function InfixFunction qualIdent]-infixOp2codes (InfixConstr qualIdent) = [ConstructorName OtherConstrKind qualIdent]---statement2codes :: Statement -> [Code] -statement2codes (StmtExpr _ expression) =-    expression2codes expression-statement2codes (StmtDecl decls) =-    concatMap decl2codes decls-statement2codes (StmtBind _ constrTerm expression) =-     constrTerm2codes constrTerm ++ expression2codes expression---alt2codes :: Alt -> [Code]-alt2codes (Alt _ constrTerm rhs) =-    constrTerm2codes constrTerm ++ rhs2codes rhs-         -constrDecl2codes :: ConstrDecl -> [Code]-constrDecl2codes (ConstrDecl _ idents ident typeExprs) =-    ConstructorName ConstrDecla (qualify ident) : concatMap typeExpr2codes typeExprs-constrDecl2codes (ConOpDecl _ idents typeExpr1 ident typeExpr2) =   -    typeExpr2codes typeExpr1 ++ [ConstructorName ConstrDecla $ qualify ident] ++ typeExpr2codes typeExpr2--         -importSpec2codes :: ModuleIdent -> ImportSpec -> [Code]-importSpec2codes moduleIdent (Importing _ imports) = concatMap (import2codes moduleIdent) imports-importSpec2codes moduleIdent (Hiding _ imports) = concatMap (import2codes moduleIdent) imports--import2codes :: ModuleIdent -> Import -> [Code]-import2codes moduleIdent (Import ident) =-     [Function OtherFunctionKind $ qualifyWith moduleIdent ident]  -import2codes moduleIdent (ImportTypeWith ident idents) = -     ConstructorName OtherConstrKind (qualifyWith moduleIdent ident) :-     map (Function OtherFunctionKind . qualifyWith moduleIdent) idents-import2codes moduleIdent (ImportTypeAll  ident) = -     [ConstructorName OtherConstrKind $ qualifyWith moduleIdent ident]  -     -typeExpr2codes :: TypeExpr -> [Code]     -typeExpr2codes (ConstructorType qualIdent typeExprs) = -    TypeConstructor TypeUse qualIdent : concatMap typeExpr2codes typeExprs-typeExpr2codes (VariableType ident) = -    [Identifier IdOccur (qualify ident)]-typeExpr2codes (TupleType typeExprs) = -    concatMap typeExpr2codes typeExprs-typeExpr2codes (ListType typeExpr) = -    typeExpr2codes typeExpr-typeExpr2codes (ArrowType typeExpr1 typeExpr2) = -    typeExpr2codes typeExpr1 ++ typeExpr2codes typeExpr2---- TOKEN TO STRING --------------------------------------------------------------token2string (Token Id a) = attributes2string a-token2string (Token QId a) = attributes2string a-token2string (Token Sym a) = attributes2string a-token2string (Token QSym a) = attributes2string a-token2string (Token IntTok a) = attributes2string a-token2string (Token FloatTok a) = attributes2string a-token2string (Token CharTok a) = attributes2string a-token2string (Token IntegerTok a) = attributes2string a-token2string (Token StringTok a) = attributes2string a-token2string (Token LeftParen _) = "("-token2string (Token RightParen _) = ")"-token2string (Token Semicolon _) = ";"-token2string (Token LeftBrace _) = "{"-token2string (Token RightBrace _) = "}"-token2string (Token LeftBracket _) = "["-token2string (Token RightBracket _) = "]"-token2string (Token Comma _) = ","-token2string (Token Underscore _) = "_"-token2string (Token Backquote _) = "`"-token2string (Token VSemicolon _) = ""-token2string (Token VRightBrace _) = ""-token2string (Token At _) = "@"-token2string (Token Colon _) = ":"-token2string (Token DotDot _) = ".."-token2string (Token DoubleColon _) = "::"-token2string (Token Equals _) = "="-token2string (Token Backslash _) = "\\"-token2string (Token Bar _) = "|"-token2string (Token LeftArrow _) = "<-"-token2string (Token RightArrow _) = "->"-token2string (Token Tilde _) = "~"-token2string (Token Sym_Dot _) = "."-token2string (Token Sym_Minus _) = "-"-token2string (Token Sym_MinusDot _) = "-."-token2string (Token KW_case _) = "case"-token2string (Token KW_choice _) = "choice"-token2string (Token KW_data _) = "data"-token2string (Token KW_do _) = "do"-token2string (Token KW_else _) = "else"-token2string (Token KW_eval _) = "eval"-token2string (Token KW_external _) = "external"-token2string (Token KW_free _) = "free"-token2string (Token KW_if _) = "if"-token2string (Token KW_import _) = "import"-token2string (Token KW_in _) = "in"-token2string (Token KW_infix _) = "infix"-token2string (Token KW_infixl _) = "infixl"-token2string (Token KW_infixr _) = "infixr"-token2string (Token KW_let _) = "let"-token2string (Token KW_module _) = "module"-token2string (Token KW_newtype _) = "newtype"-token2string (Token KW_of _) = "of"-token2string (Token KW_rigid _) = "rigid"-token2string (Token KW_then _) = "then"-token2string (Token KW_type _) = "type"-token2string (Token KW_where _) = "where"-token2string (Token Id_as _) = "as"-token2string (Token Id_ccall _) = "ccall"-token2string (Token Id_forall _) = "forall"-token2string (Token Id_hiding _) = "hiding"-token2string (Token Id_interface _) = "interface"-token2string (Token Id_primitive _) = "primitive"-token2string (Token Id_qualified _) = "qualified"-token2string (Token EOF _) = ""-token2string (Token LineComment (StringAttributes sval _)) = sval-token2string (Token NestedComment (StringAttributes sval _)) = sval--attributes2string NoAttributes = ""-attributes2string (CharAttributes cval _) = showCh cval -attributes2string (IntAttributes ival _) = show ival-attributes2string (FloatAttributes fval _) = show fval-attributes2string (IntegerAttributes intval _) = show intval-attributes2string (StringAttributes sval _) = showSt sval -attributes2string (IdentAttributes mIdent ident) =concat (intersperse "." (mIdent ++ [ident])) ---showCh c    -   | c == '\\' = "'\\\\'"-   | elem c ('\127' : ['\001' .. '\031']) = show c-   | otherwise = toString c-  where-    toString c = '\'' : c : "'"--showSt = addQuotes . concatMap toGoodChar -   where-      addQuotes x = "\"" ++ x ++ "\""--toGoodChar c     -   | c == '\\' = "\\\\"-   | elem c ('\127' : ['\001' .. '\031']) = justShow c-   | c == '"' = "\\\""-   | otherwise = c : "" - where-     justShow = init . tail . show
+ src/TokenStream.hs view
@@ -0,0 +1,168 @@+{- |+    Module      :  $Header$+    Description :  Generating List of Tokens and Spans+    Copyright   :  (c) 2015 - 2016, Katharina Rahf+                       2015 - 2016, Björn Peemöller+                       2015 - 2016, Jan Tikovsky++    This module defines a function for writing the list of tokens+    and spans of a Curry source module into a separate file.+-}++module TokenStream (showTokenStream, showCommentTokenStream) where++import Data.List             (intercalate)++import Curry.Base.Position   (Position (..))+import Curry.Base.Span       (Span (..))+import Curry.Syntax          (Token (..), Category (..), Attributes (..))++-- |Show a list of 'Span' and 'Token' tuples.+-- The list is split into one tuple on each line to increase readability.+showTokenStream :: [(Span, Token)] -> String+showTokenStream [] = "[]\n"+showTokenStream ts =+  "[ " ++ intercalate "\n, " (map showST filteredTs) ++ "\n]\n"+  where filteredTs     = filter (not . isVirtual) ts+        showST (sp, t) = "(" ++ showSpanAsPair sp ++ ", " ++ showToken t ++ ")"++-- |Show a list of 'Span' and 'Token' tuples filtered by CommentTokens.+-- The list is split into one tuple on each line to increase readability.+showCommentTokenStream :: [(Span, Token)] -> String+showCommentTokenStream [] = "[]\n"+showCommentTokenStream ts =+  "[ " ++ intercalate "\n, " (map showST filteredTs) ++ "\n]\n"+  where filteredTs     = filter isComment ts+        showST (sp, t) = "(" ++ showSpan sp ++ ", " ++ showToken t ++ ")"++isVirtual :: (Span, Token) -> Bool+isVirtual (_, Token cat _) = cat `elem` [EOF, VRightBrace, VSemicolon]++isComment :: (Span, Token) -> Bool+isComment (_, Token cat _) = cat `elem` [LineComment, NestedComment]++-- show 'span' as "((startLine, startColumn), (endLine, endColumn))"+showSpanAsPair :: Span -> String+showSpanAsPair sp =+  "(" ++ showPosAsPair (start sp) ++ ", " ++ showPos (end sp) ++ ")"++-- show 'span' as "(Span startPos endPos)"+showSpan :: Span -> String+showSpan NoSpan = "NoSpan"+showSpan Span { start = s, end = e } =+   "(Span " ++ showPos s ++ " " ++ showPos e ++ ")"++-- show 'position' as "(Position line column)"+showPos :: Position -> String+showPos NoPos = "NoPos"+showPos Position { line = l, column = c } =+  "(Position " ++ show l++ " " ++ show c ++ ")"++-- show 'Position' as "(line, column)"+showPosAsPair :: Position -> String+showPosAsPair p = "(" ++ show (line p) ++ ", " ++ show (column p) ++ ")"++-- |Show tokens and their value if needed+showToken :: Token -> String+-- literals+showToken (Token CharTok        a) = "CharTok"   +++ showAttributes a+showToken (Token IntTok         a) = "IntTok"    +++ showAttributes a+showToken (Token FloatTok       a) = "FloatTok"  +++ showAttributes a+showToken (Token StringTok      a) = "StringTok" +++ showAttributes a+-- identifiers+showToken (Token Id             a) = "Id"        +++ showAttributes a+showToken (Token QId            a) = "QId"       +++ showAttributes a+showToken (Token Sym            a) = "Sym"       +++ showAttributes a+showToken (Token QSym           a) = "QSym"      +++ showAttributes a+-- punctuation symbols+showToken (Token LeftParen      _) = "LeftParen"+showToken (Token RightParen     _) = "RightParen"+showToken (Token Semicolon      _) = "Semicolon"+showToken (Token LeftBrace      _) = "LeftBrace"+showToken (Token RightBrace     _) = "RightBrace"+showToken (Token LeftBracket    _) = "LeftBracket"+showToken (Token RightBracket   _) = "RightBracket"+showToken (Token Comma          _) = "Comma"+showToken (Token Underscore     _) = "Underscore"+showToken (Token Backquote      _) = "Backquote"+-- layout+showToken (Token VSemicolon     _) = "VSemicolon"+showToken (Token VRightBrace    _) = "VRightBrace"+-- reserved keywords+showToken (Token KW_case        _) = "KW_case"+showToken (Token KW_class       _) = "KW_class"+showToken (Token KW_data        _) = "KW_data"+showToken (Token KW_default     _) = "KW_default"+showToken (Token KW_deriving    _) = "KW_deriving"+showToken (Token KW_do          _) = "KW_do"+showToken (Token KW_else        _) = "KW_else"+showToken (Token KW_external    _) = "KW_external"+showToken (Token KW_fcase       _) = "KW_fcase"+showToken (Token KW_free        _) = "KW_free"+showToken (Token KW_if          _) = "KW_if"+showToken (Token KW_import      _) = "KW_import"+showToken (Token KW_in          _) = "KW_in"+showToken (Token KW_infix       _) = "KW_infix"+showToken (Token KW_infixl      _) = "KW_infixl"+showToken (Token KW_infixr      _) = "KW_infixr"+showToken (Token KW_instance    _) = "KW_instance"+showToken (Token KW_let         _) = "KW_let"+showToken (Token KW_module      _) = "KW_module"+showToken (Token KW_newtype     _) = "KW_newtype"+showToken (Token KW_of          _) = "KW_of"+showToken (Token KW_then        _) = "KW_then"+showToken (Token KW_type        _) = "KW_type"+showToken (Token KW_where       _) = "KW_where"+-- reserved operators+showToken (Token At             _) = "At"+showToken (Token Colon          _) = "Colon"+showToken (Token DotDot         _) = "DotDot"+showToken (Token DoubleColon    _) = "DoubleColon"+showToken (Token Equals         _) = "Equals"+showToken (Token Backslash      _) = "Backslash"+showToken (Token Bar            _) = "Bar"+showToken (Token LeftArrow      _) = "LeftArrow"+showToken (Token RightArrow     _) = "RightArrow"+showToken (Token Tilde          _) = "Tilde"+showToken (Token DoubleArrow    _) = "DoubleArrow"+-- special identifiers+showToken (Token Id_as          _) = "Id_as"+showToken (Token Id_ccall       _) = "Id_ccall"+showToken (Token Id_forall      _) = "Id_forall"+showToken (Token Id_hiding      _) = "Id_hiding"+showToken (Token Id_interface   _) = "Id_interface"+showToken (Token Id_primitive   _) = "Id_primitive"+showToken (Token Id_qualified   _) = "Id_qualified"+-- special operators+showToken (Token SymDot         _) = "SymDot"+showToken (Token SymMinus       _) = "SymMinus"+-- special symbols+showToken (Token SymStar        _) = "SymStar"+-- pragmas+showToken (Token PragmaLanguage _) = "PragmaLanguage"+showToken (Token PragmaOptions  a) = "PragmaOptions" +++ showAttributes a+showToken (Token PragmaHiding   _) = "PragmaHiding"+showToken (Token PragmaMethod   _) = "PragmaMethod"+showToken (Token PragmaModule   _) = "PragmaModule"+showToken (Token PragmaEnd      _) = "PragmaEnd"+-- comments+showToken (Token LineComment    a) = "LineComment"   +++ showAttributes a+showToken (Token NestedComment  a) = "NestedComment" +++ showAttributes a+-- end-of-file token+showToken (Token EOF            _) = "EOF"++showAttributes :: Attributes -> String+showAttributes NoAttributes            = ""+showAttributes (CharAttributes    c _) = show c+showAttributes (IntAttributes     i _) = show i+showAttributes (FloatAttributes   f _) = show f+showAttributes (StringAttributes  s _) = show s+showAttributes (IdentAttributes   m i) = show $ intercalate "." (m ++ [i])+showAttributes (OptionsAttributes t a) = "(" ++ show t ++ ")" ++ ' ' : show a++-- Concatenate two 'String's with a smart space in between,+-- which is only added if both 'String's are non-empty+(+++) :: String -> String -> String+[] +++ t  = t+s  +++ [] = s+s  +++ t  = s ++ ' ' : t
− src/TopEnv.lhs 
@@ -1,148 +0,0 @@--% $Id: TopEnv.lhs,v 1.20 2003/10/04 17:04:32 wlux Exp $-%-% Copyright (c) 1999-2003, Wolfgang Lux-% See LICENSE for the full license.-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-%-\nwfilename{TopEnv.lhs}-\subsection{Top-Level Environments}\label{sec:toplevel-env}-The module \texttt{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 \cite{DiatchkiJonesHallgren02:ModuleSystem}, 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-\texttt{Entity} is used to handle this merge.--The code in this module ensures that the list of entities returned by-the functions \texttt{lookupTopEnv} and \texttt{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.-\begin{verbatim}--> module TopEnv(TopEnv(..), Entity(..), emptyTopEnv,->               predefTopEnv,qualImportTopEnv,importTopEnv,->               bindTopEnv,qualBindTopEnv,rebindTopEnv,qualRebindTopEnv,->               unbindTopEnv,lookupTopEnv,qualLookupTopEnv,->               allImports,moduleImports,localBindings->              ) where--> import Data.Maybe-> import qualified Data.Map as Map-> import Control.Arrow(second)-> import Curry.Base.Ident---> data Source = Local | Import [ModuleIdent] deriving (Eq,Show)--> class Entity a where->  origName :: a -> QualIdent->  merge    :: a -> a -> Maybe a->  merge x y->    | origName x == origName y = Just x->    | otherwise = Nothing--> 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)--> entities :: QualIdent -> Map.Map QualIdent [(Source,a)] -> [(Source,a)]-> entities x env = fromMaybe [] (Map.lookup x env)--> emptyTopEnv :: TopEnv a-> emptyTopEnv = TopEnv Map.empty--> predefTopEnv :: Entity a => QualIdent -> a -> TopEnv a -> TopEnv a-> predefTopEnv x y (TopEnv env) =->   case Map.lookup x env of->     Just _ -> error "internal error: predefTopEnv"->     Nothing -> TopEnv (Map.insert x [(Import [],y)] env)--> importTopEnv :: Entity a => ModuleIdent -> Ident -> a -> TopEnv a -> TopEnv a-> importTopEnv m x y (TopEnv env) =->   TopEnv (Map.insert x' (mergeImport m y (entities x' env)) env)->   where x' = qualify x--> qualImportTopEnv :: Entity a => ModuleIdent -> Ident -> a -> TopEnv a->                  -> TopEnv a-> qualImportTopEnv m x y (TopEnv env) =->   TopEnv (Map.insert x' (mergeImport m y (entities x' env)) env)->   where x' = qualifyWith m x--> mergeImport :: Entity a => ModuleIdent -> a -> [(Source,a)] -> [(Source,a)]-> mergeImport m x [] = [(Import [m],x)]-> mergeImport m x ((Local,x') : xs) = (Local,x') : mergeImport m x xs-> mergeImport m x ((Import ms,x') : xs) =->   case merge x x' of->     Just x'' -> (Import (m:ms),x'') : xs->     Nothing -> (Import ms,x') : mergeImport m x xs--> bindTopEnv :: String -> Ident -> a -> TopEnv a -> TopEnv a-> bindTopEnv fun x y env = qualBindTopEnv fun (qualify x) y env--> qualBindTopEnv :: String -> QualIdent -> a -> TopEnv a -> TopEnv a-> qualBindTopEnv fun x y (TopEnv env) =->   TopEnv (Map.insert x (bindLocal y (entities x env)) env)->   where bindLocal y ys->           | null [y' | (Local,y') <- ys] = (Local,y) : ys->           | otherwise = error ("internal error: \"qualBindTopEnv " ->		                 ++ show x ++ "\" failed in function \""->			         ++ fun ++ "\"")--> 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 [] = error "internal error: qualRebindTopEnv"->         rebindLocal ((Local,_) : ys) = (Local,y) : ys->         rebindLocal ((Import ms,y) : ys) = (Import ms,y) : 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 [] = error "internal error: unbindTopEnv"->         unbindLocal ((Local,_) : ys) = ys->         unbindLocal ((Import ms,y) : ys) = (Import ms,y) : 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) <- takeWhile (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]--\end{verbatim}
+ src/Transformations.hs view
@@ -0,0 +1,89 @@+{- |+    Module      :  $Header$+    Description :  Code transformations+    Copyright   :  (c) 2011, Björn Peemöller (bjp@informatik.uni-kiel.de)+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module subsumes the different transformations of the source code.+-}+module Transformations where++import Curry.Syntax++import Base.Types++import Transformations.CaseCompletion as CC (completeCase)+import Transformations.CurryToIL      as IL (ilTrans, transType)+import Transformations.Derive         as DV (derive)+import Transformations.Desugar        as DS (desugar)+import Transformations.Dictionary     as DI (insertDicts)+import Transformations.Lift           as L  (lift)+import Transformations.Newtypes       as NT (removeNewtypes)+import Transformations.Qual           as Q  (qual)+import Transformations.Simplify       as S  (simplify)++import Env.TypeConstructor++import CompilerEnv+import Imports (qualifyEnv)+import qualified IL++-- |Fully qualify used constructors and functions.+qual :: CompEnv (Module a) -> CompEnv (Module a)+qual (env, mdl) = (qualifyEnv env, mdl')+  where mdl' = Q.qual (moduleIdent env) (tyConsEnv env) (valueEnv env) mdl++-- |Automatically derive instances.+derive :: CompEnv (Module PredType) -> CompEnv (Module PredType)+derive (env, mdl) = (env, mdl')+  where mdl' = DV.derive (tyConsEnv env) (valueEnv env) (instEnv env)+                         (opPrecEnv env) mdl++-- |Remove any syntactic sugar, changes the value environment.+desugar :: CompEnv (Module PredType) -> CompEnv (Module PredType)+desugar (env, mdl) = (env { valueEnv = tyEnv' }, mdl')+  where (mdl', tyEnv') = DS.desugar (extensions env) (valueEnv env)+                                    (tyConsEnv env) mdl++-- |Insert dictionaries, changes the type constructor and value environments.+insertDicts :: Bool -> CompEnv (Module PredType) -> CompEnv (Module Type)+insertDicts inlDi (env, mdl) = (env { interfaceEnv = intfEnv'+                                    , tyConsEnv = tcEnv'+                                    , valueEnv = vEnv'+                                    , opPrecEnv = pEnv' }, mdl')+  where (mdl', intfEnv', tcEnv', vEnv', pEnv') =+          DI.insertDicts inlDi (interfaceEnv env) (tyConsEnv env)+                         (valueEnv env) (classEnv env) (instEnv env)+                         (opPrecEnv env) mdl++-- |Remove newtype constructors.+removeNewtypes :: Bool -> CompEnv (Module Type) -> CompEnv (Module Type)+removeNewtypes remNT (env, mdl) = (env, mdl')+  where mdl' = NT.removeNewtypes remNT (valueEnv env) mdl++-- |Simplify the source code, changes the value environment.+simplify :: CompEnv (Module Type) -> CompEnv (Module Type)+simplify (env, mdl) = (env { valueEnv = tyEnv' }, mdl')+  where (mdl', tyEnv') = S.simplify (valueEnv env) mdl++-- |Lift local declarations, changes the value environment.+lift :: CompEnv (Module Type) -> CompEnv (Module Type)+lift (env, mdl) = (env { valueEnv = tyEnv' }, mdl')+  where (mdl', tyEnv') = L.lift (valueEnv env) mdl++-- |Translate into the intermediate language+ilTrans :: Bool -> CompEnv (Module Type) -> CompEnv IL.Module+ilTrans remIm (env, mdl) = (env, il)+  where il = IL.ilTrans remIm (valueEnv env) (tyConsEnv env) mdl++transType :: TCEnv -> Type -> IL.Type+transType = IL.transType++-- |Add missing case branches+completeCase :: CompEnv IL.Module -> CompEnv IL.Module+completeCase (env, mdl) =+  (env, CC.completeCase (interfaceEnv env) (tyConsEnv env) mdl)
+ src/Transformations/CaseCompletion.hs view
@@ -0,0 +1,479 @@+{- |+    Module      :  $Header$+    Description :  CaseCompletion+    Copyright   :  (c) 2005        Martin Engelke+                       2011 - 2015 Björn Peemöller+                       2016        Jan Tikovsky+                       2016 - 2017 Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module expands case branches with missing constructors.++    The MCC translates case expressions into the intermediate language+    representation (IL) without completing them (i.e. without generating+    case branches for missing contructors), because the intermediate language+    supports variable patterns for the fallback case.+    In contrast, the FlatCurry representation of patterns only allows+    literal and constructor patterns, which requires the expansion+    default branches to all missing constructors.++    This is only necessary for *rigid* case expressions, because any+    *flexible* case expression with more than one branch and a variable+    pattern is non-deterministic. In consequence, these overlapping patterns+    have already been eliminated in the pattern matching compilation+    process (see module CurryToIL).++    To summarize, this module expands all rigid case expressions.+-}+{-# LANGUAGE CPP #-}+module Transformations.CaseCompletion (completeCase) where++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative        ((<$>), (<*>))+#endif+import qualified Control.Monad.State as S   (State, evalState, gets, modify)+import           Data.List                  (find)+import           Data.Maybe                 (fromMaybe, listToMaybe)++import           Curry.Base.Ident+import qualified Curry.Syntax        as CS++import Base.CurryTypes                      (toType)+import Base.Expr+import Base.Messages                        (internalError)+import Base.Types                           ( boolType, charType, floatType+                                            , intType, listType+                                            )+import Base.Subst++import Env.TypeConstructor+import Env.Interface                        (InterfaceEnv, lookupInterface)++import Transformations.CurryToIL            (transType)+import Transformations.Dictionary           (qImplMethodId)++import IL++-- Completes case expressions by adding branches for missing constructors.+-- The interface environment 'iEnv' is needed to compute these constructors.+completeCase :: InterfaceEnv -> TCEnv -> Module -> Module+completeCase iEnv tcEnv mdl@(Module mid is ds) = Module mid is ds'+ where ds'= S.evalState (mapM ccDecl ds) (CCState mdl iEnv 0 tcEnv )++-- -----------------------------------------------------------------------------+-- Internally used state monad+-- -----------------------------------------------------------------------------++data CCState = CCState+  { modul        :: Module+  , interfaceEnv :: InterfaceEnv+  , nextId       :: Int+  , tyconEnv     :: TCEnv+  }++type CCM a = S.State CCState a++getModule :: CCM Module+getModule = S.gets modul++getTCEnv :: CCM TCEnv+getTCEnv = S.gets tyconEnv++getInterfaceEnv :: CCM InterfaceEnv+getInterfaceEnv = S.gets interfaceEnv++-- Create a fresh identifier+freshIdent :: CCM Ident+freshIdent = do+  nid <- S.gets nextId+  S.modify $ \s -> s { nextId = succ nid }+  return $ mkIdent $ "_#comp" ++ show nid++-- -----------------------------------------------------------------------------+-- The following functions traverse an IL term searching for case expressions+-- -----------------------------------------------------------------------------++ccDecl :: Decl -> CCM Decl+ccDecl dd@(DataDecl        _ _ _) = return dd+ccDecl edd@(ExternalDataDecl _ _) = return edd+ccDecl (FunctionDecl qid vs ty e) = FunctionDecl qid vs ty <$> ccExpr e+ccDecl ed@(ExternalDecl    _ _ _) = return ed+ccDecl nd@(NewtypeDecl     _ _ _) = return nd++ccExpr :: Expression -> CCM Expression+ccExpr l@(Literal       _ _) = return l+ccExpr v@(Variable      _ _) = return v+ccExpr f@(Function    _ _ _) = return f+ccExpr c@(Constructor _ _ _) = return c+ccExpr (Apply         e1 e2) = Apply <$> ccExpr e1 <*> ccExpr e2+ccExpr (Case        ea e bs) = do+  e'  <- ccExpr e+  bs' <- mapM ccAlt bs+  ccCase ea e' bs'+ccExpr (Or            e1 e2) = Or <$> ccExpr e1 <*> ccExpr e2+ccExpr (Exist        v ty e) = Exist v ty <$> ccExpr e+ccExpr (Let             b e) = Let <$> ccBinding b <*> ccExpr e+ccExpr (Letrec         bs e) = Letrec <$> mapM ccBinding bs <*> ccExpr e+ccExpr (Typed          e ty) = flip Typed ty <$> ccExpr e++ccAlt :: Alt -> CCM Alt+ccAlt (Alt p e) = Alt p <$> ccExpr e++ccBinding :: Binding -> CCM Binding+ccBinding (Binding v e) = Binding v <$> ccExpr e++-- ---------------------------------------------------------------------------+-- Functions for completing case alternatives+-- ---------------------------------------------------------------------------+ccCase :: Eval -> Expression -> [Alt] -> CCM Expression+-- flexible cases are not completed+ccCase Flex  e alts     = return $ Case Flex e alts+ccCase Rigid _ []       = internalError $ "CaseCompletion.ccCase: "+                                       ++ "empty alternative list"+ccCase Rigid e as@(Alt p _:_) = case p of+  ConstructorPattern _ _ _ -> completeConsAlts Rigid e as+  LiteralPattern     _ _   -> completeLitAlts  Rigid e as+  VariablePattern    _ _   -> completeVarAlts        e as++-- Completes a case alternative list which branches via constructor patterns+-- by adding alternatives. Thus, case expressions of the form+--     case <ce> of+--       <C_1> -> <expr_1>+--              :+--       <C_n> -> <expr_n>+--      [<var> -> <default_expr>]+-- are in general extended to+--     let x = <ce> in+--     let y = <default_expr>[<var>/x] in+--     case x of+--       <C_1>  -> <expr_1>+--               :+--       <C_n>  -> <expr_n>+--       <C'_1> -> y+--               :+--       <C'_m> -> y+-- where the C'_j are the complementary constructor patterns of the C_i,+-- @x@ and @y@ are fresh variables, and "default_expr" is the expression+-- from the first alternative containing a variable pattern. If there is no such+-- alternative, the default expression is set to the prelude function 'failed'.+-- In addition, there are a few optimizations performed to avoid the+-- construction of unnecessary let-bindings:+--   - If there are no complementary patterns, the expression remains unchanged.+--   - If there is only one complementary pattern,+--     the binding for @y@ is avoided (see @bindDefVar@).+--   - If the variable @<var>@ does not occur in the default expression,+--     the binding for @x@ is avoided (see @mkCase@).+completeConsAlts :: Eval -> Expression -> [Alt] -> CCM Expression+completeConsAlts ea ce alts = do+  mdl       <- getModule+  menv      <- getInterfaceEnv+  tcEnv     <- getTCEnv+  -- complementary constructor patterns+  complPats <- mapM genPat $ getComplConstrs mdl menv tcEnv+               [ c | (Alt (ConstructorPattern _ c _) _) <- consAlts ]+  v <- freshIdent+  w <- freshIdent+  return $ case (complPats, defaultAlt v) of+            (_:_, Just e') -> bindDefVar v ce w e' complPats+            _              -> Case ea ce consAlts+  where+  -- existing contructor pattern alternatives+  consAlts = [ a | a@(Alt (ConstructorPattern _ _ _) _) <- alts ]++  -- unifier for data type and concrete pattern type+  dataTy  = let TypeConstructor qid tys = patTy+            in TypeConstructor qid $ map TypeVariable [0 .. length tys - 1]+  patTy   = let Alt pat _ = head consAlts in typeOf pat+  tySubst = matchType dataTy patTy idSubst++  -- generate a new constructor pattern+  genPat (qid, tys) = ConstructorPattern patTy qid <$>+    mapM (\ty' -> freshIdent >>= \v -> return (ty', v)) (subst tySubst tys)++  -- default alternative, if there is one+  defaultAlt v = listToMaybe [ replaceVar x (Variable ty v) e+                             | Alt (VariablePattern ty x) e <- alts ]++  -- create a binding for @v = e@ if needed+  bindDefVar v e w e' ps+    | v `elem` fv e' = mkBinding v e $ mkCase (Variable (typeOf e) v) w e' ps+    | otherwise      = mkCase e w e' ps++  -- create a binding for @w = e'@ if needed, and a case expression+  -- @case e of { consAlts ++ (ps -> w) }@+  mkCase e w e' ps = case ps of+    [p] -> Case ea e (consAlts ++ [Alt p e'])+    _   -> mkBinding w e'+         $ Case ea e (consAlts ++ [Alt p (Variable (typeOf e') w) | p <- ps])++-- If the alternatives' branches contain literal patterns, a complementary+-- constructor list cannot be generated because it would become potentially+-- infinite. Thus, function 'completeLitAlts' transforms case expressions like+--     case <ce> of+--       <lit_1> -> <expr_1>+--       <lit_2> -> <expr_2>+--                   :+--       <lit_n> -> <expr_n>+--      [<var>   -> <default_expr>]+-- to+--     let x = <ce> in+--     case (v == <lit_1>) of+--       True  -> <expr_1>+--       False -> case (x == <lit_2>) of+--                  True  -> <expr_2>+--                  False -> case ...+--                                 :+--                               -> case (x == <lit_n>) of+--                                    True  -> <expr_n>+--                                    False -> <default_expr>+-- If the default expression is missing, @failed@ is used instead.+completeLitAlts :: Eval -> Expression -> [Alt] -> CCM Expression+completeLitAlts ea ce alts = do+  x <- freshIdent+  return $ mkBinding x ce $ nestedCases x alts+  where+  nestedCases _ []              = failedExpr (typeOf $ head alts)+  nestedCases x (Alt p ae : as) = case p of+    LiteralPattern ty l  -> Case ea (Variable ty x `eqExpr` Literal ty l)+                          [ Alt truePatt  ae+                          , Alt falsePatt (nestedCases x as)+                          ]+    VariablePattern ty v -> replaceVar v (Variable ty x) ae+    _ -> internalError "CaseCompletion.completeLitAlts: illegal alternative"++-- For the unusual case of only one alternative containing a variable pattern,+-- it is necessary to tranform it to a 'let' term because FlatCurry does not+-- support variable patterns in case alternatives. So the case expression+--    case <ce> of+--      x -> <ae>+-- is transformed to+--      let x = <ce> in <ae>+completeVarAlts :: Expression -> [Alt] -> CCM Expression+completeVarAlts _  []             = internalError $+  "CaseCompletion.completeVarAlts: empty alternative list"+completeVarAlts ce (Alt p ae : _) = case p of+  VariablePattern _ x -> return $ mkBinding x ce ae+  _                   -> internalError $+    "CaseCompletion.completeVarAlts: variable pattern expected"++-- Smart constructor for non-recursive let-binding. @mkBinding v e e'@+-- evaluates to @e'[v/e]@ if @e@ is a variable, or @let v = e in e'@ otherwise.+mkBinding :: Ident -> Expression -> Expression -> Expression+mkBinding v e e' = case e of+  Variable _ _ -> replaceVar v e e'+  _            -> Let (Binding v e) e'++-- ---------------------------------------------------------------------------+-- This part of the module contains functions for replacing variables+-- with expressions. This is necessary in the case of having a default+-- alternative like+--      v -> <expr>+-- where the variable v occurs in the default expression <expr>. When+-- building additional alternatives for this default expression, the variable+-- must be replaced with the newly generated constructors.+replaceVar :: Ident -> Expression -> Expression -> Expression+replaceVar v e x@(Variable  _ w)+  | v == w    = e+  | otherwise = x+replaceVar v e (Apply     e1 e2)+  = Apply (replaceVar v e e1) (replaceVar v e e2)+replaceVar v e (Case   ev e' bs)+  = Case ev (replaceVar v e e') (map (replaceVarInAlt v e) bs)+replaceVar v e (Or        e1 e2)+  = Or (replaceVar v e e1) (replaceVar v e e2)+replaceVar v e (Exist   w ty e')+   | v == w                     = Exist w ty e'+   | otherwise                  = Exist w ty (replaceVar v e e')+replaceVar v e (Let        b e')+   | v `occursInBinding` b      = Let b e'+   | otherwise                  = Let (replaceVarInBinding v e b)+                                      (replaceVar v e e')+replaceVar v e (Letrec    bs e')+   | any (occursInBinding v) bs = Letrec bs e'+   | otherwise                  = Letrec (map (replaceVarInBinding v e) bs)+                                         (replaceVar v e e')+replaceVar _ _ e'               = e'++replaceVarInAlt :: Ident -> Expression -> Alt -> Alt+replaceVarInAlt v e (Alt p e')+  | v `occursInPattern` p = Alt p e'+  | otherwise             = Alt p (replaceVar v e e')++replaceVarInBinding :: Ident -> Expression -> Binding -> Binding+replaceVarInBinding v e (Binding w e')+  | v == w    = Binding w e'+  | otherwise = Binding w (replaceVar v e e')++occursInPattern :: Ident -> ConstrTerm -> Bool+occursInPattern v (VariablePattern       _ w) = v == w+occursInPattern v (ConstructorPattern _ _ vs) = v `elem` map snd vs+occursInPattern _ _                           = False++occursInBinding :: Ident -> Binding -> Bool+occursInBinding v (Binding w _) = v == w++-- ---------------------------------------------------------------------------+-- The following functions generate several IL expressions and patterns++failedExpr :: Type -> Expression+failedExpr ty = Function ty (qualifyWith preludeMIdent (mkIdent "failed")) 0++--TODO: Add note about arity of 0 because of the predefined functions in the Prelude+eqExpr :: Expression -> Expression -> Expression+eqExpr e1 e2 = Apply (Apply (Function eqTy eq 0) e1) e2+  where eq   = qImplMethodId preludeMIdent qDataId ty $ mkIdent "==="+        ty   = case e2 of+                 Literal _ l -> case l of+                                  Char  _ -> charType+                                  Int   _ -> intType+                                  Float _ -> floatType+                 _ -> internalError "CaseCompletion.eqExpr: no literal"+        ty'  = case e2 of+                 Literal _ l -> case l of+                                  Char  _ -> charType'+                                  Int   _ -> intType'+                                  Float _ -> floatType'+                 _ -> internalError "CaseCompletion.eqExpr: no literal"+        eqTy = TypeArrow ty' (TypeArrow ty' boolType')++truePatt :: ConstrTerm+truePatt = ConstructorPattern boolType' qTrueId []++falsePatt :: ConstrTerm+falsePatt = ConstructorPattern boolType' qFalseId []++boolType' :: Type+boolType' = IL.TypeConstructor qBoolId []++charType' :: Type+charType' = IL.TypeConstructor qCharId []++intType' :: Type+intType' = IL.TypeConstructor qIntId []++floatType' :: Type+floatType' = IL.TypeConstructor qFloatId []++-- ---------------------------------------------------------------------------+-- The following functions compute the missing constructors for generating+-- missing case alternatives++-- Computes the complementary constructors for a given list of constructors.+-- All specified constructors must be of the same type.+-- This functions uses the module environment 'menv', which contains all+-- imported constructors, except for the built-in list constructors.+-- TODO: Check if the list constructors are in the menv.+getComplConstrs :: Module -> InterfaceEnv -> TCEnv+                -> [QualIdent] -> [(QualIdent, [Type])]+getComplConstrs _                 _    _     []+  = internalError "CaseCompletion.getComplConstrs: empty constructor list"+getComplConstrs (Module mid _ ds) menv tcEnv cs@(c:_)+  -- built-in lists+  | c `elem` [qNilId, qConsId] = complementary cs+    [ (qNilId, [])+    , (qConsId, [TypeVariable 0, transType tcEnv (listType boolType)])+    ]+  -- current module+  | mid' == mid                = getCCFromDecls cs ds+  -- imported module+  | otherwise                  = maybe [] (getCCFromIDecls mid' cs tcEnv)+                                          (lookupInterface mid' menv)+  where mid' = fromMaybe mid (qidModule c)++-- Find complementary constructors within the declarations of the+-- current module+getCCFromDecls :: [QualIdent] -> [Decl] -> [(QualIdent, [Type])]+getCCFromDecls cs ds = complementary cs cinfos+  where+  cinfos = map constrInfo+         $ maybe [] extractConstrDecls (find (`declares` head cs) ds)++  decl `declares` qid = case decl of+    DataDecl    _ _ cs' -> any (`declaresConstr` qid) cs'+    _                   -> False++  declaresConstr (ConstrDecl cid _) qid = cid == qid++  extractConstrDecls (DataDecl _ _ cs') = cs'+  extractConstrDecls _                  = []++  constrInfo (ConstrDecl cid tys) = (cid, tys)++-- Find complementary constructors within the module environment+getCCFromIDecls :: ModuleIdent -> [QualIdent] -> TCEnv-> CS.Interface+                -> [(QualIdent, [Type])]+getCCFromIDecls mid cs tcEnv (CS.Interface _ _ ds) = complementary cs cinfos+  where+  cinfos = map (uncurry constrInfo)+         $ maybe [] extractConstrDecls (find (`declares` head cs) ds)++  decl `declares` qid = case decl of+    CS.IDataDecl    _ _ _ _ cs' _ -> any (`declaresConstr` qid) cs'+    CS.INewtypeDecl _ _ _ _ nc  _ -> isNewConstrDecl qid nc+    _                             -> False++  declaresConstr (CS.ConstrDecl   _ cid _) qid = unqualify qid == cid+  declaresConstr (CS.ConOpDecl _ _ oid _) qid = unqualify qid == oid+  declaresConstr (CS.RecordDecl  _ cid _) qid = unqualify qid == cid++  isNewConstrDecl qid (CS.NewConstrDecl _ cid _) = unqualify qid == cid+  isNewConstrDecl qid (CS.NewRecordDecl _ cid _) = unqualify qid == cid++  extractConstrDecls (CS.IDataDecl _ _ _ vs cs' _) = zip (repeat vs) cs'+  extractConstrDecls _                             = []++  constrInfo vs (CS.ConstrDecl _ cid tys)     =+    (qualifyWith mid cid, map (transType' vs) tys)+  constrInfo vs (CS.ConOpDecl  _ ty1 oid ty2) =+    (qualifyWith mid oid, map (transType' vs) [ty1, ty2])+  constrInfo vs (CS.RecordDecl _ cid  fs)     =+    ( qualifyWith mid cid+    , [transType' vs ty | CS.FieldDecl _ ls ty <- fs, _ <- ls]+    )++  transType' vs = transType tcEnv . toType vs++-- Compute complementary constructors+complementary :: [QualIdent] -> [(QualIdent, [Type])] -> [(QualIdent, [Type])]+complementary known others = filter ((`notElem` known) . fst) others++-- ---------------------------------------------------------------------------+-- The following section contains defintions to compute a type substitution+-- for generating the type annotations for missing case alternatives++type TypeSubst = Subst Int Type++class SubstType a where+  subst :: TypeSubst -> a -> a++instance SubstType a => SubstType [a] where+  subst sigma = map (subst sigma)++instance SubstType Type where+  subst sigma (TypeConstructor q tys) = TypeConstructor q $ subst sigma tys+  subst sigma (TypeVariable tv)       = substVar' TypeVariable subst sigma tv+  subst sigma (TypeArrow ty1 ty2)+    = TypeArrow (subst sigma ty1) (subst sigma ty2)+  subst sigma (TypeForall tvs ty)+    = TypeForall tvs (subst (foldr (unbindSubst . fst) sigma tvs) ty)++matchType :: Type -> Type -> TypeSubst -> TypeSubst+matchType ty1 ty2 = fromMaybe noMatch (matchType' ty1 ty2)+  where+    noMatch = internalError $ "Transformations.CaseCompletion.matchType: " +++                                showsPrec 11 ty1 " " ++ showsPrec 11 ty2 ""++matchType' :: Type -> Type -> Maybe (TypeSubst -> TypeSubst)+matchType' (TypeVariable tv) ty+  | ty == TypeVariable tv = Just id+  | otherwise = Just (bindSubst tv ty)+matchType' (TypeConstructor tc1 tys1) (TypeConstructor tc2 tys2)+  | tc1 == tc2 = Just $ foldr (\(ty1, ty2) -> (matchType ty1 ty2 .)) id $ tys+  where tys = zip tys1 tys2+matchType' (TypeArrow ty11 ty12) (TypeArrow ty21 ty22) =+  Just (matchType ty11 ty21 . matchType ty12 ty22)+matchType' _ _ = Nothing
+ src/Transformations/CurryToIL.hs view
@@ -0,0 +1,704 @@+{- |+    Module      :  $Header$+    Description :  Translation of Curry into IL+    Copyright   :  (c) 1999 - 2003 Wolfgang Lux+                                   Martin Engelke+                       2011 - 2015 Björn Peemöller+                       2015        Jan Tikovsky+                       2016 - 2017 Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++   After desugaring and lifting have been performed, the source code is+   translated into the intermediate language. Besides translating from+   source terms and expressions into intermediate language terms and+   expressions, this phase in particular has to implement the pattern+   matching algorithm for equations and case expressions.++   Because of name conflicts between the source and intermediate language+   data structures, we can use only a qualified import for the 'IL' module.+-}+{-# LANGUAGE CPP #-}+module Transformations.CurryToIL (ilTrans, transType) where++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative        ((<$>), (<*>))+#endif++import           Control.Monad.Extra         (concatMapM)+import qualified Control.Monad.Reader as R+import qualified Control.Monad.State  as S+import           Data.List                   (nub, partition)+import           Data.Maybe                  (fromJust)+import qualified Data.Map             as Map+import qualified Data.Set             as Set (Set, empty, insert, delete, toList)++import Curry.Base.Ident+import Curry.Syntax hiding (caseAlt)++import Base.Expr+import Base.Messages (internalError)+import Base.Types hiding (polyType)+import Base.Kinds+import Base.Typing+import Base.Utils (foldr2)++import Env.TypeConstructor+import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)++import qualified IL as IL++ilTrans :: Bool -> ValueEnv -> TCEnv -> Module Type -> IL.Module+ilTrans remIm vEnv tcEnv (Module _ _ _ m _ im ds) = IL.Module m im' ds'+  where ds' = R.runReader (concatMapM trDecl ds) (TransEnv m vEnv tcEnv)+        im' = preludeMIdent : if remIm then imports m ds' else map moduleImport im+        moduleImport (ImportDecl _ mdl _ _ _) = mdl+++-- -----------------------------------------------------------------------------+-- Computation of necessary imports+-- -----------------------------------------------------------------------------++-- The list of import declarations in the intermediate language code is+-- determined by collecting all module qualifiers used in the current module.++imports :: ModuleIdent -> [IL.Decl] -> [ModuleIdent]+imports m = Set.toList . Set.delete m . foldr mdlsDecl Set.empty++mdlsDecl :: IL.Decl -> Set.Set ModuleIdent -> Set.Set ModuleIdent+mdlsDecl (IL.DataDecl       _ _ cs) ms = foldr mdlsConstrsDecl ms cs+  where mdlsConstrsDecl (IL.ConstrDecl _ tys) ms' = foldr mdlsType ms' tys+mdlsDecl (IL.NewtypeDecl    _ _ nc) ms = mdlsNewConstrDecl nc+  where mdlsNewConstrDecl (IL.NewConstrDecl _ ty) = mdlsType ty ms+mdlsDecl (IL.ExternalDataDecl  _ _) ms = ms+mdlsDecl (IL.FunctionDecl _ _ ty e) ms = mdlsType ty (mdlsExpr e ms)+mdlsDecl (IL.ExternalDecl   _ _ ty) ms = mdlsType ty ms++mdlsType :: IL.Type -> Set.Set ModuleIdent -> Set.Set ModuleIdent+mdlsType (IL.TypeConstructor tc tys) ms = modules tc (foldr mdlsType ms tys)+mdlsType (IL.TypeVariable         _) ms = ms+mdlsType (IL.TypeArrow      ty1 ty2) ms = mdlsType ty1 (mdlsType ty2 ms)+mdlsType (IL.TypeForall        _ ty) ms = mdlsType ty ms++mdlsExpr :: IL.Expression -> Set.Set ModuleIdent -> Set.Set ModuleIdent+mdlsExpr (IL.Function    _ f _) ms = modules f ms+mdlsExpr (IL.Constructor _ c _) ms = modules c ms+mdlsExpr (IL.Apply       e1 e2) ms = mdlsExpr e1 (mdlsExpr e2 ms)+mdlsExpr (IL.Case       _ e as) ms = mdlsExpr e (foldr mdlsAlt ms as)+  where+  mdlsAlt     (IL.Alt                 t e') = mdlsPattern t . mdlsExpr e'+  mdlsPattern (IL.ConstructorPattern _ c _) = modules c+  mdlsPattern _                             = id+mdlsExpr (IL.Or          e1 e2) ms = mdlsExpr e1 (mdlsExpr e2 ms)+mdlsExpr (IL.Exist       _ _ e) ms = mdlsExpr e ms+mdlsExpr (IL.Let           b e) ms = mdlsBinding b (mdlsExpr e ms)+mdlsExpr (IL.Letrec       bs e) ms = foldr mdlsBinding (mdlsExpr e ms) bs+mdlsExpr _                      ms = ms++mdlsBinding :: IL.Binding -> Set.Set ModuleIdent -> Set.Set ModuleIdent+mdlsBinding (IL.Binding _ e) = mdlsExpr e++modules :: QualIdent -> Set.Set ModuleIdent -> Set.Set ModuleIdent+modules x ms = maybe ms (`Set.insert` ms) (qidModule x)++-- -----------------------------------------------------------------------------+-- Internal reader monad+-- -----------------------------------------------------------------------------++data TransEnv = TransEnv+  { moduleIdent :: ModuleIdent+  , valueEnv    :: ValueEnv+  , tyconEnv    :: TCEnv+  }++type TransM a = R.Reader TransEnv a++getValueEnv :: TransM ValueEnv+getValueEnv = R.asks valueEnv++getTCEnv :: TransM TCEnv+getTCEnv = R.asks tyconEnv++trQualify :: Ident -> TransM QualIdent+trQualify i = flip qualifyWith i <$> R.asks moduleIdent++getArity :: QualIdent -> TransM Int+getArity qid = do+    vEnv <- getValueEnv+    return $ case qualLookupValue qid vEnv of+      [DataConstructor  _ a _ _] -> a+      [NewtypeConstructor _ _ _] -> 1+      [Value            _ _ a _] -> a+      [Label              _ _ _] -> 1+      _                          ->+        internalError $ "CurryToIL.getArity: " ++ show qid++-- Return the type of a constructor+constrType :: QualIdent -> TransM Type+constrType c = do+  vEnv <- getValueEnv+  case qualLookupValue c vEnv of+    [DataConstructor  _ _ _ (ForAll _ (PredType _ ty))] -> return ty+    [NewtypeConstructor _ _ (ForAll _ (PredType _ ty))] -> return ty+    _ -> internalError $ "CurryToIL.constrType: " ++ show c++-- Return the kinds of a type constructor's type variables+tcTVarKinds :: QualIdent -> TransM [Kind]+tcTVarKinds qid = do+  tcEnv <- getTCEnv+  let mid = fromJust $ qidModule qid+      kind = tcKind mid qid tcEnv+  return $ kindArgs kind++-- -----------------------------------------------------------------------------+-- Translation+-- -----------------------------------------------------------------------------++-- At the top-level, the compiler has to translate data type, newtype,+-- function, and external declarations. When translating a data type or+-- newtype declaration, we ignore the types in the declaration and lookup+-- the types of the constructors in the type environment instead because+-- these types are already fully expanded, i.e., they do not include any+-- alias types.++trDecl :: Decl Type -> TransM [IL.Decl]+trDecl (DataDecl     _ tc tvs cs _) = (:[]) <$> trData tc tvs cs+trDecl (NewtypeDecl  _ tc tvs nc _) = (:[]) <$> trNewtype tc tvs nc+trDecl (ExternalDataDecl  _ tc tvs) = (:[]) <$> trExternalData tc tvs+trDecl (FunctionDecl    _ _ f  eqs) = (:[]) <$> trFunction f eqs+trDecl (ExternalDecl          _ vs) = mapM trExternal vs+trDecl _                            = return []++trData :: Ident -> [Ident] -> [ConstrDecl] -> TransM IL.Decl+trData tc tvs cs = do+  tc' <- trQualify tc+  ks <- tcTVarKinds tc'+  IL.DataDecl tc' (transKind <$> ks) <$> mapM trConstrDecl cs++trNewtype :: Ident -> [Ident] -> NewConstrDecl -> TransM IL.Decl+trNewtype tc tvs nc = do+  tc' <- trQualify tc+  ks <- tcTVarKinds tc'+  IL.NewtypeDecl tc' (transKind <$> ks) <$> trNewConstrDecl nc++trConstrDecl :: ConstrDecl -> TransM IL.ConstrDecl+trConstrDecl d = do+  c' <- trQualify (constr d)+  ty' <- arrowArgs <$> constrType c'+  tcEnv <- getTCEnv+  return $ IL.ConstrDecl c' (map (transType tcEnv) ty')+  where+  constr (ConstrDecl    _ c _) = c+  constr (ConOpDecl  _ _ op _) = op+  constr (RecordDecl    _ c _) = c++trNewConstrDecl :: NewConstrDecl -> TransM IL.NewConstrDecl+trNewConstrDecl d = do+  c' <- trQualify (constr d)+  ty' <- arrowArgs <$> constrType c'+  tcEnv <- getTCEnv+  case ty' of+    [ty] -> return $ IL.NewConstrDecl c' (transType tcEnv ty)+    _    -> internalError "CurryToIL.trNewConstrDecl: invalid constructor type"+  where+  constr (NewConstrDecl    _ c _) = c+  constr (NewRecordDecl    _ c _) = c++trExternalData :: Ident -> [Ident] -> TransM IL.Decl+trExternalData tc tvs = do+  tc' <- trQualify tc+  ks <- tcTVarKinds tc'+  return $ IL.ExternalDataDecl tc' (transKind <$> ks)++trExternal :: Var Type -> TransM IL.Decl+trExternal (Var ty f) = do+  tcEnv <- getTCEnv+  f' <- trQualify f+  a <- getArity f'+  return $ IL.ExternalDecl f' a (transType tcEnv $ polyType ty)++-- The type representation in the intermediate language does not support+-- types with higher order kinds. Therefore, the type transformations has+-- to transform all types to first order terms. To that end, we assume the+-- existence of a type synonym 'type Apply f a = f a'. In addition, the type+-- representation of the intermediate language does not support constrained+-- type variables and skolem types. The former are fixed and the later are+-- replaced by fresh type constructors.++transType :: TCEnv -> Type -> IL.Type+transType tcEnv ty' = transType' ty' []+  where+    ks = transTVars tcEnv ty'+    transType' (TypeConstructor    tc) = IL.TypeConstructor tc+    transType' (TypeApply     ty1 ty2) = transType' ty1 . (transType' ty2 [] :)+    transType' (TypeVariable       tv) = foldl applyType' (IL.TypeVariable tv)+    transType' (TypeConstrained tys _) = transType' (head tys)+    transType' (TypeArrow     ty1 ty2) =+      foldl applyType' (IL.TypeArrow (transType' ty1 []) (transType' ty2 []))+    transType' (TypeForall     tvs ty) =+      foldl applyType' (IL.TypeForall tvs' (transType' ty []))+      where tvs' = filter ((`elem` tvs) . fst) ks++applyType' :: IL.Type -> IL.Type -> IL.Type+applyType' ty1 ty2 =+  IL.TypeConstructor (qualifyWith preludeMIdent (mkIdent "Apply")) [ty1, ty2]++-- We need to existentially quantify all variables in some types+polyType :: Type -> Type+polyType (TypeForall _ ty) = polyType ty+polyType ty                =+  let vs = nub $ typeVars ty+  in if null vs then ty else TypeForall vs ty++-- We need to infer kinds for the quantified variables.+-- We already checked the correctness of all Kinds earlier,+-- thus we know that we will be able to unify all the inferred equations.+-- We can also keep a flat environment,+-- as all variables have already been renamed.++data KIS = KIS+  { _nextId :: Int+  , kinds  :: Map.Map Int IL.Kind+  }++freshId :: S.State KIS Int+freshId = do+  KIS i ks <- S.get+  S.put (KIS (i+1) ks)+  return i++transTVars :: TCEnv -> Type -> [(Int, IL.Kind)]+transTVars tcEnv ty' =+  Map.toList $ kinds $ S.execState (build ty' IL.KindStar) (KIS 0 Map.empty)+  where+    build :: Type -> IL.Kind -> S.State KIS ()+    build (TypeArrow     ty1 ty2) _ =+      build ty1 IL.KindStar >> build ty2 IL.KindStar+    build (TypeConstrained tys _) k =+      build (head tys) k+    build (TypeForall       _ ty) k =+      build ty k+    build (TypeVariable       tv) k = do+      KIS i ks <- S.get+      -- get current kind+      let k' = Map.findWithDefault k tv ks+      -- unify it+      let s = unifyKind k k'+      -- apply substitution+      let ks' = fmap (applyKindSubst s) $ Map.insert tv k' ks+      S.put (KIS i ks')+    build (TypeConstructor     _) _ = return ()+    build ta@(TypeApply       _ _) k =+      let (ty, tys) = unapplyType True ta+      in case ty of+        TypeConstructor tc -> do+          let k' = tcKind (fromJust $ qidModule tc) tc tcEnv+          mapM_ (uncurry build) (zip tys $ unarrowKind $ transKind k')+        _ -> do -- var of forall+          -- construct new kind vars+          ks <- mapM (const (freshId >>= return . IL.KindVariable)) tys+          -- infer kind for v+          build ty (foldr IL.KindArrow k ks)+          -- infer kinds for args+          mapM_ (uncurry build) (zip tys ks)++type KindSubst = Map.Map Int IL.Kind++transKind :: Kind -> IL.Kind+transKind KindStar          = IL.KindStar+transKind (KindVariable  _) = IL.KindStar+transKind (KindArrow k1 k2) = IL.KindArrow (transKind k1) (transKind k2)++unarrowKind :: IL.Kind -> [IL.Kind]+unarrowKind (IL.KindArrow k1 k2) = k1 : unarrowKind k2+unarrowKind k                    = [k]++applyKindSubst :: KindSubst -> IL.Kind -> IL.Kind+applyKindSubst _ IL.KindStar =+  IL.KindStar+applyKindSubst s (IL.KindArrow k1 k2) =+  IL.KindArrow (applyKindSubst s k1) (applyKindSubst s k2)+applyKindSubst s v@(IL.KindVariable i) =+  Map.findWithDefault v i s++composeKindSubst :: KindSubst -> KindSubst -> KindSubst+composeKindSubst s1 s2 = Map.map (applyKindSubst s1) s2 `Map.union` s1++unifyKind :: IL.Kind -> IL.Kind -> KindSubst+unifyKind IL.KindStar          IL.KindStar            = Map.empty+unifyKind (IL.KindVariable i)  k                      = Map.singleton i k+unifyKind k                    (IL.KindVariable i)    = Map.singleton i k+unifyKind (IL.KindArrow k1 k2) (IL.KindArrow k1' k2') =+  let s1 = unifyKind k1 k1'+      s2 = unifyKind (applyKindSubst s1 k2) (applyKindSubst s1 k2')+  in s1 `composeKindSubst` s2+unifyKind k1 k2 = error $ "Transformation.CurryToIL.unifyKind: " ++ show k1 ++ ", " ++ show k2++-- Each function in the program is translated into a function of the+-- intermediate language. The arguments of the function are renamed such+-- that all variables occurring in the same position (in different+-- equations) have the same name. This is necessary in order to+-- facilitate the translation of pattern matching into a 'case' expression.+-- We use the following simple convention here: The top-level+-- arguments of the function are named from left to right '_1', '_2',+-- and so on. The names of nested arguments are constructed by appending+-- '_1', '_2', etc. from left to right to the name that were assigned+-- to a variable occurring at the position of the constructor term.++-- Some special care is needed for the selector functions introduced by+-- the compiler in place of pattern bindings. In order to generate the+-- code for updating all pattern variables, the equality of names between+-- the pattern variables in the first argument of the selector function+-- and their repeated occurrences in the remaining arguments must be+-- preserved. This means that the second and following arguments of a+-- selector function have to be renamed according to the name mapping+-- computed for its first argument.++trFunction :: Ident -> [Equation Type] -> TransM IL.Decl+trFunction f eqs = do+  f' <- trQualify f+  tcEnv <- getTCEnv+  let tys = map typeOf ts+      ty' = transType tcEnv $ polyType $ foldr TypeArrow (typeOf rhs) tys+      vs' = zip (map (transType tcEnv) tys) vs+  alts <- mapM (trEquation vs ws) eqs+  return $ IL.FunctionDecl f' vs' ty' (flexMatch vs' alts)+  where+  -- vs are the variables needed for the function: _1, _2, etc.+  -- ws is an infinite list for introducing additional variables later+  Equation _ lhs rhs = head eqs+  (_, ts) = flatLhs lhs+  (vs, ws) = splitAt (length ts) (argNames (mkIdent ""))++trEquation :: [Ident]       -- identifiers for the function's parameters+           -> [Ident]       -- infinite list of additional identifiers+           -> Equation Type -- equation to be translated+           -> TransM Match  -- nested constructor terms + translated RHS+trEquation vs vs' (Equation _ (FunLhs _ _ ts) rhs) = do+  -- construct renaming of variables inside constructor terms+  let patternRenaming = foldr2 bindRenameEnv Map.empty vs ts+  -- translate right-hand-side+  rhs' <- trRhs vs' patternRenaming rhs+  -- convert patterns+  tcEnv <- getTCEnv+  return (zipWith (trPattern tcEnv) vs ts, rhs')+trEquation _  _    _+  = internalError "Translation of non-FunLhs euqation not defined"++type RenameEnv = Map.Map Ident Ident++-- Construct a renaming of all variables inside the pattern to fresh identifiers+bindRenameEnv :: Ident -> Pattern a -> RenameEnv -> RenameEnv+bindRenameEnv _ (LiteralPattern        _ _ _) env = env+bindRenameEnv v (VariablePattern      _ _ v') env = Map.insert v' v env+bindRenameEnv v (ConstructorPattern _ _ _ ts) env+  = foldr2 bindRenameEnv env (argNames v) ts+bindRenameEnv v (AsPattern            _ v' t) env+  = Map.insert v' v (bindRenameEnv v t env)+bindRenameEnv _ _                           _+  = internalError "CurryToIL.bindRenameEnv"++trRhs :: [Ident] -> RenameEnv -> Rhs Type -> TransM IL.Expression+trRhs vs env (SimpleRhs _ _ e _) = trExpr vs env e+trRhs _  _   (GuardedRhs _ _ _ _) = internalError "CurryToIL.trRhs: GuardedRhs"++-- Note that the case matching algorithm assumes that the matched+-- expression is accessible through a variable. The translation of case+-- expressions therefore introduces a let binding for the scrutinized+-- expression and immediately throws it away after the matching -- except+-- if the matching algorithm has decided to use that variable in the+-- right hand sides of the case expression. This may happen, for+-- instance, if one of the alternatives contains an as-pattern.++trExpr :: [Ident] -> RenameEnv -> Expression Type -> TransM IL.Expression+trExpr _  _   (Literal     _ ty l) = do+  tcEnv <- getTCEnv+  return $ IL.Literal (transType tcEnv ty) (trLiteral l)+trExpr _  env (Variable    _ ty v)+  | isQualified v = getTCEnv >>= fun+  | otherwise     = do+    tcEnv <- getTCEnv+    case Map.lookup (unqualify v) env of+      Nothing -> error $ "unexpected variable" ++ show v --TODO: Replace case by fromJust?+      Just v' -> return $ IL.Variable (transType tcEnv ty) v' -- apply renaming+  where+    fun tcEnv = IL.Function (transType tcEnv ty) v <$> getArity v+trExpr _  _   (Constructor _ ty c) = do+  tcEnv <- getTCEnv+  IL.Constructor (transType tcEnv ty) c <$> getArity c+trExpr vs env (Apply     _ e1 e2)+  = IL.Apply <$> trExpr vs env e1 <*> trExpr vs env e2+trExpr vs env (Let      _ _ ds e) = do+  e' <- trExpr vs env' e+  case ds of+    [FreeDecl _ vs']+       -> do tcEnv <- getTCEnv+             return $+               foldr (\ (Var ty v) -> IL.Exist v (transType tcEnv ty)) e' vs'+    [d] | all (`notElem` bv d) (qfv emptyMIdent d)+      -> flip IL.Let    e' <$>      trBinding d+    _ -> flip IL.Letrec e' <$> mapM trBinding ds+  where+  env' = foldr2 Map.insert env bvs bvs+  bvs  = bv ds+  trBinding (PatternDecl _ (VariablePattern _ _ v) rhs)+    = IL.Binding v <$> trRhs vs env' rhs+  trBinding p = error $ "unexpected binding: " ++ show p+trExpr (v:vs) env (Case _ _ ct e alts) = do+  -- the ident v is used for the case expression subject, as this could+  -- be referenced in the case alternatives by a variable pattern+  e' <- trExpr vs env e+  tcEnv <- getTCEnv+  let matcher = if ct == Flex then flexMatch else rigidMatch+      ty'     = transType tcEnv $ typeOf e+  expr <- matcher [(ty', v)] <$> mapM (trAlt (v:vs) env) alts+  return $ case expr of+    IL.Case mode (IL.Variable _ v') alts'+        -- subject is not referenced -> forget v and insert subject+      | v == v' && v `notElem` fv alts' -> IL.Case mode e' alts'+    _+        -- subject is referenced -> introduce binding for v as subject+      | v `elem` fv expr                -> IL.Let (IL.Binding v e') expr+      | otherwise                       -> expr+trExpr vs env (Typed _ e _) = do+  tcEnv <- getTCEnv+  e' <- trExpr vs env e+  return $ IL.Typed e' (transType tcEnv $ typeOf e)+trExpr _ _ _ = internalError "CurryToIL.trExpr"++trAlt :: [Ident] -> RenameEnv -> Alt Type -> TransM Match+trAlt ~(v:vs) env (Alt _ t rhs) = do+  tcEnv <- getTCEnv+  rhs' <- trRhs vs (bindRenameEnv v t env) rhs+  return ([trPattern tcEnv v t], rhs')++trLiteral :: Literal -> IL.Literal+trLiteral (Char  c) = IL.Char c+trLiteral (Int   i) = IL.Int i+trLiteral (Float f) = IL.Float f+trLiteral _         = internalError "CurryToIL.trLiteral"++-- -----------------------------------------------------------------------------+-- Translation of Patterns+-- -----------------------------------------------------------------------------++data NestedTerm = NestedTerm IL.ConstrTerm [NestedTerm] deriving Show++pattern :: NestedTerm -> IL.ConstrTerm+pattern (NestedTerm t _) = t++arguments :: NestedTerm -> [NestedTerm]+arguments (NestedTerm _ ts) = ts++trPattern :: TCEnv -> Ident -> Pattern Type -> NestedTerm+trPattern tcEnv _ (LiteralPattern        _ ty l)+  = NestedTerm (IL.LiteralPattern (transType tcEnv ty) $ trLiteral l) []+trPattern tcEnv v (VariablePattern       _ ty _)+  = NestedTerm (IL.VariablePattern (transType tcEnv ty) v) []+trPattern tcEnv v (ConstructorPattern _ ty c ts)+  = NestedTerm (IL.ConstructorPattern (transType tcEnv ty) c vs')+               (zipWith (trPattern tcEnv) vs ts)+  where vs  = argNames v+        vs' = zip (map (transType tcEnv . typeOf) ts) vs+trPattern tcEnv v (AsPattern              _ _ t)+  = trPattern tcEnv v t+trPattern _ _ _+  = internalError "CurryToIL.trPattern"++argNames :: Ident -> [Ident]+argNames v = [mkIdent (prefix ++ show i) | i <- [1 :: Integer ..] ]+  where prefix = idName v ++ "_"++-- -----------------------------------------------------------------------------+-- Flexible Pattern Matching Algorithm+-- -----------------------------------------------------------------------------++-- The pattern matching code searches for the left-most inductive+-- argument position in the left hand sides of all rules defining an+-- equation. An inductive position is a position where all rules have a+-- constructor rooted term. If such a position is found, a flexible 'case'+-- expression is generated for the argument at that position. The+-- matching code is then computed recursively for all of the alternatives+-- independently. If no inductive position is found, the algorithm looks+-- for the left-most demanded argument position, i.e., a position where+-- at least one of the rules has a constructor rooted term. If such a+-- position is found, an 'or' expression is generated with those+-- cases that have a variable at the argument position in one branch and+-- all other rules in the other branch. If there is no demanded position,+-- the pattern matching is finished and the compiler translates the right+-- hand sides of the remaining rules, eventually combining them using+-- 'or' expressions.++-- Actually, the algorithm below combines the search for inductive and+-- demanded positions. The function 'flexMatch' scans the argument+-- lists for the left-most demanded position. If this turns out to be+-- also an inductive position, the function 'flexMatchInductive' is+-- called in order to generate a flexible 'case' expression. Otherwise, the+-- function 'optFlexMatch' is called that tries to find an inductive+-- position in the remaining arguments. If one is found,+-- 'flexMatchInductive' is called, otherwise the function+-- 'optFlexMatch' uses the demanded argument position found by 'flexMatch'.++-- a @Match@ is a list of patterns and the respective expression.+type Match  = ([NestedTerm], IL.Expression)+-- a @Match'@ is a @Match@ with skipped patterns during the search for an+-- inductive position.+type Match' = (FunList NestedTerm, [NestedTerm], IL.Expression)+-- Functional lists+type FunList a = [a] -> [a]++flexMatch :: [(IL.Type, Ident)] -- variables to be matched+          -> [Match]            -- alternatives+          -> IL.Expression      -- result expression+flexMatch []     alts = foldl1 IL.Or (map snd alts)+flexMatch (v:vs) alts+  | notDemanded = varExp+  | isInductive = conExp+  | otherwise   = optFlexMatch (IL.Or conExp varExp) (v:) vs (map skipPat alts)+  where+  isInductive        = null varAlts+  notDemanded        = null conAlts+  -- separate variable and constructor patterns+  (varAlts, conAlts) = partition isVarMatch (map tagAlt alts)+  -- match variables+  varExp             = flexMatch               vs (map snd  varAlts)+  -- match constructors+  conExp             = flexMatchInductive id v vs (map prep conAlts)+  prep (p, (ts, e))  = (p, (id, ts, e))++-- Search for the next inductive position+optFlexMatch :: IL.Expression            -- default expression+             -> FunList (IL.Type, Ident) -- skipped variables+             -> [(IL.Type, Ident)]       -- next variables+             -> [Match']                 -- alternatives+             -> IL.Expression+optFlexMatch def _      []     _    = def+optFlexMatch def prefix (v:vs) alts+  | isInductive = flexMatchInductive prefix v vs alts'+  | otherwise   = optFlexMatch def (prefix . (v:)) vs (map skipPat' alts)+  where+  isInductive   = not (any isVarMatch alts')+  alts'         = map tagAlt' alts++-- Generate a case expression matching the inductive position+flexMatchInductive :: FunList (IL.Type, Ident)  -- skipped variables+                   -> (IL.Type, Ident)          -- current variable+                   -> [(IL.Type, Ident)]        -- next variables+                   -> [(IL.ConstrTerm, Match')] -- alternatives+                   -> IL.Expression+flexMatchInductive prefix v vs as+  = IL.Case IL.Flex (uncurry IL.Variable v) (flexMatchAlts as)+  where+  -- create alternatives for the different constructors+  flexMatchAlts []              = []+  flexMatchAlts ((t, e) : alts) = IL.Alt t expr : flexMatchAlts others+    where+    -- match nested patterns for same constructors+    expr = flexMatch (prefix (vars t ++ vs)) (map expandVars (e : map snd same))+    expandVars (pref, ts1, e') = (pref ts1, e')+    -- split into same and other constructors+    (same, others) = partition ((t ==) . fst) alts++-- -----------------------------------------------------------------------------+-- Rigid Pattern Matching Algorithm+-- -----------------------------------------------------------------------------++-- Matching in a 'case'-expression works a little bit differently.+-- In this case, the alternatives are matched from the first to the last+-- alternative and the first matching alternative is chosen. All+-- remaining alternatives are discarded.++-- TODO: The case matching algorithm should use type information in order+-- to detect total matches and immediately discard all alternatives which+-- cannot be reached.++rigidMatch :: [(IL.Type, Ident)] -> [Match] -> IL.Expression+rigidMatch vs alts = rigidOptMatch (snd $ head alts) id vs (map prepare alts)+  where prepare (ts, e) = (id, ts, e)++rigidOptMatch :: IL.Expression            -- default expression+              -> FunList (IL.Type, Ident) -- variables to be matched next+              -> [(IL.Type, Ident)]       -- variables to be matched afterwards+              -> [Match']                 -- translated equations+              -> IL.Expression+-- if there are no variables left: return the default expression+rigidOptMatch def _      []       _    = def+rigidOptMatch def prefix (v : vs) alts+  | isDemanded = rigidMatchDemanded prefix v vs alts'+  | otherwise  = rigidOptMatch def (prefix . (v:)) vs (map skipPat' alts)+  where+  isDemanded   = not $ isVarMatch (head alts')+  alts'        = map tagAlt' alts++-- Generate a case expression matching the demanded position.+-- This algorithm constructs a branch for all contained patterns, where+-- the right-hand side then respects the order of the patterns.+-- Thus, the expression+--    case x of+--      []   -> []+--      ys   -> ys+--      y:ys -> [y]+-- gets translated to+--    case x of+--      []   -> []+--      y:ys -> x+--      x    -> x+rigidMatchDemanded :: FunList (IL.Type, Ident)  -- skipped variables+                   -> (IL.Type, Ident)          -- current variable+                   -> [(IL.Type, Ident)]        -- next variables+                   -> [(IL.ConstrTerm, Match')] -- alternatives+                   -> IL.Expression+rigidMatchDemanded prefix v vs alts = IL.Case IL.Rigid (uncurry IL.Variable v)+  $ map caseAlt (consPats ++ varPats)+  where+  -- N.B.: @varPats@ is either empty or a singleton list due to nub+  (varPats, consPats) = partition isVarPattern $ nub $ map fst alts+  caseAlt t           = IL.Alt t expr+    where+    expr = rigidMatch (prefix $ vars t ++ vs) (matchingCases alts)+    -- matchingCases selects the matching alternatives+    --  and recursively matches the remaining patterns+    matchingCases a = map (expandVars (vars t)) $ filter (matches . fst) a+    matches t' = t == t' || isVarPattern t'+    expandVars vs' (p, (pref, ts1, e)) = (pref ts2, e)+      where ts2 | isVarPattern p = map var2Pattern vs' ++ ts1+                | otherwise      = ts1+            var2Pattern v' = NestedTerm (uncurry IL.VariablePattern v') []++-- -----------------------------------------------------------------------------+-- Pattern Matching Auxiliaries+-- -----------------------------------------------------------------------------++isVarPattern :: IL.ConstrTerm -> Bool+isVarPattern (IL.VariablePattern _ _) = True+isVarPattern _                        = False++isVarMatch :: (IL.ConstrTerm, a) -> Bool+isVarMatch = isVarPattern . fst++vars :: IL.ConstrTerm -> [(IL.Type, Ident)]+vars (IL.ConstructorPattern _ _ vs) = vs+vars _                              = []++-- tagAlt extracts the structure of the first pattern+tagAlt :: Match -> (IL.ConstrTerm, Match)+tagAlt (t:ts, e) = (pattern t, (arguments t ++ ts, e))+tagAlt ([]  , _) = error "CurryToIL.tagAlt: empty pattern list"++-- skipPat skips the current pattern position for later matching+skipPat :: Match -> Match'+skipPat (t:ts, e) = ((t:), ts, e)+skipPat ([]  , _) = error "CurryToIL.skipPat: empty pattern list"++-- tagAlt' extracts the next pattern+tagAlt' :: Match' -> (IL.ConstrTerm, Match')+tagAlt' (pref, t:ts, e') = (pattern t, (pref, arguments t ++ ts, e'))+tagAlt' (_   , []  , _ ) = error "CurryToIL.tagAlt': empty pattern list"++-- skipPat' skips the current argument for later matching+skipPat' :: Match' -> Match'+skipPat' (pref, t:ts, e') = (pref . (t:), ts, e')+skipPat' (_   , []  , _ ) = error "CurryToIL.skipPat': empty pattern list"
+ src/Transformations/Derive.hs view
@@ -0,0 +1,729 @@+{- |+  Module      :  $Header$+  Description :  Deriving instances+  Copyright   :  (c) 2016        Finn Teegen+  License     :  BSD-3-clause++  Maintainer  :  bjp@informatik.uni-kiel.de+  Stability   :  experimental+  Portability :  portable++  TODO+-}+{-# LANGUAGE CPP #-}+module Transformations.Derive (derive) where++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative      ((<$>))+#endif+import Control.Monad               (replicateM)+import qualified Control.Monad.State as S (State, evalState, gets, modify)+import           Data.List         (intercalate, intersperse)+import           Data.Maybe        (fromJust, isJust)+import qualified Data.Set   as Set (deleteMin, union)++import Curry.Base.Ident+import Curry.Base.SpanInfo+import Curry.Syntax++import Base.CurryTypes (fromPredType)+import Base.Messages (internalError)+import Base.Types+import Base.TypeSubst (instanceType)+import Base.Typing (typeOf)+import Base.Utils (snd3, mapAccumM)++import Env.Instance+import Env.OpPrec+import Env.TypeConstructor+import Env.Value++data DVState = DVState+  { moduleIdent :: ModuleIdent+  , tyConsEnv   :: TCEnv+  , valueEnv    :: ValueEnv+  , instEnv     :: InstEnv+  , opPrecEnv   :: OpPrecEnv+  , nextId      :: Integer+  }++type DVM = S.State DVState++derive :: TCEnv -> ValueEnv -> InstEnv -> OpPrecEnv -> Module PredType+       -> Module PredType+derive tcEnv vEnv inEnv pEnv (Module spi li ps m es is ds) = Module spi li ps m es is $+  ds ++ concat (S.evalState (deriveAllInstances tds) initState)+  where tds = filter isTypeDecl ds+        initState = DVState m tcEnv vEnv inEnv pEnv 1++getModuleIdent :: DVM ModuleIdent+getModuleIdent = S.gets moduleIdent++getTyConsEnv :: DVM TCEnv+getTyConsEnv = S.gets tyConsEnv++getValueEnv :: DVM ValueEnv+getValueEnv = S.gets valueEnv++getInstEnv :: DVM InstEnv+getInstEnv = S.gets instEnv++getPrecEnv :: DVM OpPrecEnv+getPrecEnv = S.gets opPrecEnv++getNextId :: DVM Integer+getNextId = do+  nid <- S.gets nextId+  S.modify $ \s -> s { nextId = succ nid }+  return nid++-- TODO: Comment (here and below)++type ConstrInfo = (Int, QualIdent, Maybe [Ident], [Type])++deriveAllInstances :: [Decl PredType] -> DVM [[Decl PredType]]+deriveAllInstances ds = do+  derived <- mapM deriveInstances ds+  inst <- getInstEnv+  mid <- getModuleIdent+  let dds = filter (hasDataInstance inst mid) ds+  datains <- mapM deriveDataInstance dds+  return (datains:derived)++-- If we ever entered a data instance for this datatype into the instance+-- environment, we can safely derive a data instance+hasDataInstance :: InstEnv -> ModuleIdent -> Decl PredType -> Bool+hasDataInstance inst mid (DataDecl    _ tc _ _ _) =+  maybe False (\(mid', _, _) -> mid == mid') $+    lookupInstInfo (qDataId, qualifyWith mid tc) inst+hasDataInstance inst mid (NewtypeDecl _ tc _ _ _) =+  maybe False (\(mid', _, _) -> mid == mid') $+    lookupInstInfo (qDataId, qualifyWith mid tc) inst+hasDataInstance _       _   _                     =+  False++deriveDataInstance :: Decl PredType -> DVM (Decl PredType)+deriveDataInstance (DataDecl    p tc tvs _ _) =+  head <$> deriveInstances (DataDecl p tc tvs [] [qDataId])+deriveDataInstance (NewtypeDecl p tc tvs _ _) =+  deriveDataInstance $ DataDecl p tc tvs [] []+deriveDataInstance _                          =+  internalError "Derive.deriveDataInstance: No DataDel"++-- An instance declaration is created for each type class of a deriving clause.+-- Newtype declaration are simply treated as data declarations.++deriveInstances :: Decl PredType -> DVM [Decl PredType]+deriveInstances (DataDecl    _ tc tvs _ clss) = do+  m <- getModuleIdent+  tcEnv <- getTyConsEnv+  let otc = qualifyWith m tc+      cis = constructors m otc tcEnv+  mapM (deriveInstance otc tvs cis) clss+deriveInstances (NewtypeDecl p tc tvs _ clss) =+  deriveInstances $ DataDecl p tc tvs [] clss+deriveInstances _                             = return []++deriveInstance :: QualIdent -> [Ident] -> [ConstrInfo] -> QualIdent+               -> DVM (Decl PredType)+deriveInstance tc tvs cis cls = do+  inEnv <- getInstEnv+  let ps = snd3 $ fromJust $ lookupInstInfo (cls, tc) inEnv+      ty = applyType (TypeConstructor tc) $+             take (length tvs) $ map TypeVariable [0 ..]+      QualTypeExpr _ cx inst = fromPredType tvs $ PredType ps ty+  ds <- deriveMethods cls ty cis ps+  return $ InstanceDecl NoSpanInfo WhitespaceLayout cx cls inst ds++-- Note: The methods and arities of the generated instance declarations have to+-- correspond to the methods and arities entered previously into the instance+-- environment (see instance check).++deriveMethods :: QualIdent -> Type -> [ConstrInfo] -> PredSet+              -> DVM [Decl PredType]+deriveMethods cls+  | cls == qEqId      = deriveEqMethods+  | cls == qOrdId     = deriveOrdMethods+  | cls == qEnumId    = deriveEnumMethods+  | cls == qBoundedId = deriveBoundedMethods+  | cls == qReadId    = deriveReadMethods+  | cls == qShowId    = deriveShowMethods+  | cls == qDataId    = deriveDataMethods+  | otherwise         = internalError $ "Derive.deriveMethods: " ++ show cls++-- Binary Operators:++type BinOpExpr = Int+              -> [Expression PredType]+              -> Int+              -> [Expression PredType]+              -> Expression PredType++deriveBinOp :: QualIdent -> Ident -> BinOpExpr -> Type -> [ConstrInfo]+            -> PredSet -> DVM (Decl PredType)+deriveBinOp cls op expr ty cis ps = do+  pty <- getInstMethodType ps cls ty op+  eqs <- mapM (deriveBinOpEquation op expr ty) $ sequence [cis, cis]+  return $ FunctionDecl NoSpanInfo pty op $+    if null eqs+      then [mkEquation NoSpanInfo op [] $+        preludeFailed $ instType $ unpredType pty]+      else eqs++deriveBinOpEquation :: Ident -> BinOpExpr -> Type -> [ConstrInfo]+                    -> DVM (Equation PredType)+deriveBinOpEquation op expr ty [(i1, c1, _, tys1), (i2, c2, _, tys2)] = do+  vs1 <- mapM (freshArgument . instType) tys1+  vs2 <- mapM (freshArgument . instType) tys2+  let pat1 = constrPattern pty c1 vs1+      pat2 = constrPattern pty c2 vs2+      es1 = map (uncurry mkVar) vs1+      es2 = map (uncurry mkVar) vs2+  return $ mkEquation NoSpanInfo op [pat1, pat2] $ expr i1 es1 i2 es2+  where pty = predType $ instType ty+deriveBinOpEquation _ _ _ _ = internalError "Derive.deriveBinOpEquation"++-- Equality:++deriveEqMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType]+deriveEqMethods ty cis ps = sequence+  [deriveBinOp qEqId eqOpId eqOpExpr ty cis ps]++eqOpExpr :: BinOpExpr+eqOpExpr i1 es1 i2 es2+  | i1 == i2  = if null es1 then prelTrue+                            else foldl1 prelAnd $ zipWith prelEq es1 es2+  | otherwise = prelFalse++-- Data:++deriveDataMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType]+deriveDataMethods ty cis ps = sequence+  [ deriveBinOp qDataId dataEqId dataEqOpExpr ty cis ps+  , deriveAValue ty cis ps]++dataEqOpExpr :: BinOpExpr+dataEqOpExpr i1 es1 i2 es2+  | i1 == i2  = if null es1 then prelTrue+                            else foldl1 prelAnd $ zipWith prelDataEq es1 es2+  | otherwise = prelFalse++deriveAValue :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType)+deriveAValue ty cis ps = do+  pty <- getInstMethodType ps qDataId ty aValueId+  return $ FunctionDecl NoSpanInfo pty aValueId $+    if null cis+      then [mkEquation NoSpanInfo aValueId [] $ preludeFailed $ instType ty]+      else map (aValueEquation ty) cis++aValueEquation :: Type -> ConstrInfo -> Equation PredType+aValueEquation ty (arity, cns, _, tys)+  | arity >= 0 = mkEquation NoSpanInfo aValueId [] $ predType <$>+                  foldl (Apply NoSpanInfo)+                    (Constructor NoSpanInfo constrType cns)+                    (map mkAValue tys')+  | otherwise  = internalError "Derive.aValueEquation: negative arity"+  where+    constrType = foldr TypeArrow (instType ty) tys'+    mkAValue argTy = Variable NoSpanInfo argTy qAValueId+    tys' = map instType tys++-- Ordering:++deriveOrdMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType]+deriveOrdMethods ty cis ps = sequence+  [deriveBinOp qOrdId leqOpId leqOpExpr ty cis ps]++leqOpExpr :: BinOpExpr+leqOpExpr i1 es1 i2 es2+  | i1 < i2   = prelTrue+  | i1 > i2   = prelFalse+  | otherwise = if null es1 then prelTrue+                            else foldl1 prelOr $ map innerAnd [0 .. n - 1]+  where n = length es1+        innerAnd i = foldl1 prelAnd $ map (innerOp i) [0 .. i]+        innerOp i j | j == n - 1 = prelLeq (es1 !! j) (es2 !! j)+                    | j == i     = prelLt  (es1 !! j) (es2 !! j)+                    | otherwise  = prelEq  (es1 !! j) (es2 !! j)++-- Enumerations:++deriveEnumMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType]+deriveEnumMethods ty cis ps = sequence+  [ deriveSuccOrPred succId ty cis (tail cis) ps+  , deriveSuccOrPred predId ty (tail cis) cis ps+  , deriveToEnum ty cis ps+  , deriveFromEnum ty cis ps+  , deriveEnumFrom ty (last cis) ps+  , deriveEnumFromThen ty (head cis) (last cis) ps+  ]++deriveSuccOrPred :: Ident -> Type -> [ConstrInfo] -> [ConstrInfo] -> PredSet+                 -> DVM (Decl PredType)+deriveSuccOrPred f ty cis1 cis2 ps = do+  pty <- getInstMethodType ps qEnumId ty f+  FunctionDecl NoSpanInfo pty f <$>+    if null eqs+      then do+        v <- freshArgument $ instType ty+        return [mkEquation NoSpanInfo f [uncurry (VariablePattern NoSpanInfo) v] $+          preludeFailed $ instType ty]+      else return eqs+  where eqs = zipWith (succOrPredEquation f ty) cis1 cis2++succOrPredEquation :: Ident -> Type -> ConstrInfo -> ConstrInfo+                   -> Equation PredType+succOrPredEquation f ty (_, c1, _, _) (_, c2, _, _) =+  mkEquation NoSpanInfo f [ConstructorPattern NoSpanInfo pty c1 []] $+    Constructor NoSpanInfo pty c2+  where pty = predType $ instType ty++deriveToEnum :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType)+deriveToEnum ty cis ps = do+  pty <- getInstMethodType ps qEnumId ty toEnumId+  return $ FunctionDecl NoSpanInfo pty toEnumId eqs+  where eqs = zipWith (toEnumEquation ty) [0 ..] cis++toEnumEquation :: Type -> Integer -> ConstrInfo -> Equation PredType+toEnumEquation ty i (_, c, _, _) =+  mkEquation NoSpanInfo toEnumId+    [LiteralPattern NoSpanInfo (predType intType) (Int i)] $+    Constructor NoSpanInfo (predType $ instType ty) c++deriveFromEnum :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType)+deriveFromEnum ty cis ps = do+  pty <- getInstMethodType ps qEnumId ty fromEnumId+  return $ FunctionDecl NoSpanInfo pty fromEnumId eqs+  where eqs = zipWith (fromEnumEquation ty) cis [0 ..]++fromEnumEquation :: Type -> ConstrInfo -> Integer -> Equation PredType+fromEnumEquation ty (_, c, _, _) i =+  mkEquation NoSpanInfo fromEnumId [ConstructorPattern NoSpanInfo pty c []] $+    Literal NoSpanInfo (predType intType) $ Int i+  where pty = predType $ instType ty++deriveEnumFrom :: Type -> ConstrInfo -> PredSet -> DVM (Decl PredType)+deriveEnumFrom ty (_, c, _, _) ps = do+  pty <- getInstMethodType ps qEnumId ty enumFromId+  v <- freshArgument $ instType ty+  return $ funDecl NoSpanInfo pty enumFromId+    [uncurry (VariablePattern NoSpanInfo) v] $+    enumFromExpr v c++enumFromExpr :: (PredType, Ident) -> QualIdent -> Expression PredType+enumFromExpr v c = prelEnumFromTo (uncurry mkVar v) $+  Constructor NoSpanInfo (fst v) c++deriveEnumFromThen :: Type -> ConstrInfo -> ConstrInfo -> PredSet+                   -> DVM (Decl PredType)+deriveEnumFromThen ty (_, c1, _, _) (_, c2, _, _) ps = do+  pty <- getInstMethodType ps qEnumId ty enumFromId+  vs  <- replicateM 2 ((freshArgument . instType) ty)+  let [v1, v2] = vs+  return $ funDecl NoSpanInfo pty enumFromThenId+    (map (uncurry (VariablePattern NoSpanInfo)) vs) $+    enumFromThenExpr v1 v2 c1 c2++enumFromThenExpr :: (PredType, Ident) -> (PredType, Ident) -> QualIdent+                 -> QualIdent -> Expression PredType+enumFromThenExpr v1 v2 c1 c2 =+  prelEnumFromThenTo (uncurry mkVar v1) (uncurry mkVar v2) boundedExpr+  where boundedExpr = IfThenElse NoSpanInfo+                                 (prelLeq+                                   (prelFromEnum $ uncurry mkVar v1)+                                   (prelFromEnum $ uncurry mkVar v2))+                                 (Constructor NoSpanInfo (fst v1) c2)+                                 (Constructor NoSpanInfo (fst v1) c1)++-- Upper and Lower Bounds:++deriveBoundedMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType]+deriveBoundedMethods ty cis ps = sequence+  [ deriveMaxOrMinBound qMinBoundId ty (head cis) ps+  , deriveMaxOrMinBound qMaxBoundId ty (last cis) ps+  ]++deriveMaxOrMinBound :: QualIdent -> Type -> ConstrInfo -> PredSet+                    -> DVM (Decl PredType)+deriveMaxOrMinBound f ty (_, c, _, tys) ps = do+  pty <- getInstMethodType ps qBoundedId ty $ unqualify f+  return $ funDecl NoSpanInfo pty (unqualify f) [] $ maxOrMinBoundExpr f c ty tys++maxOrMinBoundExpr :: QualIdent -> QualIdent -> Type -> [Type]+                  -> Expression PredType+maxOrMinBoundExpr f c ty tys =+  apply (Constructor NoSpanInfo pty c) $+  map (flip (Variable NoSpanInfo) f . predType) instTys+  where instTy:instTys = map instType $ ty : tys+        pty = predType $ foldr TypeArrow instTy instTys++-- Read:++deriveReadMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType]+deriveReadMethods ty cis ps = sequence [deriveReadsPrec ty cis ps]++deriveReadsPrec :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType)+deriveReadsPrec ty cis ps = do+  pty <- getInstMethodType ps qReadId ty readsPrecId+  d <- freshArgument intType+  r <- freshArgument stringType+  let pats = map (uncurry (VariablePattern NoSpanInfo)) [d, r]+  funDecl NoSpanInfo pty readsPrecId pats <$>+    deriveReadsPrecExpr ty cis (uncurry mkVar d) (uncurry mkVar r)++deriveReadsPrecExpr :: Type -> [ConstrInfo] -> Expression PredType+                    -> Expression PredType -> DVM (Expression PredType)+deriveReadsPrecExpr ty cis d r = do+  es <- mapM (deriveReadsPrecReadParenExpr ty d) cis+  return $ foldr1 prelAppend $ map (flip (Apply NoSpanInfo) r) es++deriveReadsPrecReadParenExpr :: Type -> Expression PredType -> ConstrInfo+                             -> DVM (Expression PredType)+deriveReadsPrecReadParenExpr ty d ci@(_, c, _, _) = do+  pEnv <- getPrecEnv+  let p = precedence c pEnv+  e <- deriveReadsPrecLambdaExpr ty ci p+  return $ prelReadParen (readsPrecReadParenCondExpr ci d p) e++readsPrecReadParenCondExpr :: ConstrInfo -> Expression PredType -> Precedence+                           -> Expression PredType+readsPrecReadParenCondExpr (_, c, _, tys) d p+  | null tys                        = prelFalse+  | isQInfixOp c && length tys == 2 =+    prelLt (Literal NoSpanInfo predIntType $ Int p) d+  | otherwise                       =+    prelLt (Literal NoSpanInfo predIntType $ Int 10) d++deriveReadsPrecLambdaExpr :: Type -> ConstrInfo -> Precedence+                      -> DVM (Expression PredType)+deriveReadsPrecLambdaExpr ty (_, c, ls, tys) p = do+  r <- freshArgument stringType+  (stmts, vs, s) <- deriveReadsPrecStmts (unqualify c) (p + 1) r ls tys+  let pty = predType $ foldr (TypeArrow . instType) (instType ty) tys+      e = Tuple NoSpanInfo+                [ apply (Constructor NoSpanInfo pty c) $ map (uncurry mkVar) vs+                , uncurry mkVar s+                ]+  return $ Lambda NoSpanInfo [uncurry (VariablePattern NoSpanInfo) r]+         $ ListCompr NoSpanInfo e stmts++deriveReadsPrecStmts+  :: Ident -> Precedence -> (PredType, Ident) -> Maybe [Ident] -> [Type]+  -> DVM ([Statement PredType], [(PredType, Ident)], (PredType, Ident))+deriveReadsPrecStmts c p r ls tys+  | null tys                       = deriveReadsPrecNullaryConstrStmts c r+  | isJust ls                      =+    deriveReadsPrecRecordConstrStmts c r (fromJust ls) tys+  | isInfixOp c && length tys == 2 = deriveReadsPrecInfixConstrStmts c p r tys+  | otherwise                      = deriveReadsPrecConstrStmts c r tys++deriveReadsPrecNullaryConstrStmts+  :: Ident -> (PredType, Ident)+  -> DVM ([Statement PredType], [(PredType, Ident)], (PredType, Ident))+deriveReadsPrecNullaryConstrStmts c r = do+  (s, stmt) <- deriveReadsPrecLexStmt (idName c) r+  return ([stmt], [], s)++deriveReadsPrecRecordConstrStmts+  :: Ident -> (PredType, Ident) -> [Ident] -> [Type]+  -> DVM ([Statement PredType], [(PredType, Ident)], (PredType, Ident))+deriveReadsPrecRecordConstrStmts c r ls tys = do+  (s, stmt1) <- deriveReadsPrecLexStmt (idName c) r+  (t, ress) <-+    mapAccumM deriveReadsPrecFieldStmts s $ zip3 ("{" : repeat ",") ls tys+  let (stmtss, vs) = unzip ress+  (u, stmt2) <- deriveReadsPrecLexStmt "}" t+  return (stmt1 : concat stmtss ++ [stmt2], vs, u)++deriveReadsPrecFieldStmts+  :: (PredType, Ident) -> (String, Ident, Type)+  -> DVM ((PredType, Ident), ([Statement PredType], (PredType, Ident)))+deriveReadsPrecFieldStmts r (pre, l, ty) = do+  (s, stmt1) <- deriveReadsPrecLexStmt pre r+  (t, stmt2) <- deriveReadsPrecLexStmt (idName l) s+  (u, stmt3) <- deriveReadsPrecLexStmt "=" t+  (w, (stmt4, v)) <- deriveReadsPrecReadsPrecStmt 0 u ty+  return (w, ([stmt1, stmt2, stmt3, stmt4], v))++deriveReadsPrecInfixConstrStmts+  :: Ident -> Precedence -> (PredType, Ident) -> [Type]+  -> DVM ([Statement PredType], [(PredType, Ident)], (PredType, Ident))+deriveReadsPrecInfixConstrStmts c p r tys = do+  (s, (stmt1, v1)) <- deriveReadsPrecReadsPrecStmt (p + 1) r $ head tys+  (t, stmt2) <- deriveReadsPrecLexStmt (idName c) s+  (u, (stmt3, v2)) <- deriveReadsPrecReadsPrecStmt (p + 1) t $ head $ tail tys+  return ([stmt1, stmt2, stmt3], [v1, v2], u)++deriveReadsPrecConstrStmts+  :: Ident -> (PredType, Ident) -> [Type]+  -> DVM ([Statement PredType], [(PredType, Ident)], (PredType, Ident))+deriveReadsPrecConstrStmts c r tys = do+    (s, stmt) <- deriveReadsPrecLexStmt (idName c) r+    (t, ress) <- mapAccumM (deriveReadsPrecReadsPrecStmt 11) s tys+    let (stmts, vs) = unzip ress+    return (stmt : stmts, vs, t)++deriveReadsPrecLexStmt :: String -> (PredType, Ident)+                      -> DVM ((PredType, Ident), Statement PredType)+deriveReadsPrecLexStmt str r = do+  s <- freshArgument stringType+  let pat  = TuplePattern NoSpanInfo+               [ LiteralPattern NoSpanInfo predStringType $ String str+               , uncurry (VariablePattern NoSpanInfo) s+               ]+      stmt = StmtBind NoSpanInfo pat $ preludeLex $ uncurry mkVar r+  return (s, stmt)++deriveReadsPrecReadsPrecStmt  :: Precedence -> (PredType, Ident) -> Type+      -> DVM ((PredType, Ident), (Statement PredType, (PredType, Ident)))+deriveReadsPrecReadsPrecStmt p r ty = do+  v <- freshArgument $ instType ty+  s <- freshArgument $ stringType+  let pat  = TuplePattern NoSpanInfo $+               map (uncurry (VariablePattern NoSpanInfo)) [v, s]+      stmt = StmtBind NoSpanInfo pat $ preludeReadsPrec (instType ty) p $+               uncurry mkVar r+  return (s, (stmt, v))++-- Show:++deriveShowMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType]+deriveShowMethods ty cis ps = sequence [deriveShowsPrec ty cis ps]++deriveShowsPrec :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType)+deriveShowsPrec ty cis ps = do+  pty <- getInstMethodType ps qShowId ty showsPrecId+  eqs <- mapM (deriveShowsPrecEquation ty) cis+  return $ FunctionDecl NoSpanInfo pty showsPrecId eqs++deriveShowsPrecEquation :: Type -> ConstrInfo -> DVM (Equation PredType)+deriveShowsPrecEquation ty (_, c, ls, tys) = do+  d <- freshArgument intType+  vs <- mapM (freshArgument . instType) tys+  let pats = [uncurry (VariablePattern NoSpanInfo) d, constrPattern pty c vs]+  pEnv <- getPrecEnv+  return $ mkEquation NoSpanInfo showsPrecId pats $ showsPrecExpr (unqualify c)+    (precedence c pEnv) ls (uncurry mkVar d) $ map (uncurry mkVar) vs+  where pty = predType $ instType ty++showsPrecExpr :: Ident -> Precedence -> Maybe [Ident] -> Expression PredType+              -> [Expression PredType] -> Expression PredType+showsPrecExpr c p ls d vs+  | null vs                       = showsPrecNullaryConstrExpr c+  | isJust ls                     = showsPrecShowParenExpr d 10 $+    showsPrecRecordConstrExpr c (fromJust ls) vs+  | isInfixOp c && length vs == 2 = showsPrecShowParenExpr d p $+    showsPrecInfixConstrExpr c p vs+  | otherwise                     = showsPrecShowParenExpr d 10 $+    showsPrecConstrExpr c vs++showsPrecNullaryConstrExpr :: Ident -> Expression PredType+showsPrecNullaryConstrExpr c = preludeShowString $ showsConstr c ""++showsPrecShowParenExpr :: Expression PredType -> Precedence+                       -> Expression PredType -> Expression PredType+showsPrecShowParenExpr d p =+  prelShowParen $ prelLt (Literal NoSpanInfo predIntType $ Int p) d++showsPrecRecordConstrExpr :: Ident -> [Ident] -> [Expression PredType]+                          -> Expression PredType+showsPrecRecordConstrExpr c ls vs = foldr prelDot (preludeShowString "}") $+  (:) (preludeShowString $ showsConstr c " {") $+    intercalate [preludeShowString ", "] $ zipWith showsPrecFieldExpr ls vs++showsPrecFieldExpr :: Ident -> Expression PredType -> [Expression PredType]+showsPrecFieldExpr l v =+  [preludeShowString $ showsConstr l " = ", preludeShowsPrec 0 v]++showsPrecInfixConstrExpr :: Ident -> Precedence -> [Expression PredType]+                         -> Expression PredType+showsPrecInfixConstrExpr c p vs = foldr1 prelDot+  [ preludeShowsPrec (p + 1) $ head vs+  , preludeShowString $ ' ' : idName c ++ " "+  , preludeShowsPrec (p + 1) $ head $ tail vs+  ]++showsPrecConstrExpr :: Ident -> [Expression PredType] -> Expression PredType+showsPrecConstrExpr c vs = foldr1 prelDot $+  preludeShowString (showsConstr c " ") :+    intersperse (preludeShowString " ") (map (preludeShowsPrec 11) vs)++-- -----------------------------------------------------------------------------+-- Generating variables+-- -----------------------------------------------------------------------------++freshArgument :: Type -> DVM (PredType, Ident)+freshArgument = freshVar "_#arg"++freshVar :: String -> Type -> DVM (PredType, Ident)+freshVar name ty =+  ((,) (predType ty)) . mkIdent . (name ++) .  show <$> getNextId++-- -----------------------------------------------------------------------------+-- Auxiliary functions+-- -----------------------------------------------------------------------------++constructors :: ModuleIdent -> QualIdent -> TCEnv -> [ConstrInfo]+constructors m tc tcEnv =  zipWith (mkConstrInfo m) [1 ..] $+  case qualLookupTypeInfo tc tcEnv of+    [DataType     _ _ cs] -> cs+    [RenamingType _ _ nc] -> [nc]+    _                     -> internalError $ "Derive.constructors: " ++ show tc++mkConstrInfo :: ModuleIdent -> Int -> DataConstr -> ConstrInfo+mkConstrInfo m i (DataConstr   c    tys) =+  (i, qualifyWith m c, Nothing, tys)+mkConstrInfo m i (RecordConstr c ls tys) =+  (i, qualifyWith m c, Just ls, tys)++showsConstr :: Ident -> ShowS+showsConstr c = showParen (isInfixOp c) $ showString $ idName c++precedence :: QualIdent -> OpPrecEnv -> Precedence+precedence op pEnv = case qualLookupP op pEnv of+  [] -> defaultPrecedence+  PrecInfo _ (OpPrec _ p) : _ -> p++instType :: Type -> Type+instType (TypeConstructor tc) = TypeConstructor tc+instType (TypeVariable    tv) = TypeVariable (-1 - tv)+instType (TypeApply  ty1 ty2) = TypeApply (instType ty1) (instType ty2)+instType (TypeArrow  ty1 ty2) = TypeArrow (instType ty1) (instType ty2)+instType ty = ty++-- Returns the type for a given instance's method of a given class. To this+-- end, the class method's type is stripped of its first predicate (which is+-- the implicit class constraint) and the class variable is replaced with the+-- instance's type. The remaining predicate set is then united with the+-- instance's predicate set.++getInstMethodType :: PredSet -> QualIdent -> Type -> Ident -> DVM PredType+getInstMethodType ps cls ty f = do+  vEnv <- getValueEnv+  return $ instMethodType vEnv ps cls ty f++instMethodType :: ValueEnv -> PredSet -> QualIdent -> Type -> Ident -> PredType+instMethodType vEnv ps cls ty f = PredType (ps `Set.union` ps'') ty''+  where PredType ps' ty' = case qualLookupValue (qualifyLike cls f) vEnv of+          [Value _ _ _ (ForAll _ pty)] -> pty+          _ -> internalError "Derive.instMethodType"+        PredType ps'' ty'' = instanceType ty $ PredType (Set.deleteMin ps') ty'++-- -----------------------------------------------------------------------------+-- Prelude entities+-- -----------------------------------------------------------------------------++prelTrue :: Expression PredType+prelTrue = Constructor NoSpanInfo predBoolType qTrueId++prelFalse :: Expression PredType+prelFalse = Constructor NoSpanInfo predBoolType qFalseId++prelAppend :: Expression PredType -> Expression PredType -> Expression PredType+prelAppend e1 e2 = foldl1 (Apply NoSpanInfo)+  [Variable NoSpanInfo pty qAppendOpId, e1, e2]+  where pty = predType $ foldr1 TypeArrow $ replicate 3 $ typeOf e1++prelDot :: Expression PredType -> Expression PredType -> Expression PredType+prelDot e1 e2 = foldl1 (Apply NoSpanInfo)+  [Variable NoSpanInfo pty qDotOpId, e1, e2]+  where ty1@(TypeArrow _    ty12) = typeOf e1+        ty2@(TypeArrow ty21 _   ) = typeOf e2+        pty = predType $ foldr1 TypeArrow [ty1, ty2, ty21, ty12]++prelAnd :: Expression PredType -> Expression PredType -> Expression PredType+prelAnd e1 e2 = foldl1 (Apply NoSpanInfo)+  [Variable NoSpanInfo pty qAndOpId, e1, e2]+  where pty = predType $ foldr1 TypeArrow $ replicate 3 boolType++prelEq :: Expression PredType -> Expression PredType -> Expression PredType+prelEq e1 e2 = foldl1 (Apply NoSpanInfo)+  [Variable NoSpanInfo pty qEqOpId, e1, e2]+  where ty = typeOf e1+        pty = predType $ foldr1 TypeArrow [ty, ty, boolType]++prelDataEq :: Expression PredType -> Expression PredType -> Expression PredType+prelDataEq e1 e2 = foldl1 (Apply NoSpanInfo)+  [Variable NoSpanInfo pty qDataEqId, e1, e2]+  where ty = typeOf e1+        pty = predType $ foldr1 TypeArrow [ty, ty, boolType]++prelLeq :: Expression PredType -> Expression PredType -> Expression PredType+prelLeq e1 e2 = foldl1 (Apply NoSpanInfo)+  [Variable NoSpanInfo pty qLeqOpId, e1, e2]+  where ty = typeOf e1+        pty = predType $ foldr1 TypeArrow [ty, ty, boolType]++prelLt :: Expression PredType -> Expression PredType -> Expression PredType+prelLt e1 e2 = foldl1 (Apply NoSpanInfo)+  [Variable NoSpanInfo pty qLtOpId, e1, e2]+  where ty = typeOf e1+        pty = predType $ foldr1 TypeArrow [ty, ty, boolType]++prelOr :: Expression PredType -> Expression PredType -> Expression PredType+prelOr e1 e2 = foldl1 (Apply NoSpanInfo)+  [Variable NoSpanInfo pty qOrOpId, e1, e2]+  where pty = predType $ foldr1 TypeArrow $ replicate 3 boolType++prelFromEnum :: Expression PredType -> Expression PredType+prelFromEnum e = Apply NoSpanInfo (Variable NoSpanInfo pty qFromEnumId) e+  where pty = predType $ TypeArrow (typeOf e) intType++prelEnumFromTo :: Expression PredType -> Expression PredType+               -> Expression PredType+prelEnumFromTo e1 e2 = apply (Variable NoSpanInfo pty qEnumFromToId) [e1, e2]+  where ty = typeOf e1+        pty = predType $ foldr1 TypeArrow [ty, ty, listType ty]++prelEnumFromThenTo :: Expression PredType -> Expression PredType+                   -> Expression PredType -> Expression PredType+prelEnumFromThenTo e1 e2 e3 =+  apply (Variable NoSpanInfo pty qEnumFromThenToId) [e1, e2, e3]+  where ty = typeOf e1+        pty = predType $ foldr1 TypeArrow [ty, ty, ty, listType ty]++prelReadParen :: Expression PredType -> Expression PredType+              -> Expression PredType+prelReadParen e1 e2 = apply (Variable NoSpanInfo pty qReadParenId) [e1, e2]+  where ty = typeOf e2+        pty = predType $ foldr1 TypeArrow [boolType, ty, ty]++prelShowParen :: Expression PredType -> Expression PredType+              -> Expression PredType+prelShowParen e1 e2 = apply (Variable NoSpanInfo pty qShowParenId) [e1, e2]+  where pty = predType $ foldr1 TypeArrow [ boolType+                                          , TypeArrow stringType stringType+                                          , stringType, stringType+                                          ]++preludeLex :: Expression PredType -> Expression PredType+preludeLex = Apply NoSpanInfo (Variable NoSpanInfo pty qLexId)+  where pty = predType $ TypeArrow stringType $+                listType $ tupleType [stringType, stringType]++preludeReadsPrec :: Type -> Integer -> Expression PredType+                 -> Expression PredType+preludeReadsPrec ty p e = flip (Apply NoSpanInfo) e $+  Apply NoSpanInfo (Variable NoSpanInfo pty qReadsPrecId) $+  Literal NoSpanInfo predIntType $ Int p+  where pty = predType $ foldr1 TypeArrow [ intType, stringType+                                          , listType $ tupleType [ ty+                                                                 , stringType+                                                                 ]+                                          ]++preludeShowsPrec :: Integer -> Expression PredType -> Expression PredType+preludeShowsPrec p e = flip (Apply NoSpanInfo) e $+  Apply NoSpanInfo (Variable NoSpanInfo pty qShowsPrecId) $+  Literal NoSpanInfo predIntType $ Int p+  where pty = predType $ foldr1 TypeArrow [ intType, typeOf e+                                          , stringType, stringType+                                          ]++preludeShowString :: String -> Expression PredType+preludeShowString s = Apply NoSpanInfo (Variable NoSpanInfo pty qShowStringId) $+  Literal NoSpanInfo predStringType $ String s+  where pty = predType $ foldr1 TypeArrow $ replicate 3 stringType++preludeFailed :: Type -> Expression PredType+preludeFailed ty = Variable NoSpanInfo (predType ty) qFailedId
+ src/Transformations/Desugar.hs view
@@ -0,0 +1,1168 @@+{- |+  Module      :  $Header$+  Description :  Desugaring Curry Expressions+  Copyright   :  (c) 2001 - 2004 Wolfgang Lux+                                 Martin Engelke+                     2011 - 2015 Björn Peemöller+                     2015        Jan Tikovsky+                     2016 - 2017 Finn Teegen+  License     :  BSD-3-clause++  Maintainer  :  bjp@informatik.uni-kiel.de+  Stability   :  experimental+  Portability :  portable++  The desugaring pass removes all syntactic sugar from the module.+  In particular, the output of the desugarer will have the following+  properties.++  * No guarded right hand sides occur in equations, pattern declarations,+    and case alternatives. In addition, the declaration lists (`where`-blocks)+    of the right hand sides are empty; local declarations are transformed+    into let expressions.++  * Patterns in equations and case alternatives are composed only of+    - literals,+    - variables,+    - constructor applications, and+    - as patterns applied to literals or constructor applications.++  * Expressions are composed only of+    - literals,+    - variables,+    - constructors,+    - (binary) applications,+    - case expressions,+    - let expressions, and+    - expressions with a type signature.++  * Functional patterns are replaced by variables and are integrated+    in a guarded right hand side using the (=:<=) operator.++  * Records are transformed into ordinary data types by removing the fields.+    Record construction and pattern matching are represented using solely the+    record constructor. Record selections are represented using selector+    functions which are generated for each record declaration, and record+    updated are represented using case-expressions that perform the update.++  * The type environment will be extended by new function declarations for:+    - Record selections, and+    - Converted lambda expressions.++  As we are going to insert references to real prelude entities,+  all names must be properly qualified before calling this module.+-}+{-# LANGUAGE CPP #-}+module Transformations.Desugar (desugar) where++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative        ((<$>), (<*>))+#endif+import           Control.Arrow              (first, second)+import           Control.Monad              (liftM2)+import           Control.Monad.Extra        (concatMapM)+import qualified Control.Monad.State as S   (State, runState, gets, modify)+import           Data.Foldable              (foldrM)+import           Data.List                  ( (\\), elemIndex, nub, partition+                                            , tails )+import           Data.Maybe                 (fromMaybe)+import qualified Data.Set            as Set (Set, empty, member, insert)++import Curry.Base.Ident+import Curry.Base.SpanInfo+import Curry.Syntax++import Base.Expr+import Base.CurryTypes+import Base.Messages (internalError)+import Base.TypeExpansion+import Base.Types+import Base.TypeSubst+import Base.Typing+import Base.Utils (fst3, mapAccumM)++import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTypeInfo)+import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)++-- TODO: some types keep their spanInfo, some don't. Probably none of them are needed++-- The desugaring phase keeps only the type, function, and value+-- declarations of the module, i.e., type signatures are discarded.+-- While record declarations are transformed into ordinary data/newtype+-- declarations, the remaining type declarations are not desugared.+-- Since they cannot occur in local declaration groups, they are filtered+-- out separately. Actually, the transformation is slightly more general than+-- necessary as it allows value declarations at the top-level of a module.++desugar :: [KnownExtension] -> ValueEnv -> TCEnv -> Module PredType+        -> (Module PredType, ValueEnv)+desugar xs vEnv tcEnv (Module spi li ps m es is ds)+  = (Module spi li ps m es is ds', valueEnv s')+  where (ds', s') = S.runState (desugarModuleDecls ds)+                               (DesugarState m xs tcEnv vEnv 1)++-- ---------------------------------------------------------------------------+-- Desugaring monad and accessor functions+-- ---------------------------------------------------------------------------++-- New identifiers may be introduced while desugaring pattern declarations,+-- case and lambda-expressions, list comprehensions, and record selections+-- and updates. As usual, we use a state monad transformer for generating+-- unique names. In addition, the state is also used for passing through the+-- type environment, which must be augmented with the types of these new+-- variables.++data DesugarState = DesugarState+  { moduleIdent :: ModuleIdent      -- read-only+  , extensions  :: [KnownExtension] -- read-only+  , tyConsEnv   :: TCEnv            -- read-only+  , valueEnv    :: ValueEnv         -- will be extended+  , nextId      :: Integer          -- counter+  }++type DsM a = S.State DesugarState a++getModuleIdent :: DsM ModuleIdent+getModuleIdent = S.gets moduleIdent++checkNegativeLitsExtension :: DsM Bool+checkNegativeLitsExtension = S.gets (\s -> NegativeLiterals `elem` extensions s)++getTyConsEnv :: DsM TCEnv+getTyConsEnv = S.gets tyConsEnv++getValueEnv :: DsM ValueEnv+getValueEnv = S.gets valueEnv++getNextId :: DsM Integer+getNextId = do+  nid <- S.gets nextId+  S.modify $ \s -> s { nextId = succ nid }+  return nid++-- ---------------------------------------------------------------------------+-- Generation of fresh names+-- ---------------------------------------------------------------------------++-- Create a fresh variable ident for a given prefix with a monomorphic type+freshVar :: Typeable t => String -> t -> DsM (PredType, Ident)+freshVar prefix t = do+  v <- (mkIdent . (prefix ++) . show) <$> getNextId+  return (predType $ typeOf t, v)++-- ---------------------------------------------------------------------------+-- Desugaring+-- ---------------------------------------------------------------------------++desugarModuleDecls :: [Decl PredType] -> DsM [Decl PredType]+desugarModuleDecls ds = do+  ds'    <- concatMapM dsRecordDecl ds+  ds''   <- concatMapM dsTypeDecl ds'+  ds'''  <- mapM dsClassAndInstanceDecl ds''+  ds'''' <- dsDeclGroup ds'''+  return $ filter (not . liftM2 (||) isValueDecl isTypeSig) ds''' ++ ds''''++-- -----------------------------------------------------------------------------+-- Desugaring of type declarations+-- -----------------------------------------------------------------------------++dsTypeDecl :: Decl PredType -> DsM [Decl PredType]+dsTypeDecl (DataDecl si tc tvs cs clss) = do+  cs' <- mapM dsConstrDecl cs+  return $ [DataDecl si tc tvs cs' clss]+dsTypeDecl (NewtypeDecl si tc tvs nc clss) = do+  nc' <- dsNewConstrDecl nc+  return $ [NewtypeDecl si tc tvs nc' clss]+dsTypeDecl (TypeDecl _ _ _ _) = return []+dsTypeDecl d = return [d]++dsConstrDecl :: ConstrDecl -> DsM ConstrDecl+dsConstrDecl (ConstrDecl si c tys) = ConstrDecl si c <$> mapM dsTypeExpr tys+dsConstrDecl (ConOpDecl si ty1 op ty2) =+  ConstrDecl si op <$> mapM dsTypeExpr [ty1, ty2]+dsConstrDecl cd = internalError $ "Desugar.dsConstrDecl: " ++ show cd++dsNewConstrDecl :: NewConstrDecl -> DsM NewConstrDecl+dsNewConstrDecl (NewConstrDecl si c ty) = NewConstrDecl si c <$> dsTypeExpr ty+dsNewConstrDecl nc = internalError $ "Desugar.dsNewConstrDecl: " ++ show nc++-- -----------------------------------------------------------------------------+-- Desugaring of class and instance declarations+-- -----------------------------------------------------------------------------++dsClassAndInstanceDecl :: Decl PredType -> DsM (Decl PredType)+dsClassAndInstanceDecl (ClassDecl p li cx cls tv ds) = do+  tds' <- mapM dsTypeSig tds+  vds' <- dsDeclGroup vds+  return $ ClassDecl p li cx cls tv $ tds' ++ vds'+  where (tds, vds) = partition isTypeSig ds+dsClassAndInstanceDecl (InstanceDecl p li cx cls ty ds) =+  InstanceDecl p li cx cls ty <$> dsDeclGroup ds+dsClassAndInstanceDecl d = return d++dsTypeSig :: Decl PredType -> DsM (Decl PredType)+dsTypeSig (TypeSig s fs qty) = TypeSig s fs <$> dsQualTypeExpr qty+dsTypeSig d                  = internalError $ "Desugar.dsTypeSig: " ++ show d++-- -----------------------------------------------------------------------------+-- Desugaring of type declarations: records+-- -----------------------------------------------------------------------------++-- As an extension to the Curry language, the compiler supports Haskell's+-- record syntax, which introduces field labels for data and renaming types.+-- Field labels can be used in constructor declarations, patterns,+-- and expressions. For further convenience, an implicit selector+-- function is introduced for each field label.++-- Generate selector functions for record labels and replace record+-- constructor declarations by ordinary constructor declarations.+dsRecordDecl :: Decl PredType -> DsM [Decl PredType]+dsRecordDecl (DataDecl p tc tvs cs clss) = do+  m <- getModuleIdent+  let qcs = map (qualifyWith m . constrId) cs+  selFuns <- mapM (genSelFun p qcs) (nub $ concatMap recordLabels cs)+  return $ DataDecl p tc tvs (map unlabelConstr cs) clss : selFuns+dsRecordDecl (NewtypeDecl p tc tvs nc clss) = do+  m <- getModuleIdent+  let qc = qualifyWith m (nconstrId nc)+  selFun <- mapM (genSelFun p [qc]) (nrecordLabels nc)+  return $ NewtypeDecl p tc tvs (unlabelNewConstr nc) clss : selFun+dsRecordDecl d = return [d]++-- Generate a selector function for a single record label+genSelFun :: SpanInfo -> [QualIdent] -> Ident -> DsM (Decl PredType)+genSelFun p qcs l = do+  m <- getModuleIdent+  vEnv <- getValueEnv+  let ForAll _ pty = varType (qualifyWith m l) vEnv+  FunctionDecl p pty l <$> concatMapM (genSelEqn p l) qcs++-- Generate a selector equation for a label and a constructor if the label+-- is applicable, otherwise the empty list is returned.+genSelEqn :: SpanInfo -> Ident -> QualIdent -> DsM [Equation PredType]+genSelEqn p l qc = do+  vEnv <- getValueEnv+  let (ls, ty) = conType qc vEnv+      (tys, ty0) = arrowUnapply (instType ty)+  case elemIndex l ls of+    Just n  -> do+      vs <- mapM (freshVar "_#rec") tys+      let pat = constrPattern (predType ty0) qc vs+      return [mkEquation p l [pat] (uncurry mkVar (vs !! n))]+    Nothing -> return []++-- Remove any labels from a data constructor declaration+unlabelConstr :: ConstrDecl -> ConstrDecl+unlabelConstr (RecordDecl p c fs) = ConstrDecl p c tys+  where tys = [ty | FieldDecl _ ls ty <- fs, _ <- ls]+unlabelConstr c                   = c++-- Remove any labels from a newtype constructor declaration+unlabelNewConstr :: NewConstrDecl -> NewConstrDecl+unlabelNewConstr (NewRecordDecl p nc (_, ty)) = NewConstrDecl p nc ty+unlabelNewConstr c                            = c++-- -----------------------------------------------------------------------------+-- Desugaring of value declarations+-- -----------------------------------------------------------------------------++-- Within a declaration group, all type signatures are discarded. First,+-- the patterns occurring in the left hand sides of pattern declarations+-- and external declarations are desugared. Due to lazy patterns, the former+-- may add further declarations to the group that must be desugared as well.+dsDeclGroup :: [Decl PredType] -> DsM [Decl PredType]+dsDeclGroup ds = concatMapM dsDeclLhs (filter isValueDecl ds) >>= mapM dsDeclRhs++dsDeclLhs :: Decl PredType -> DsM [Decl PredType]+dsDeclLhs (PatternDecl p t rhs) = do+  (ds', t') <- dsPat p [] t+  dss'      <- mapM dsDeclLhs ds'+  return $ PatternDecl p t' rhs : concat dss'+dsDeclLhs d                     = return [d]++-- TODO: Check if obsolete and remove+-- After desugaring its right hand side, each equation is eta-expanded+-- by adding as many variables as necessary to the argument list and+-- applying the right hand side to those variables (Note: eta-expansion+-- is disabled in the version for PAKCS).+-- Furthermore every occurrence of a record type within the type of a function+-- is simplified to the corresponding type constructor from the record+-- declaration. This is possible because currently records must not be empty+-- and a record label belongs to only one record declaration.++-- Desugaring of the right-hand-side of declarations+dsDeclRhs :: Decl PredType -> DsM (Decl PredType)+dsDeclRhs (FunctionDecl p pty f eqs) =+  FunctionDecl p pty f <$> mapM dsEquation eqs+dsDeclRhs (PatternDecl      p t rhs) = PatternDecl p t <$> dsRhs id rhs+dsDeclRhs d@(FreeDecl           _ _) = return d+dsDeclRhs d@(ExternalDecl       _ _) = return d+dsDeclRhs _                          =+  error "Desugar.dsDeclRhs: no pattern match"++-- Desugaring of an equation+dsEquation :: Equation PredType -> DsM (Equation PredType)+dsEquation (Equation p lhs rhs) = do+  (     cs1, ts1) <- dsNonLinearity         ts+  (ds1, cs2, ts2) <- dsFunctionalPatterns p ts1+  (ds2,      ts3) <- mapAccumM (dsPat p) [] ts2+  rhs'            <- dsRhs (constrain cs2 . constrain cs1)+                           (addDecls (ds1 ++ ds2) rhs)+  return $ Equation p (FunLhs NoSpanInfo f ts3) rhs'+  where (f, ts) = flatLhs lhs++-- Constrain an expression by a list of constraints.+-- @constrain []  e  ==  e@+-- @constrain c_n e  ==  (c_1 & ... & c_n) &> e@+constrain :: [Expression PredType] -> Expression PredType -> Expression PredType+constrain cs e = if null cs then e else foldr1 (&) cs &> e++-- -----------------------------------------------------------------------------+-- Desugaring of right-hand sides+-- -----------------------------------------------------------------------------++-- A list of boolean guards is expanded into a nested if-then-else+-- expression, whereas a constraint guard is replaced by a case+-- expression. Note that if the guard type is 'Success' only a+-- single guard is allowed for each equation (This change was+-- introduced in version 0.8 of the Curry report.). We check for the+-- type 'Bool' of the guard because the guard's type defaults to+-- 'Success' if it is not restricted by the guard expression.++dsRhs :: (Expression PredType -> Expression PredType)+      -> Rhs PredType -> DsM (Rhs PredType)+dsRhs f rhs =   expandRhs (prelFailed (typeOf rhs)) f rhs+            >>= dsExpr (getSpanInfo rhs)+            >>= return . simpleRhs (getSpanInfo rhs)++expandRhs :: Expression PredType -> (Expression PredType -> Expression PredType)+          -> Rhs PredType -> DsM (Expression PredType)+expandRhs _  f (SimpleRhs _ _ e ds) = return $ mkLet ds (f e)+expandRhs e0 f (GuardedRhs _ _ es ds) = mkLet ds . f+                                     <$> expandGuards e0 es++expandGuards :: Expression PredType -> [CondExpr PredType]+             -> DsM (Expression PredType)+expandGuards e0 es =+  return $ if boolGuards es then foldr mkIfThenElse e0 es else mkCond es+  where+  mkIfThenElse (CondExpr _ g e) = IfThenElse NoSpanInfo g e+  mkCond [CondExpr _ g e] = g &> e+  mkCond _                = error "Desugar.expandGuards.mkCond: non-unary list"++boolGuards :: [CondExpr PredType] -> Bool+boolGuards []                    = False+boolGuards (CondExpr _ g _ : es) = not (null es) || typeOf g == boolType++-- Add additional declarations to a right-hand side+addDecls :: [Decl PredType] -> Rhs PredType -> Rhs PredType+addDecls ds (SimpleRhs p li e ds') = SimpleRhs p li e (ds ++ ds')+addDecls ds (GuardedRhs spi li es ds') = GuardedRhs spi li es (ds ++ ds')++-- -----------------------------------------------------------------------------+-- Desugaring of non-linear patterns+-- -----------------------------------------------------------------------------++-- The desugaring traverses a pattern in depth-first order and collects+-- all variables. If it encounters a variable which has been previously+-- introduced, the second occurrence is changed to a fresh variable+-- and a new pair (newvar, oldvar) is saved to generate constraints later.+-- Non-linear patterns inside single functional patterns are not desugared,+-- as this special case is handled later.+dsNonLinearity :: [Pattern PredType]+               -> DsM ([Expression PredType], [Pattern PredType])+dsNonLinearity ts = do+  ((_, cs), ts') <- mapAccumM dsNonLinear (Set.empty, []) ts+  return (reverse cs, ts')++type NonLinearEnv = (Set.Set Ident, [Expression PredType])++dsNonLinear :: NonLinearEnv -> Pattern PredType+            -> DsM (NonLinearEnv, Pattern PredType)+dsNonLinear env l@(LiteralPattern        _ _ _) = return (env, l)+dsNonLinear env n@(NegativePattern       _ _ _) = return (env, n)+dsNonLinear env t@(VariablePattern       _ _ v)+  | isAnonId v         = return (env, t)+  | v `Set.member` vis = do+    v' <- freshVar "_#nonlinear" t+    return ((vis, mkStrictEquality v v' : eqs),+             uncurry (VariablePattern NoSpanInfo) v')+  | otherwise          = return ((Set.insert v vis, eqs), t)+  where (vis, eqs) = env+dsNonLinear env (ConstructorPattern _ pty c ts)+  = second (ConstructorPattern NoSpanInfo pty c) <$> mapAccumM dsNonLinear env ts+dsNonLinear env (InfixPattern   _ pty t1 op t2) = do+  (env1, t1') <- dsNonLinear env  t1+  (env2, t2') <- dsNonLinear env1 t2+  return (env2, InfixPattern NoSpanInfo pty t1' op t2')+dsNonLinear env (ParenPattern              _ t) =+  second (ParenPattern NoSpanInfo) <$> dsNonLinear env t+dsNonLinear env (RecordPattern      _ pty c fs) =+  second (RecordPattern NoSpanInfo pty c)+  <$> mapAccumM (dsField dsNonLinear) env fs+dsNonLinear env (TuplePattern             _ ts) =+  second (TuplePattern NoSpanInfo) <$> mapAccumM dsNonLinear env ts+dsNonLinear env (ListPattern          _ pty ts) =+  second (ListPattern NoSpanInfo pty) <$> mapAccumM dsNonLinear env ts+dsNonLinear env (AsPattern               _ v t) = do+  let pty = predType $ typeOf t+  (env1, pat) <- dsNonLinear env (VariablePattern NoSpanInfo pty v)+  let VariablePattern _ _ v' = pat+  (env2, t') <- dsNonLinear env1 t+  return (env2, AsPattern NoSpanInfo v' t')+dsNonLinear env (LazyPattern               _ t) =+  second (LazyPattern NoSpanInfo) <$> dsNonLinear env t+dsNonLinear env fp@(FunctionPattern    _ _ _ _) = dsNonLinearFuncPat env fp+dsNonLinear env fp@(InfixFuncPattern _ _ _ _ _) = dsNonLinearFuncPat env fp++dsNonLinearFuncPat :: NonLinearEnv -> Pattern PredType+                   -> DsM (NonLinearEnv, Pattern PredType)+dsNonLinearFuncPat (vis, eqs) fp = do+  let fpVars = map (\(v, _, pty) -> (pty, v)) $ patternVars fp+      vs     = filter ((`Set.member` vis) . snd) fpVars+  vs' <- mapM (freshVar "_#nonlinear" . uncurry (VariablePattern NoSpanInfo)) vs+  let vis' = foldr (Set.insert . snd) vis fpVars+      fp'  = substPat (zip (map snd vs) (map snd vs')) fp+  return ((vis', zipWith mkStrictEquality (map snd vs) vs' ++ eqs), fp')++mkStrictEquality :: Ident -> (PredType, Ident) -> Expression PredType+mkStrictEquality x (pty, y) = mkVar pty x =:= mkVar pty y++substPat :: [(Ident, Ident)] -> Pattern a -> Pattern a+substPat _ l@(LiteralPattern        _ _ _) = l+substPat _ n@(NegativePattern       _ _ _) = n+substPat s (VariablePattern         _ a v) =+  VariablePattern NoSpanInfo a $ fromMaybe v (lookup v s)++substPat s (ConstructorPattern   _ a c ps) =+  ConstructorPattern NoSpanInfo a c $ map (substPat s) ps+substPat s (InfixPattern     _ a p1 op p2) =+  InfixPattern NoSpanInfo a (substPat s p1) op (substPat s p2)+substPat s (ParenPattern              _ p) =+  ParenPattern NoSpanInfo (substPat s p)+substPat s (RecordPattern        _ a c fs) =+  RecordPattern NoSpanInfo a c (map substField fs)+  where substField (Field pos l pat) = Field pos l (substPat s pat)+substPat s (TuplePattern             _ ps) =+  TuplePattern NoSpanInfo $ map (substPat s) ps+substPat s (ListPattern            _ a ps) =+  ListPattern NoSpanInfo a $ map (substPat s) ps+substPat s (AsPattern               _ v p) =+  AsPattern NoSpanInfo (fromMaybe v (lookup v s)) (substPat s p)+substPat s (LazyPattern               _ p) =+  LazyPattern NoSpanInfo (substPat s p)+substPat s (FunctionPattern      _ a f ps) =+  FunctionPattern NoSpanInfo a f $ map (substPat s) ps+substPat s (InfixFuncPattern _ a p1 op p2) =+  InfixFuncPattern NoSpanInfo a (substPat s p1) op (substPat s p2)++-- -----------------------------------------------------------------------------+-- Desugaring of functional patterns+-- -----------------------------------------------------------------------------++-- Desugaring of functional patterns works in the following way:+--  1. The patterns are recursively traversed from left to right+--     to extract every functional pattern (note that functional patterns+--     can not be nested).+--     Each pattern is replaced by a fresh variable and a pair+--     (variable, functional pattern) is generated.+--  2. The variable-pattern pairs of the form @(v, p)@ are collected and+--     transformed into additional constraints of the form @p =:<= v@,+--     where the pattern @p@ is converted to the corresponding expression.+--     In addition, any variable occurring in @p@ is declared as a fresh+--     free variable.+--     Multiple constraints will later be combined using the @&>@-operator+--     such that the patterns are evaluated from left to right.++dsFunctionalPatterns+  :: SpanInfo -> [Pattern PredType]+  -> DsM ([Decl PredType], [Expression PredType], [Pattern PredType])+dsFunctionalPatterns p ts = do+  -- extract functional patterns+  (bs, ts') <- mapAccumM elimFP [] ts+  -- generate declarations of free variables and constraints+  let (ds, cs) = genFPExpr p (concatMap patternVars ts') (reverse bs)+  -- return (declarations, constraints, desugared patterns)+  return (ds, cs, ts')++type LazyBinding = (Pattern PredType, (PredType, Ident))++elimFP :: [LazyBinding] -> Pattern PredType+       -> DsM ([LazyBinding], Pattern PredType)+elimFP bs p@(LiteralPattern        _ _ _) = return (bs, p)+elimFP bs p@(NegativePattern       _ _ _) = return (bs, p)+elimFP bs p@(VariablePattern       _ _ _) = return (bs, p)+elimFP bs (ConstructorPattern _ pty c ts) =+  second (ConstructorPattern NoSpanInfo  pty c) <$> mapAccumM elimFP bs ts+elimFP bs (InfixPattern   _ pty t1 op t2) = do+  (bs1, t1') <- elimFP bs  t1+  (bs2, t2') <- elimFP bs1 t2+  return (bs2, InfixPattern NoSpanInfo pty t1' op t2')+elimFP bs (ParenPattern              _ t) =+  second (ParenPattern NoSpanInfo) <$> elimFP bs t+elimFP bs (RecordPattern      _ pty c fs) =+  second (RecordPattern NoSpanInfo pty c) <$> mapAccumM (dsField elimFP) bs fs+elimFP bs (TuplePattern             _ ts) =+  second (TuplePattern NoSpanInfo) <$> mapAccumM elimFP bs ts+elimFP bs (ListPattern          _ pty ts) =+  second (ListPattern NoSpanInfo pty) <$> mapAccumM elimFP bs ts+elimFP bs (AsPattern               _ v t) =+  second (AsPattern NoSpanInfo v) <$> elimFP bs t+elimFP bs (LazyPattern               _ t) =+  second (LazyPattern NoSpanInfo) <$> elimFP bs t+elimFP bs p@(FunctionPattern    _  _ _ _) = do+ (pty, v) <- freshVar "_#funpatt" p+ return ((p, (pty, v)) : bs, VariablePattern NoSpanInfo pty v)+elimFP bs p@(InfixFuncPattern  _ _ _ _ _) = do+ (pty, v) <- freshVar "_#funpatt" p+ return ((p, (pty, v)) : bs, VariablePattern NoSpanInfo pty v)++genFPExpr :: SpanInfo -> [(Ident, Int, PredType)] -> [LazyBinding]+          -> ([Decl PredType], [Expression PredType])+genFPExpr p vs bs+  | null bs   = ([]               , [])+  | null free = ([]               , cs)+  | otherwise = ([FreeDecl p (map (\(v, _, pty) -> Var pty v) free)], cs)+  where+  mkLB (t, (pty, v)) = let (t', es) = fp2Expr t+                       in  (t' =:<= mkVar pty v) : es+  cs   = concatMap mkLB bs+  free = nub $ filter (not . isAnonId . fst3) $+                 concatMap patternVars (map fst bs) \\ vs++fp2Expr :: Pattern PredType -> (Expression PredType, [Expression PredType])+fp2Expr (LiteralPattern          _ pty l) = (Literal NoSpanInfo  pty l, [])+fp2Expr (NegativePattern         _ pty l) =+  (Literal NoSpanInfo pty (negateLiteral l), [])+fp2Expr (VariablePattern         _ pty v) = (mkVar pty v, [])+fp2Expr (ConstructorPattern  _  pty c ts) =+  let (ts', ess) = unzip $ map fp2Expr ts+      pty' = predType $ foldr TypeArrow (unpredType pty) $ map typeOf ts+  in  (apply (Constructor NoSpanInfo pty' c) ts', concat ess)+fp2Expr (InfixPattern   _ pty t1 op t2) =+  let (t1', es1) = fp2Expr t1+      (t2', es2) = fp2Expr t2+      pty' = predType $ foldr TypeArrow (unpredType pty) [typeOf t1, typeOf t2]+  in  (InfixApply NoSpanInfo t1' (InfixConstr pty' op) t2', es1 ++ es2)+fp2Expr (ParenPattern                _ t) = first (Paren NoSpanInfo) (fp2Expr t)+fp2Expr (TuplePattern               _ ts) =+  let (ts', ess) = unzip $ map fp2Expr ts+  in  (Tuple NoSpanInfo ts', concat ess)+fp2Expr (ListPattern            _ pty ts) =+  let (ts', ess) = unzip $ map fp2Expr ts+  in  (List NoSpanInfo pty ts', concat ess)+fp2Expr (FunctionPattern      _ pty f ts) =+  let (ts', ess) = unzip $ map fp2Expr ts+      pty' = predType $ foldr TypeArrow (unpredType pty) $ map typeOf ts+  in  (apply (Variable NoSpanInfo pty' f) ts', concat ess)+fp2Expr (InfixFuncPattern _ pty t1 op t2) =+  let (t1', es1) = fp2Expr t1+      (t2', es2) = fp2Expr t2+      pty' = predType $ foldr TypeArrow (unpredType pty) $ map typeOf [t1, t2]+  in  (InfixApply NoSpanInfo t1' (InfixOp pty' op) t2', es1 ++ es2)+fp2Expr (AsPattern                 _ v t) =+  let (t', es) = fp2Expr t+      pty = predType $ typeOf t+  in  (mkVar pty v, (t' =:<= mkVar pty v) : es)+fp2Expr (RecordPattern        _ pty c fs) =+  let (fs', ess) = unzip [ (Field p f e, es) | Field p f t <- fs+                                             , let (e, es) = fp2Expr t]+  in  (Record NoSpanInfo pty c fs', concat ess)+fp2Expr t                               = internalError $+  "Desugar.fp2Expr: Unexpected constructor term: " ++ show t++-- -----------------------------------------------------------------------------+-- Desugaring of ordinary patterns+-- -----------------------------------------------------------------------------++-- The transformation of patterns is straight forward except for lazy+-- patterns. A lazy pattern '~t' is replaced by a fresh+-- variable 'v' and a new local declaration 't = v' in the+-- scope of the pattern. In addition, as-patterns 'v@t' where+-- 't' is a variable or an as-pattern are replaced by 't' in combination+-- with a local declaration for 'v'.++-- Record patterns are transformed into normal constructor patterns by+-- rearranging fields in the order of the record's declaration, adding+-- fresh variables in place of omitted fields, and discarding the field+-- labels.++-- Note: By rearranging fields here we loose the ability to comply+-- strictly with the Haskell 98 pattern matching semantics, which matches+-- fields of a record pattern in the order of their occurrence in the+-- pattern. However, keep in mind that Haskell matches alternatives from+-- top to bottom and arguments within an equation or alternative from+-- left to right, which is not the case in Curry except for rigid case+-- expressions.++dsLiteralPat :: PredType -> Literal+             -> Either (Pattern PredType) (Pattern PredType)+dsLiteralPat pty c@(Char _) = Right (LiteralPattern NoSpanInfo pty c)+dsLiteralPat pty (Int i) =+  Right (LiteralPattern NoSpanInfo pty (fixLiteral (unpredType pty)))+  where fixLiteral (TypeConstrained tys _) = fixLiteral (head tys)+        fixLiteral ty+          | ty == floatType = Float $ fromInteger i+          | otherwise = Int i+dsLiteralPat pty f@(Float _) = Right (LiteralPattern NoSpanInfo pty f)+dsLiteralPat pty (String cs) =+  Left $ ListPattern NoSpanInfo pty $+  map (LiteralPattern NoSpanInfo pty' . Char) cs+  where pty' = predType $ elemType $ unpredType pty++dsPat :: SpanInfo -> [Decl PredType] -> Pattern PredType+      -> DsM ([Decl PredType], Pattern PredType)+dsPat _ ds v@(VariablePattern       _ _ _) = return (ds, v)+dsPat p ds (LiteralPattern      _ pty l) =+  either (dsPat p ds) (return . (,) ds) (dsLiteralPat pty l)+dsPat p ds (NegativePattern       _ pty l) =+  dsPat p ds (LiteralPattern NoSpanInfo pty (negateLiteral l))+dsPat p ds (ConstructorPattern _ pty c ts) =+  second (ConstructorPattern NoSpanInfo pty c) <$> mapAccumM (dsPat p) ds ts+dsPat p ds (InfixPattern   _ pty t1 op t2) =+  dsPat p ds (ConstructorPattern NoSpanInfo pty op [t1, t2])+dsPat p ds (ParenPattern              _ t) = dsPat p ds t+dsPat p ds (RecordPattern      _ pty c fs) = do+  vEnv <- getValueEnv+  --TODO: Rework+  let (ls, tys) = argumentTypes (unpredType pty) c vEnv+      tsMap = map field2Tuple fs+  anonTs <- mapM ((uncurry (VariablePattern NoSpanInfo) <$>) .+                  freshVar "_#recpat") tys+  let maybeTs = map (flip lookup tsMap) ls+      ts = zipWith fromMaybe anonTs maybeTs+  dsPat p ds (ConstructorPattern NoSpanInfo pty c ts)+dsPat p ds (TuplePattern              _ ts) =+  dsPat p ds (ConstructorPattern NoSpanInfo pty (qTupleId $ length ts) ts)+  where pty = predType (tupleType (map typeOf ts))+dsPat p ds (ListPattern           _ pty ts) =+  second (dsList cons nil) <$> mapAccumM (dsPat p) ds ts+  where nil = ConstructorPattern NoSpanInfo pty qNilId []+        cons t ts' = ConstructorPattern NoSpanInfo pty qConsId [t, ts']+dsPat p ds (AsPattern            _ v t) = dsAs p v <$> dsPat p ds t+dsPat p ds (LazyPattern            _ t) = dsLazy p ds t+dsPat p ds (FunctionPattern   _   pty f ts) =+  second (FunctionPattern NoSpanInfo pty f) <$> mapAccumM (dsPat p) ds ts+dsPat p ds (InfixFuncPattern _ pty t1 f t2) =+  dsPat p ds (FunctionPattern NoSpanInfo pty f [t1, t2])++dsAs :: SpanInfo -> Ident -> ([Decl PredType], Pattern PredType)+     -> ([Decl PredType], Pattern PredType)+dsAs p v (ds, t) = case t of+  VariablePattern _ pty v' -> (varDecl p pty  v (mkVar pty  v') : ds,t)+  AsPattern       _  v' t' -> (varDecl p pty' v (mkVar pty' v') : ds,t)+    where pty' = predType $ typeOf t'+  _                      -> (ds, AsPattern NoSpanInfo v t)++dsLazy :: SpanInfo -> [Decl PredType] -> Pattern PredType+       -> DsM ([Decl PredType], Pattern PredType)+dsLazy p ds t = case t of+  VariablePattern _ _ _ -> return (ds, t)+  ParenPattern     _ t' -> dsLazy p ds t'+  AsPattern      _ v t' -> dsAs p v <$> dsLazy p ds t'+  LazyPattern      _ t' -> dsLazy p ds t'+  _                 -> do+    (pty, v') <- freshVar "_#lazy" t+    return (patDecl NoSpanInfo t (mkVar pty v') : ds,+            VariablePattern NoSpanInfo pty v')++{-+-- -----------------------------------------------------------------------------+-- Desugaring of expressions+-- -----------------------------------------------------------------------------++-- Record construction expressions are transformed into normal+-- constructor applications by rearranging fields in the order of the+-- record's declaration, passing `Prelude.unknown` in place of+-- omitted fields, and discarding the field labels. The transformation of+-- record update expressions is a bit more involved as we must match the+-- updated expression with all valid constructors of the expression's+-- type. As stipulated by the Haskell 98 Report, a record update+-- expression @e { l_1 = e_1, ..., l_k = e_k }@ succeeds only if @e@ reduces to+-- a value @C e'_1 ... e'_n@ such that @C@'s declaration contains all+-- field labels @l_1,...,l_k@. In contrast to Haskell, we do not report+-- an error if this is not the case, but call failed instead.+-}+dsExpr :: SpanInfo -> Expression PredType -> DsM (Expression PredType)+dsExpr p (Literal     _ pty l) =+  either (dsExpr p) return (dsLiteral pty l)+dsExpr _ var@(Variable _ pty v)+  | isAnonId (unqualify v)   = return $ prelUnknown $ unpredType pty+  | otherwise                = return var+dsExpr _ c@(Constructor _ _ _) = return c+dsExpr p (Paren           _ e) = dsExpr p e+dsExpr p (Typed       _ e qty) = Typed NoSpanInfo+  <$> dsExpr p e <*> dsQualTypeExpr qty+dsExpr p (Record   _ pty c fs) = do+  vEnv <- getValueEnv+  --TODO: Rework+  let (ls, tys) = argumentTypes (unpredType pty) c vEnv+      esMap = map field2Tuple fs+      unknownEs = map prelUnknown tys+      maybeEs = map (flip lookup esMap) ls+      es = zipWith fromMaybe unknownEs maybeEs+  dsExpr p (applyConstr pty c tys es)+dsExpr p (RecordUpdate _ e fs) = do+  alts  <- constructors tc >>= concatMapM updateAlt+  dsExpr p $ mkCase Flex e (map (uncurry (caseAlt p)) alts)+  where ty = typeOf e+        pty = predType ty+        tc = rootOfType (arrowBase ty)+        updateAlt (RecordConstr c ls _)+          | all (`elem` qls2) (map fieldLabel fs)= do+            let qc = qualifyLike tc c+            vEnv <- getValueEnv+            let (qls, tys) = argumentTypes ty qc vEnv+            vs <- mapM (freshVar "_#rec") tys+            let pat = constrPattern pty qc vs+                esMap = map field2Tuple fs+                originalEs = map (uncurry mkVar) vs+                maybeEs = map (flip lookup esMap) qls+                es = zipWith fromMaybe originalEs maybeEs+            return [(pat, applyConstr pty qc tys es)]+          where qls2 = map (qualifyLike tc) ls+        updateAlt _ = return []+dsExpr p (Tuple      _ es) =+  apply (Constructor NoSpanInfo pty $ qTupleId $ length es)+  <$> mapM (dsExpr p) es+  where pty = predType (foldr TypeArrow (tupleType tys) tys)+        tys = map typeOf es+dsExpr p (List   _ pty es) = dsList cons nil <$> mapM (dsExpr p) es+  where nil = Constructor NoSpanInfo pty qNilId+        cons = (Apply NoSpanInfo) . (Apply NoSpanInfo)+          (Constructor NoSpanInfo+            (predType $ consType $ elemType $ unpredType pty) qConsId)+dsExpr p (ListCompr          _ e qs) = dsListComp p e qs+dsExpr p (EnumFrom              _ e) =+  Apply NoSpanInfo (prelEnumFrom (typeOf e)) <$> dsExpr p e+dsExpr p (EnumFromThen      _ e1 e2) =+  apply (prelEnumFromThen (typeOf e1)) <$> mapM (dsExpr p) [e1, e2]+dsExpr p (EnumFromTo        _ e1 e2) = apply (prelEnumFromTo (typeOf e1))+                                    <$> mapM (dsExpr p) [e1, e2]+dsExpr p (EnumFromThenTo _ e1 e2 e3) = apply (prelEnumFromThenTo (typeOf e1))+                                    <$> mapM (dsExpr p) [e1, e2, e3]+dsExpr p (UnaryMinus            _ e) = do+  e' <- dsExpr p e+  negativeLitsEnabled <- checkNegativeLitsExtension+  return $ case e' of+    Literal _ pty l | negativeLitsEnabled ->+      Literal NoSpanInfo pty $ negateLiteral l+    _                                     ->+      Apply NoSpanInfo (prelNegate $ typeOf e') e'+dsExpr p (Apply _ e1 e2) = Apply NoSpanInfo <$> dsExpr p e1 <*> dsExpr p e2+dsExpr p (InfixApply _ e1 op e2) = do+  op' <- dsExpr p (infixOp op)+  e1' <- dsExpr p e1+  e2' <- dsExpr p e2+  return $ apply op' [e1', e2']+dsExpr p (LeftSection  _ e op) =+  Apply NoSpanInfo <$> dsExpr p (infixOp op) <*> dsExpr p e+dsExpr p (RightSection _ op e) = do+  op' <- dsExpr p (infixOp op)+  e'  <- dsExpr p e+  return $ apply (prelFlip ty1 ty2 ty3) [op', e']+  where TypeArrow ty1 (TypeArrow ty2 ty3) = typeOf (infixOp op)+dsExpr p expr@(Lambda _ ts e) = do+  (pty, f) <- freshVar "_#lambda" expr+  dsExpr p $ mkLet [funDecl p pty f ts e] $ mkVar pty f+dsExpr p (Let _ _ ds e) = do+  ds' <- dsDeclGroup ds+  e'  <- dsExpr p e+  return $ mkLet ds' e'+dsExpr p (Do            _ _ sts e) = dsDo sts e >>= dsExpr p+dsExpr p (IfThenElse _ e1 e2 e3) = do+  e1' <- dsExpr p e1+  e2' <- dsExpr p e2+  e3' <- dsExpr p e3+  return $ mkCase Rigid e1'+             [caseAlt p truePat e2', caseAlt p falsePat e3']+dsExpr p (Case _ _ ct e alts) = dsCase p ct e alts++-- We ignore the context in the type signature of a typed expression, since+-- there should be no possibility to provide an non-empty context without+-- scoped type-variables.+-- TODO: Verify++dsQualTypeExpr :: QualTypeExpr -> DsM QualTypeExpr+dsQualTypeExpr (QualTypeExpr _ cx ty) =+  QualTypeExpr NoSpanInfo cx <$> dsTypeExpr ty++dsTypeExpr :: TypeExpr -> DsM TypeExpr+dsTypeExpr ty = do+  m <- getModuleIdent+  tcEnv <- getTyConsEnv+  let tvs = typeVariables ty+  return $ fromType tvs $ expandType m tcEnv $ toType tvs ty++-- -----------------------------------------------------------------------------+-- Desugaring of case expressions+-- -----------------------------------------------------------------------------++-- If an alternative in a case expression has boolean guards and all of+-- these guards return 'False', the enclosing case expression does+-- not fail but continues to match the remaining alternatives against the+-- selector expression. In order to implement this semantics, which is+-- compatible with Haskell, we expand an alternative with boolean guards+-- such that it evaluates a case expression with the remaining cases that+-- are compatible with the matched pattern when the guards fail.++dsCase :: SpanInfo -> CaseType -> Expression PredType -> [Alt PredType]+       -> DsM (Expression PredType)+dsCase p ct e alts+  | null alts = internalError "Desugar.dsCase: empty list of alternatives"+  | otherwise = do+    m  <- getModuleIdent+    e' <- dsExpr p e+    v  <- freshVar "_#case" e+    alts'  <- mapM dsAltLhs alts+    alts'' <- mapM (expandAlt v ct) (init (tails alts')) >>= mapM dsAltRhs+    return (mkMyCase m v e' alts'')+  where+  mkMyCase m (pty, v) e' bs+    | v `elem` qfv m bs = mkLet [varDecl p pty v e']+                          (mkCase ct (mkVar pty v) bs)+    | otherwise         = mkCase ct e' bs++dsAltLhs :: Alt PredType -> DsM (Alt PredType)+dsAltLhs (Alt p t rhs) = do+  (ds', t') <- dsPat p [] t+  return $ Alt p t' (addDecls ds' rhs)++dsAltRhs :: Alt PredType -> DsM (Alt PredType)+dsAltRhs (Alt p t rhs) = Alt p t <$> dsRhs id rhs++expandAlt :: (PredType, Ident) -> CaseType -> [Alt PredType]+          -> DsM (Alt PredType)+expandAlt _ _  []                   = error "Desugar.expandAlt: empty list"+expandAlt v ct (Alt p t rhs : alts) = caseAlt p t <$> expandRhs e0 id rhs+  where+  e0 | ct == Flex || null compAlts = prelFailed (typeOf rhs)+     | otherwise = mkCase ct (uncurry mkVar v) compAlts+  compAlts = filter (isCompatible t . altPattern) alts+  altPattern (Alt _ t1 _) = t1++isCompatible :: Pattern a -> Pattern a -> Bool+isCompatible (VariablePattern _ _ _) _ = True+isCompatible _ (VariablePattern _ _ _) = True+isCompatible (AsPattern _ _ t1) t2 = isCompatible t1 t2+isCompatible t1 (AsPattern _ _ t2) = isCompatible t1 t2+isCompatible (ConstructorPattern _ _ c1 ts1) (ConstructorPattern _ _ c2 ts2)+  = and ((c1 == c2) : zipWith isCompatible ts1 ts2)+isCompatible (LiteralPattern _ _ l1) (LiteralPattern _ _ l2) = l1 == l2+isCompatible _ _ = False++-- -----------------------------------------------------------------------------+-- Desugaring of do-Notation+-- -----------------------------------------------------------------------------++-- The do-notation is desugared in the following way:+--+-- `dsDo([]         , e)` -> `e`+-- `dsDo(e'     ; ss, e)` -> `e' >>        dsDo(ss, e)`+-- `dsDo(p <- e'; ss, e)` -> `e' >>= \v -> case v of+--                                           p -> dsDo(ss, e)+--                                           _ -> fail "..."`+-- `dsDo(let ds ; ss, e)` -> `let ds in    dsDo(ss, e)`+dsDo :: [Statement PredType] -> Expression PredType -> DsM (Expression PredType)+dsDo sts e = foldrM dsStmt e sts++dsStmt :: Statement PredType -> Expression PredType -> DsM (Expression PredType)+dsStmt (StmtExpr   _ e1) e' =+  return $ apply (prelBind_ (typeOf e1) (typeOf e')) [e1, e']+dsStmt (StmtBind _ t e1) e' = do+  v <- freshVar "_#var" t+  failable <- checkFailableBind t+  let func = mkLambda [uncurry (VariablePattern NoSpanInfo) v] $+               mkCase Rigid (uncurry mkVar v) $+                 caseAlt NoSpanInfo t e' :+                   if failable+                     then [caseAlt NoSpanInfo+                                   (uncurry (VariablePattern NoSpanInfo) v)+                                   (failedPatternMatch $ typeOf e')]+                     else []+  return $ apply (prelBind (typeOf e1) (typeOf t) (typeOf e')) [e1, func]+  where failedPatternMatch ty =+          apply (prelFail ty)+            [Literal NoSpanInfo predStringType $ String "Pattern match failed!"]+dsStmt (StmtDecl   _ _ ds) e' = return $ mkLet ds e'++checkFailableBind :: Pattern a -> DsM Bool+checkFailableBind (ConstructorPattern _ _ idt ps   ) = do+  tcEnv <- getTyConsEnv+  case qualLookupTypeInfo idt tcEnv of+    [RenamingType _ _ _ ] -> or <$> mapM checkFailableBind ps -- or [] == False+    [DataType     _ _ cs]+      | length cs == 1    -> or <$> mapM checkFailableBind ps+      | otherwise         -> return True+    _                     -> return True+checkFailableBind (InfixPattern       _ _ p1 idt p2) = do+  tcEnv <- getTyConsEnv+  case qualLookupTypeInfo idt tcEnv of+    [RenamingType _ _ _ ] -> (||) <$> checkFailableBind p1+                                  <*> checkFailableBind p2+    [DataType     _ _ cs]+      | length cs == 1    -> (||) <$> checkFailableBind p1+                                  <*> checkFailableBind p2+      | otherwise         -> return True+    _                     -> return True+checkFailableBind (RecordPattern      _ _ idt fs   ) = do+  tcEnv <- getTyConsEnv+  case qualLookupTypeInfo idt tcEnv of+    [RenamingType _ _ _ ] -> or <$> mapM (checkFailableBind . fieldContent) fs+    [DataType     _ _ cs]+      | length cs == 1    -> or <$> mapM (checkFailableBind . fieldContent) fs+      | otherwise         -> return True+    _                     -> return True+  where fieldContent (Field _ _ c) = c+checkFailableBind (TuplePattern       _       ps   ) =+  or <$> mapM checkFailableBind ps+checkFailableBind (AsPattern          _   _   p    ) = checkFailableBind p+checkFailableBind (ParenPattern       _       p    ) = checkFailableBind p+checkFailableBind (LazyPattern        _       _    ) = return False+checkFailableBind (VariablePattern    _ _ _        ) = return False+checkFailableBind _                                  = return True+-- -----------------------------------------------------------------------------+-- Desugaring of List Comprehensions+-- -----------------------------------------------------------------------------++-- In general, a list comprehension of the form+-- '[e | t <- l, qs]'+-- is transformed into an expression 'foldr f [] l' where 'f'+-- is a new function defined as+--+--     f x xs =+--       case x of+--           t -> [e | qs] ++ xs+--           _ -> xs+--+-- Note that this translation evaluates the elements of 'l' rigidly,+-- whereas the translation given in the Curry report is flexible.+-- However, it does not seem very useful to have the comprehension+-- generate instances of 't' which do not contribute to the list.+-- TODO: Unfortunately, this is incorrect.++-- Actually, we generate slightly better code in a few special cases.+-- When 't' is a plain variable, the 'case' expression degenerates+-- into a let-binding and the auxiliary function thus becomes an alias+-- for '(++)'. Instead of 'foldr (++)' we use the+-- equivalent prelude function 'concatMap'. In addition, if the+-- remaining list comprehension in the body of the auxiliary function has+-- no qualifiers -- i.e., if it is equivalent to '[e]' -- we+-- avoid the construction of the singleton list by calling '(:)'+-- instead of '(++)' and 'map' in place of 'concatMap', respectively.++dsListComp :: SpanInfo -> Expression PredType -> [Statement PredType]+           -> DsM (Expression PredType)+dsListComp p e []     =+  dsExpr p (List NoSpanInfo (predType $ listType $ typeOf e) [e])+dsListComp p e (q:qs) = dsQual p q (ListCompr NoSpanInfo e qs)++dsQual :: SpanInfo -> Statement PredType -> Expression PredType+       -> DsM (Expression PredType)+dsQual p (StmtExpr   _ b) e =+  dsExpr p (IfThenElse NoSpanInfo b e (List NoSpanInfo (predType $ typeOf e) []))+dsQual p (StmtDecl _ _ ds) e = dsExpr p (mkLet ds e)+dsQual p (StmtBind _ t l) e+  | isVariablePattern t = dsExpr p (qualExpr t e l)+  | otherwise = do+    v <- freshVar "_#var" t+    l' <- freshVar "_#var" e+    dsExpr p (apply (prelFoldr (typeOf t) (typeOf e))+      [foldFunct v l' e, List NoSpanInfo (predType $ typeOf e) [], l])+  where+  qualExpr v (ListCompr NoSpanInfo e1 []) l1+    = apply (prelMap (typeOf v) (typeOf e1)) [mkLambda [v] e1, l1]+  qualExpr v e1                  l1+    = apply (prelConcatMap (typeOf v) (elemType $ typeOf e1))+      [mkLambda [v] e1, l1]+  foldFunct v l1 e1+    = mkLambda (map (uncurry (VariablePattern NoSpanInfo)) [v, l1])+       (mkCase Rigid (uncurry mkVar v)+          [ caseAlt p t (append e1 (uncurry mkVar l1))+          , caseAlt p (uncurry (VariablePattern NoSpanInfo) v)+                                    (uncurry mkVar l1)])++  append (ListCompr _ e1 []) l1 = apply (prelCons (typeOf e1)) [e1, l1]+  append e1                  l1 =+    apply (prelAppend (elemType $ typeOf e1)) [e1, l1]+  prelCons ty                   =+      Constructor NoSpanInfo (predType $ consType ty) $ qConsId++-- -----------------------------------------------------------------------------+-- Desugaring of Lists, labels, fields, and literals+-- -----------------------------------------------------------------------------++dsList :: (b -> b -> b) -> b -> [b] -> b+dsList = foldr++--dsLabel :: a -> [(QualIdent, a)] -> QualIdent -> a+--dsLabel def fs l = fromMaybe def (lookup l fs)++dsField :: (a -> b -> DsM (a, b)) -> a -> Field b -> DsM (a, Field b)+dsField ds z (Field p l x) = second (Field p l) <$> ds z x++dsLiteral :: PredType -> Literal+          -> Either (Expression PredType) (Expression PredType)+dsLiteral pty (Char c) = Right $ Literal NoSpanInfo pty $ Char c+dsLiteral pty (Int i) = Right $ fixLiteral (unpredType pty)+  where fixLiteral (TypeConstrained tys _) = fixLiteral (head tys)+        fixLiteral ty+          | ty == intType = Literal NoSpanInfo pty $ Int i+          | ty == floatType = Literal NoSpanInfo pty $ Float $ fromInteger i+          | otherwise = Apply NoSpanInfo (prelFromInt $ unpredType pty) $+                          Literal NoSpanInfo predIntType $ Int i+dsLiteral pty f@(Float _) = Right $ fixLiteral (unpredType pty)+  where fixLiteral (TypeConstrained tys _) = fixLiteral (head tys)+        fixLiteral ty+          | ty == floatType = Literal NoSpanInfo pty f+          | otherwise = Apply NoSpanInfo (prelFromFloat $ unpredType pty) $+                          Literal NoSpanInfo predFloatType f+dsLiteral pty (String cs) =+  Left $ List NoSpanInfo pty $ map (Literal NoSpanInfo pty' . Char) cs+  where pty' = predType $ elemType $ unpredType pty++negateLiteral :: Literal -> Literal+negateLiteral (Int i) = Int (-i)+negateLiteral (Float f) = Float (-f)+negateLiteral _ = internalError "Desugar.negateLiteral"++-- ---------------------------------------------------------------------------+-- Prelude entities+-- ---------------------------------------------------------------------------++preludeFun :: [Type] -> Type -> String -> Expression PredType+preludeFun tys ty = Variable NoSpanInfo (predType $ foldr TypeArrow ty tys)+                  . preludeIdent++preludeIdent :: String -> QualIdent+preludeIdent = qualifyWith preludeMIdent . mkIdent++prelBind :: Type -> Type -> Type -> Expression PredType+prelBind ma a mb = preludeFun [ma, TypeArrow a mb] mb ">>="++prelBind_ :: Type -> Type -> Expression PredType+prelBind_ ma mb = preludeFun [ma, mb] mb ">>"++prelFlip :: Type -> Type -> Type -> Expression PredType+prelFlip a b c = preludeFun [TypeArrow a (TypeArrow b c), b, a] c "flip"++prelFromInt :: Type -> Expression PredType+prelFromInt a = preludeFun [intType] a "fromInt"++prelFromFloat :: Type -> Expression PredType+prelFromFloat a = preludeFun [floatType] a "fromFloat"++prelEnumFrom :: Type -> Expression PredType+prelEnumFrom a = preludeFun [a] (listType a) "enumFrom"++prelEnumFromTo :: Type -> Expression PredType+prelEnumFromTo a = preludeFun [a, a] (listType a) "enumFromTo"++prelEnumFromThen :: Type -> Expression PredType+prelEnumFromThen a = preludeFun [a, a] (listType a) "enumFromThen"++prelEnumFromThenTo :: Type -> Expression PredType+prelEnumFromThenTo a = preludeFun [a, a, a] (listType a) "enumFromThenTo"++prelNegate :: Type -> Expression PredType+prelNegate a = preludeFun [a] a "negate"++prelFail :: Type -> Expression PredType+prelFail ma = preludeFun [stringType] ma "fail"++prelFailed :: Type -> Expression PredType+prelFailed a = preludeFun [] a "failed"++prelUnknown :: Type -> Expression PredType+prelUnknown a = preludeFun [] a "unknown"++prelMap :: Type -> Type -> Expression PredType+prelMap a b = preludeFun [TypeArrow a b, listType a] (listType b) "map"++prelFoldr :: Type -> Type -> Expression PredType+prelFoldr a b =+  preludeFun [TypeArrow a (TypeArrow b b), b, listType a] b "foldr"++prelAppend :: Type -> Expression PredType+prelAppend a = preludeFun [listType a, listType a] (listType a) "++"++prelConcatMap :: Type -> Type -> Expression PredType+prelConcatMap a b =+  preludeFun [TypeArrow a (listType b), listType a] (listType b) "concatMap"++(=:<=) :: Expression PredType -> Expression PredType -> Expression PredType+e1 =:<= e2 = apply (preludeFun [typeOf e1, typeOf e2] boolType "=:<=") [e1, e2]++(=:=) :: Expression PredType -> Expression PredType -> Expression PredType+e1 =:= e2 = apply (preludeFun [typeOf e1, typeOf e2] boolType "=:=") [e1, e2]++(&>) :: Expression PredType -> Expression PredType -> Expression PredType+e1 &> e2 = apply (preludeFun [boolType, typeOf e2] (typeOf e2) "cond") [e1, e2]++(&) :: Expression PredType -> Expression PredType -> Expression PredType+e1 & e2 = apply (preludeFun [boolType, boolType] boolType "&") [e1, e2]++truePat :: Pattern PredType+truePat = ConstructorPattern NoSpanInfo predBoolType qTrueId []++falsePat :: Pattern PredType+falsePat = ConstructorPattern NoSpanInfo predBoolType qFalseId []++-- ---------------------------------------------------------------------------+-- Auxiliary definitions+-- ---------------------------------------------------------------------------++conType :: QualIdent -> ValueEnv -> ([Ident], TypeScheme)+conType c vEnv = case qualLookupValue c vEnv of+  [DataConstructor _ _ ls ty] -> (ls , ty)+  [NewtypeConstructor _ l ty] -> ([l], ty)+  _                           -> internalError $ "Desguar.conType: " ++ show c++varType :: QualIdent -> ValueEnv -> TypeScheme+varType v vEnv = case qualLookupValue v vEnv of+  Value _ _ _ tySc : _ -> tySc+  Label _ _   tySc : _ -> tySc+  _                    -> internalError $ "Desugar.varType: " ++ show v++elemType :: Type -> Type+elemType (TypeApply (TypeConstructor tc) ty) | tc == qListId = ty+elemType ty = internalError $ "Base.Types.elemType " ++ show ty++applyConstr :: PredType -> QualIdent -> [Type] -> [Expression PredType]+            -> Expression PredType+applyConstr pty c tys =+  apply (Constructor NoSpanInfo+    (predType (foldr TypeArrow (unpredType pty) tys)) c)++-- The function 'instType' instantiates the universally quantified+-- type variables of a type scheme with fresh type variables. Since this+-- function is used only to instantiate the closed types of record+-- constructors (recall that no existentially quantified type+-- variables are allowed for records), the compiler can reuse the same+-- monomorphic type variables for every instantiated type.++instType :: TypeScheme -> Type+instType (ForAll _ pty) = inst $ unpredType pty+  where inst (TypeConstructor     tc) = TypeConstructor tc+        inst (TypeApply      ty1 ty2) = TypeApply (inst ty1) (inst ty2)+        inst (TypeVariable        tv) = TypeVariable (-1 - tv)+        inst (TypeArrow      ty1 ty2) = TypeArrow (inst ty1) (inst ty2)+        inst ty                       = ty++-- Retrieve all constructors of a type+constructors :: QualIdent -> DsM [DataConstr]+constructors tc = getTyConsEnv >>= \tcEnv -> return $+  case qualLookupTypeInfo tc tcEnv of+    [DataType     _ _ cs] -> cs+    [RenamingType _ _ nc] -> [nc]+    _                     ->+      internalError $ "Transformations.Desugar.constructors: " ++ show tc++-- The function 'argumentTypes' returns the labels and the argument types+-- of a data constructor instantiated at a particular type.++argumentTypes :: Type -> QualIdent -> ValueEnv -> ([QualIdent], [Type])+argumentTypes ty c vEnv =+  (map (qualifyLike c) ls, map (subst (matchType ty0 ty idSubst)) tys)+  where (ls, ForAll _ (PredType _ ty')) = conType c vEnv+        (tys, ty0) = arrowUnapply ty'
+ src/Transformations/Dictionary.hs view
@@ -0,0 +1,1143 @@+{- |+  Module      :  $Header$+  Description :  Dictionary insertion+  Copyright   :  (c) 2016 - 2017 Finn Teegen+  License     :  BSD-3-clause++  Maintainer  :  bjp@informatik.uni-kiel.de+  Stability   :  experimental+  Portability :  portable++  TODO+-}++{-# LANGUAGE CPP #-}+module Transformations.Dictionary+  ( insertDicts+  , dictTypeId, qDictTypeId, dictConstrId, qDictConstrId+  , defaultMethodId, qDefaultMethodId, superDictStubId, qSuperDictStubId+  , instFunId, qInstFunId, implMethodId, qImplMethodId+  ) where++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative      ((<$>), (<*>))+import           Data.Traversable         (traverse)+#endif+import           Control.Monad.Extra      ( concatMapM, liftM, maybeM, when+                                          , zipWithM )+import qualified Control.Monad.State as S (State, runState, gets, modify)++import           Data.List         (inits, nub, partition, tails, zipWith4)+import qualified Data.Map   as Map ( Map, empty, insert, lookup, mapWithKey+                                   , toList )+import           Data.Maybe        (fromMaybe, isJust)+import qualified Data.Set   as Set ( deleteMin, fromList, null, size, toAscList+                                   , toList, union )++import Curry.Base.Ident+import Curry.Base.Position+import Curry.Base.SpanInfo+import Curry.Syntax++import Base.CurryTypes+import Base.Expr+import Base.Kinds+import Base.Messages (internalError)+import Base.TopEnv+import Base.Types+import Base.TypeSubst+import Base.Typing++import Env.Class+import Env.Instance+import Env.Interface+import Env.OpPrec+import Env.TypeConstructor+import Env.Value++data DTState = DTState+  { moduleIdent :: ModuleIdent+  , tyConsEnv   :: TCEnv+  , valueEnv    :: ValueEnv+  , classEnv    :: ClassEnv+  , instEnv     :: InstEnv+  , opPrecEnv   :: OpPrecEnv+  , dictEnv     :: DictEnv    -- for dictionary insertion+  , specEnv     :: SpecEnv    -- for dictionary specialization+  , nextId      :: Integer+  }++type DTM = S.State DTState++insertDicts :: Bool -> InterfaceEnv -> TCEnv -> ValueEnv -> ClassEnv+            -> InstEnv -> OpPrecEnv -> Module PredType+            -> (Module Type, InterfaceEnv, TCEnv, ValueEnv, OpPrecEnv)+insertDicts inlDi intfEnv tcEnv vEnv clsEnv inEnv pEnv mdl@(Module _ _ _ m _ _ _) =+  (mdl', intfEnv', tcEnv', vEnv', pEnv')+  where initState =+          DTState m tcEnv vEnv clsEnv inEnv pEnv emptyDictEnv emptySpEnv 1+        (mdl', tcEnv', vEnv', pEnv') =+          runDTM (dictTrans mdl >>= (if inlDi then specialize else return) >>= cleanup) initState+        intfEnv' = dictTransInterfaces vEnv' clsEnv intfEnv++runDTM :: DTM a -> DTState -> (a, TCEnv, ValueEnv, OpPrecEnv)+runDTM dtm s =+  let (a, s') = S.runState dtm s in (a, tyConsEnv s', valueEnv s', opPrecEnv s')++getModuleIdent :: DTM ModuleIdent+getModuleIdent = S.gets moduleIdent++getTyConsEnv :: DTM TCEnv+getTyConsEnv = S.gets tyConsEnv++modifyTyConsEnv :: (TCEnv -> TCEnv) -> DTM ()+modifyTyConsEnv f = S.modify $ \s -> s { tyConsEnv = f $ tyConsEnv s }++getValueEnv :: DTM ValueEnv+getValueEnv = S.gets valueEnv++modifyValueEnv :: (ValueEnv -> ValueEnv) -> DTM ()+modifyValueEnv f = S.modify $ \s -> s { valueEnv = f $ valueEnv s }++withLocalValueEnv :: DTM a -> DTM a+withLocalValueEnv act = do+  oldEnv <- getValueEnv+  res <- act+  modifyValueEnv $ const oldEnv+  return res++getClassEnv :: DTM ClassEnv+getClassEnv = S.gets classEnv++getInstEnv :: DTM InstEnv+getInstEnv = S.gets instEnv++modifyInstEnv :: (InstEnv -> InstEnv) -> DTM ()+modifyInstEnv f = S.modify $ \s -> s { instEnv = f $ instEnv s }++getPrecEnv :: DTM OpPrecEnv+getPrecEnv = S.gets opPrecEnv++modifyPrecEnv :: (OpPrecEnv -> OpPrecEnv) -> DTM ()+modifyPrecEnv f = S.modify $ \s -> s { opPrecEnv = f $ opPrecEnv s }++getDictEnv :: DTM DictEnv+getDictEnv = S.gets dictEnv++modifyDictEnv :: (DictEnv -> DictEnv) -> DTM ()+modifyDictEnv f = S.modify $ \s -> s { dictEnv = f $ dictEnv s }++withLocalDictEnv :: DTM a -> DTM a+withLocalDictEnv act = do+  oldEnv <- getDictEnv+  res <- act+  modifyDictEnv $ const oldEnv+  return res++getSpEnv :: DTM SpecEnv+getSpEnv = S.gets specEnv++setSpEnv :: SpecEnv -> DTM ()+setSpEnv spEnv = S.modify $ \s -> s { specEnv = spEnv }++getNextId :: DTM Integer+getNextId = do+  nid <- S.gets nextId+  S.modify $ \s -> s { nextId = succ nid }+  return nid++-- -----------------------------------------------------------------------------+-- Lifting class and instance declarations+-- -----------------------------------------------------------------------------++-- When we lift class and instance declarations, we can remove the optional+-- default declaration since it has already been considered during the type+-- check.++liftDecls :: Decl PredType -> DTM [Decl PredType]+liftDecls (DefaultDecl _ _) = return []+liftDecls (ClassDecl _ _ _ cls tv ds) = do+  m <- getModuleIdent+  liftClassDecls (qualifyWith m cls) tv ds+liftDecls (InstanceDecl _ _ cx cls ty ds) = do+  clsEnv <- getClassEnv+  let PredType ps ty' = toPredType [] $ QualTypeExpr NoSpanInfo cx ty+      ps' = minPredSet clsEnv ps+  liftInstanceDecls ps' cls ty' ds+liftDecls d = return [d]++liftClassDecls :: QualIdent -> Ident -> [Decl PredType] -> DTM [Decl PredType]+liftClassDecls cls tv ds = do+  dictDecl <- createClassDictDecl cls tv ods+  clsEnv <- getClassEnv+  let fs = classMethods cls clsEnv+  methodDecls <- mapM (createClassMethodDecl cls ms) fs+  return $ dictDecl : methodDecls+  where (vds, ods) = partition isValueDecl ds+        ms = methodMap vds++liftInstanceDecls :: PredSet -> QualIdent -> Type -> [Decl PredType]+                  -> DTM [Decl PredType]+liftInstanceDecls ps cls ty ds = do+  dictDecl <- createInstDictDecl ps cls ty+  clsEnv <- getClassEnv+  let fs = classMethods cls clsEnv+  methodDecls <- mapM (createInstMethodDecl ps cls ty ms) fs+  return $ dictDecl : methodDecls+  where ms = methodMap ds++-- Since not every class method needs to be implemented in a class or instance+-- declaration, we use a map to associate a class method identifier with its+-- implementation.++type MethodMap = [(Ident, Decl PredType)]++-- We have to unrename the method's identifiers here because the syntax check+-- has renamed them before.++methodMap :: [Decl PredType] -> MethodMap+methodMap ds = [(unRenameIdent f, d) | d@(FunctionDecl _ _ f _) <- ds]++createClassDictDecl :: QualIdent -> Ident -> [Decl a] -> DTM (Decl a)+createClassDictDecl cls tv ds = do+  c <- createClassDictConstrDecl cls tv ds+  return $ DataDecl NoSpanInfo (dictTypeId cls) [tv] [c] []++createClassDictConstrDecl :: QualIdent -> Ident -> [Decl a] -> DTM ConstrDecl+createClassDictConstrDecl cls tv ds = do+  let tvs  = tv : filter (unRenameIdent tv /=) identSupply+      mtys = map (fromType tvs . generalizeMethodType . transformMethodPredType)+                 [toMethodType cls tv qty | TypeSig _ fs qty <- ds, _ <- fs]+  return $ ConstrDecl NoSpanInfo (dictConstrId cls) mtys++classDictConstrPredType :: ValueEnv -> ClassEnv -> QualIdent -> PredType+classDictConstrPredType vEnv clsEnv cls = PredType ps $ foldr TypeArrow ty mtys+  where sclss = superClasses cls clsEnv+        ps    = Set.fromList [Pred scls (TypeVariable 0) | scls <- sclss]+        fs    = classMethods cls clsEnv+        mptys = map (classMethodType vEnv cls) fs+        ty    = dictType $ Pred cls $ TypeVariable 0+        mtys  = map (generalizeMethodType . transformMethodPredType) mptys++createInstDictDecl :: PredSet -> QualIdent -> Type -> DTM (Decl PredType)+createInstDictDecl ps cls ty = do+  pty <- PredType ps . arrowBase <$> getInstDictConstrType cls ty+  funDecl NoSpanInfo pty (instFunId cls ty) [ConstructorPattern NoSpanInfo predUnitType qUnitId []] <$> createInstDictExpr cls ty++createInstDictExpr :: QualIdent -> Type -> DTM (Expression PredType)+createInstDictExpr cls ty = do+  ty' <- instType <$> getInstDictConstrType cls ty+  m <- getModuleIdent+  clsEnv <- getClassEnv+  let fs = map (qImplMethodId m cls ty) $ classMethods cls clsEnv+  return $ apply (Constructor NoSpanInfo (predType ty') (qDictConstrId cls))+             (zipWith (Variable NoSpanInfo . predType) (arrowArgs ty') fs)++getInstDictConstrType :: QualIdent -> Type -> DTM Type+getInstDictConstrType cls ty = do+  vEnv <- getValueEnv+  clsEnv <- getClassEnv+  return $ instanceType ty $ unpredType $ classDictConstrPredType vEnv clsEnv cls++createClassMethodDecl :: QualIdent -> MethodMap -> Ident -> DTM (Decl PredType)+createClassMethodDecl cls =+  createMethodDecl (defaultMethodId cls) (defaultClassMethodDecl cls)++defaultClassMethodDecl :: QualIdent -> Ident -> DTM (Decl PredType)+defaultClassMethodDecl cls f = do+  pty@(PredType _ ty) <- getClassMethodType cls f+  return $ funDecl NoSpanInfo pty f [] $ preludeError (instType ty) $+    "No instance or default method for class operation " ++ escName f++getClassMethodType :: QualIdent -> Ident -> DTM PredType+getClassMethodType cls f = do+  vEnv <- getValueEnv+  return $ classMethodType vEnv cls f++classMethodType :: ValueEnv -> QualIdent -> Ident -> PredType+classMethodType vEnv cls f = pty+  where ForAll _ pty = funType (qualifyLike cls f) vEnv++createInstMethodDecl :: PredSet -> QualIdent -> Type -> MethodMap -> Ident+                     -> DTM (Decl PredType)+createInstMethodDecl ps cls ty =+  createMethodDecl (implMethodId cls ty) (defaultInstMethodDecl ps cls ty)++defaultInstMethodDecl :: PredSet -> QualIdent -> Type -> Ident+                      -> DTM (Decl PredType)+defaultInstMethodDecl ps cls ty f = do+  vEnv <- getValueEnv+  let pty@(PredType _ ty') = instMethodType vEnv ps cls ty f+  return $ funDecl NoSpanInfo pty f [] $+    Variable NoSpanInfo (predType $ instType ty') (qDefaultMethodId cls f)++-- Returns the type for a given instance's method of a given class. To this+-- end, the class method's type is stripped of its first predicate (which is+-- the implicit class constraint) and the class variable is replaced with the+-- instance's type. The remaining predicate set is then united with the+-- instance's predicate set.++instMethodType :: ValueEnv -> PredSet -> QualIdent -> Type -> Ident -> PredType+instMethodType vEnv ps cls ty f = PredType (ps `Set.union` ps'') ty''+  where PredType ps'  ty'  = classMethodType vEnv cls f+        PredType ps'' ty'' = instanceType ty $ PredType (Set.deleteMin ps') ty'++createMethodDecl :: (Ident -> Ident) -> (Ident -> DTM (Decl PredType))+                 -> MethodMap -> Ident -> DTM (Decl PredType)+createMethodDecl methodId defaultDecl ms f =+  liftM (renameDecl $ methodId f) $ maybe (defaultDecl f) return (lookup f ms)++-- We have to rename the left hand side of lifted function declarations+-- accordingly which is done by the function 'renameDecl'.++renameDecl :: Ident -> Decl a -> Decl a+renameDecl f (FunctionDecl p a _ eqs) = FunctionDecl p a f $ map renameEq eqs+  where renameEq (Equation p' lhs rhs) = Equation p' (renameLhs lhs) rhs+        renameLhs (FunLhs _ _ ts) = FunLhs NoSpanInfo f ts+        renameLhs _ = internalError "Dictionary.renameDecl.renameLhs"+renameDecl _ _ = internalError "Dictionary.renameDecl"++-- -----------------------------------------------------------------------------+-- Creating stub declarations+-- -----------------------------------------------------------------------------++-- For each class method f defined in the processed module we have to introduce+-- a stub method with the same name that selects the appropriate function from+-- the provided dictionary and applies the remaining arguments to it. We also+-- create a stub method for each super class selecting the corresponding super+-- class dictionary from the provided class dictionary.++createStubs :: Decl PredType -> DTM [Decl Type]+createStubs (ClassDecl _ _ _ cls _ _) = do+  m <- getModuleIdent+  vEnv <- getValueEnv+  clsEnv <- getClassEnv+  let ocls  = qualifyWith m cls+      sclss = superClasses ocls clsEnv+      fs    = classMethods ocls clsEnv+      dictConstrPty = classDictConstrPredType vEnv clsEnv ocls+      (superDictAndMethodTys, dictTy) =+        arrowUnapply $ transformPredType dictConstrPty+      (superDictTys, methodTys)       =+        splitAt (length sclss) superDictAndMethodTys+      (superStubTys, methodStubTys)   =+        splitAt (length sclss) $ map (TypeArrow dictTy) superDictAndMethodTys+  superDictVs <- mapM (freshVar "_#super" . instType) superDictTys+  methodVs <- mapM (freshVar "_#meth" . instType) methodTys+  let patternVs   = superDictVs ++ methodVs+      pattern     = createDictPattern (instType dictTy) ocls patternVs+      superStubs  = zipWith3 (createSuperDictStubDecl pattern ocls)+                      superStubTys sclss superDictVs+      methodStubs = zipWith3 (createMethodStubDecl pattern)+                      methodStubTys fs methodVs+  return $ superStubs ++ methodStubs+createStubs _ = return []++createDictPattern :: Type -> QualIdent -> [(Type, Ident)] -> Pattern Type+createDictPattern a cls = constrPattern a (qDictConstrId cls)++createSuperDictStubDecl :: Pattern Type -> QualIdent -> Type -> QualIdent+                        -> (Type, Ident) -> Decl Type+createSuperDictStubDecl t cls a super v =+  createStubDecl t a (superDictStubId cls super) v++createMethodStubDecl :: Pattern Type -> Type -> Ident -> (Type, Ident) -> Decl Type+createMethodStubDecl = createStubDecl++createStubDecl :: Pattern Type -> Type -> Ident -> (Type, Ident) -> Decl Type+createStubDecl t a f v =+  FunctionDecl NoSpanInfo a f [createStubEquation t f v]++createStubEquation :: Pattern Type -> Ident -> (Type, Ident) -> Equation Type+createStubEquation t f v = +  mkEquation NoSpanInfo f [VariablePattern NoSpanInfo (TypeArrow unitType (typeOf t)) (mkIdent "_#temp")] $+    mkLet [FunctionDecl NoSpanInfo (TypeArrow (typeOf t) (fst v)) (mkIdent "_#lambda")+      [mkEquation NoSpanInfo (mkIdent "_#lambda") [t] $ uncurry mkVar v]]+      (apply (Variable NoSpanInfo (TypeArrow (typeOf t) (fst v)) (qualify $ mkIdent "_#lambda"))+        [apply (Variable NoSpanInfo (TypeArrow unitType (typeOf t)) (qualify $ mkIdent "_#temp"))+          [Constructor NoSpanInfo unitType qUnitId]])++superDictStubType :: QualIdent -> QualIdent -> Type -> Type+superDictStubType cls super ty =+  TypeArrow (rtDictType $ Pred cls ty) (rtDictType $ Pred super ty)++-- -----------------------------------------------------------------------------+-- Entering new bindings into the environments+-- -----------------------------------------------------------------------------++bindDictTypes :: ModuleIdent -> ClassEnv -> TCEnv -> TCEnv+bindDictTypes m clsEnv tcEnv =+  foldr (bindDictType m clsEnv) tcEnv (allEntities tcEnv)++bindDictType :: ModuleIdent -> ClassEnv -> TypeInfo -> TCEnv -> TCEnv+bindDictType m clsEnv (TypeClass cls k ms) = bindEntity m tc ti+  where ti    = DataType tc (KindArrow k KindStar) [c]+        tc    = qDictTypeId cls+        c     = DataConstr (dictConstrId cls) (map rtDictType (Set.toAscList ps) ++ tys)+        sclss = superClasses cls clsEnv+        ps    = Set.fromList [Pred scls (TypeVariable 0) | scls <- sclss]+        tys   = map (generalizeMethodType . transformMethodPredType . methodType) ms+bindDictType _ _      _                    = id++bindClassDecls :: ModuleIdent -> TCEnv -> ClassEnv -> ValueEnv -> ValueEnv+bindClassDecls m tcEnv clsEnv =+  flip (foldr $ bindClassEntities m clsEnv) $ allEntities tcEnv++-- It is safe to use 'fromMaybe 0' in 'bindClassEntities', because the+-- augmentation has already replaced the 'Nothing' value for the arity+-- of a method's implementation with 'Just 1' (despite the fact that+-- maybe no default implementation has been provided) if the method has+-- been augmented.++bindClassEntities :: ModuleIdent -> ClassEnv -> TypeInfo -> ValueEnv -> ValueEnv+bindClassEntities m clsEnv (TypeClass cls _ ms) =+  bindClassDict m clsEnv cls . bindSuperStubs m cls sclss .+    bindDefaultMethods m cls fs+  where fs    = zip (map methodName ms) (map (fromMaybe 0 . methodArity) ms)+        sclss = superClasses cls clsEnv+bindClassEntities _ _ _ = id++bindClassDict :: ModuleIdent -> ClassEnv -> QualIdent -> ValueEnv -> ValueEnv+bindClassDict m clsEnv cls vEnv = bindEntity m c dc vEnv+  where c  = qDictConstrId cls+        dc = DataConstructor c a (replicate a anonId) tySc+        a  = Set.size ps + arrowArity ty+        pty@(PredType ps ty) = classDictConstrPredType vEnv clsEnv cls+        tySc = ForAll 1 pty++bindDefaultMethods :: ModuleIdent -> QualIdent -> [(Ident, Int)] -> ValueEnv+                   -> ValueEnv+bindDefaultMethods m = flip . foldr . bindDefaultMethod m++bindDefaultMethod :: ModuleIdent -> QualIdent -> (Ident, Int) -> ValueEnv+                  -> ValueEnv+bindDefaultMethod m cls (f, n) vEnv =+  bindMethod m (qDefaultMethodId cls f) n (classMethodType vEnv cls f) vEnv++bindSuperStubs :: ModuleIdent -> QualIdent -> [QualIdent] -> ValueEnv+               -> ValueEnv+bindSuperStubs m = flip . foldr . bindSuperStub m++bindSuperStub :: ModuleIdent -> QualIdent -> QualIdent -> ValueEnv -> ValueEnv+bindSuperStub m cls scls = bindEntity m f $ Value f Nothing 1 $ polyType ty+  where f  = qSuperDictStubId cls scls+        ty = superDictStubType cls scls (TypeVariable 0)++bindInstDecls :: ModuleIdent -> TCEnv -> ClassEnv -> InstEnv -> ValueEnv+                  -> ValueEnv+bindInstDecls m tcEnv clsEnv =+  flip (foldr $ bindInstFuns m tcEnv clsEnv) . Map.toList++bindInstFuns :: ModuleIdent -> TCEnv -> ClassEnv -> (InstIdent, InstInfo)+             -> ValueEnv -> ValueEnv+bindInstFuns m tcEnv clsEnv ((cls, tc), (m', ps, is)) =+  bindInstDict m cls ty m' ps . bindInstMethods m clsEnv cls ty m' ps is+  where ty = applyType (TypeConstructor tc) (take n (map TypeVariable [0..]))+        n = kindArity (tcKind m tc tcEnv) - kindArity (clsKind m cls tcEnv)++bindInstDict :: ModuleIdent -> QualIdent -> Type -> ModuleIdent -> PredSet+             -> ValueEnv -> ValueEnv+bindInstDict m cls ty m' ps =+  bindMethod m (qInstFunId m' cls ty) 1 $ PredType ps $ rtDictType $ Pred cls ty++bindInstMethods :: ModuleIdent -> ClassEnv -> QualIdent -> Type -> ModuleIdent+                -> PredSet -> [(Ident, Int)] -> ValueEnv -> ValueEnv+bindInstMethods m clsEnv cls ty m' ps is =+  flip (foldr (bindInstMethod m cls ty m' ps is)) (classMethods cls clsEnv)++bindInstMethod :: ModuleIdent -> QualIdent -> Type -> ModuleIdent+               -> PredSet -> [(Ident, Int)] -> Ident -> ValueEnv -> ValueEnv+bindInstMethod m cls ty m' ps is f vEnv = bindMethod m f' a pty vEnv+  where f'  = qImplMethodId m' cls ty f+        a   = fromMaybe 0 $ lookup f is+        pty = instMethodType vEnv ps cls ty f++bindMethod :: ModuleIdent -> QualIdent -> Int -> PredType -> ValueEnv+           -> ValueEnv+bindMethod m f n pty = bindEntity m f $ Value f Nothing n $ typeScheme pty++-- The function 'bindEntity' introduces a binding for an entity into a top-level+-- environment. Depending on whether the entity is defined in the current module+-- or not, either an unqualified and a qualified local binding or a qualified+-- import are added to the environment.++bindEntity :: Entity a => ModuleIdent -> QualIdent -> a -> TopEnv a+           -> TopEnv a+bindEntity m x = case qidModule (qualUnqualify m x) of+  Just m' | m /= m' -> qualImportTopEnv m' x'+  _                 -> qualBindTopEnv (qualifyWith m x')+  where x' = unqualify x++-- -----------------------------------------------------------------------------+-- Transforming the environments+-- -----------------------------------------------------------------------------++dictTransTypes :: TCEnv -> TCEnv+dictTransTypes = fmap dictTransTypeInfo++dictTransTypeInfo :: TypeInfo -> TypeInfo+dictTransTypeInfo (DataType tc k cs) =+  DataType tc k $ map dictTransDataConstr cs+dictTransTypeInfo (RenamingType tc k nc) =+  RenamingType tc k $ dictTransDataConstr nc+dictTransTypeInfo ti@(AliasType _ _ _ _) = ti+dictTransTypeInfo (TypeClass cls k ms) =+  TypeClass cls k $ map dictTransClassMethod ms+dictTransTypeInfo (TypeVar _) =+  internalError "Dictionary.dictTransTypeInfo: type variable"++dictTransDataConstr :: DataConstr -> DataConstr+dictTransDataConstr (DataConstr c tys) = DataConstr c tys+dictTransDataConstr (RecordConstr c _ tys) =+  dictTransDataConstr $ DataConstr c tys++-- For the same reason as in 'bindClassEntities' it is safe to use 'fromMaybe 0'+-- in 'dictTransClassMethod'. Note that type classes are removed anyway in the+-- cleanup phase.++dictTransClassMethod :: ClassMethod -> ClassMethod+dictTransClassMethod (ClassMethod f a pty) = ClassMethod f a' $ predType ty+  where a' = Just $ fromMaybe 0 a + arrowArity ty - arrowArity (unpredType pty)+        ty = transformPredType pty++dictTransValues :: ValueEnv -> ValueEnv+dictTransValues = fmap dictTransValueInfo++dictTransValueInfo :: ValueInfo -> ValueInfo+dictTransValueInfo (DataConstructor c a ls (ForAll n pty)) =+  DataConstructor c a' ls' $ ForAll n $ predType ty+  where a'  = arrowArity ty+        ls' = replicate (a' - a) anonId ++ ls+        ty  = transformPredType pty+dictTransValueInfo (NewtypeConstructor c l (ForAll n pty)) =+  NewtypeConstructor c l (ForAll n (predType (unpredType pty)))+dictTransValueInfo (Value f cm a (ForAll n pty)) =+  Value f Nothing a' $ ForAll n $ predType ty+  where a' = a + if isJust cm then 1 else arrowArity ty - arrowArity (unpredType pty)+        ty = transformPredType pty+dictTransValueInfo (Label l cs (ForAll n pty)) =+  Label l cs $ ForAll n $ predType $ unpredType pty++-- -----------------------------------------------------------------------------+-- Adding exports+-- -----------------------------------------------------------------------------++addExports :: Maybe ExportSpec -> [Export] -> Maybe ExportSpec+addExports (Just (Exporting p es)) es' = Just $ Exporting p $ es ++ es'+addExports Nothing                 _   = internalError "Dictionary.addExports"++dictExports :: Decl a -> DTM [Export]+dictExports (ClassDecl _ _ _ cls _ _) = do+  m <- getModuleIdent+  clsEnv <- getClassEnv+  return $ classExports m clsEnv cls+dictExports (InstanceDecl _ _ _ cls ty _) = do+  m <- getModuleIdent+  clsEnv <- getClassEnv+  return $ instExports m clsEnv cls (toType [] ty)+dictExports _ = return []++classExports :: ModuleIdent -> ClassEnv -> Ident -> [Export]+classExports m clsEnv cls =+  ExportTypeWith NoSpanInfo (qDictTypeId qcls) [dictConstrId qcls] :+   map (Export NoSpanInfo . qSuperDictStubId qcls) (superClasses qcls clsEnv) +++    map (Export NoSpanInfo . qDefaultMethodId qcls) (classMethods qcls clsEnv)+  where qcls = qualifyWith m cls++instExports :: ModuleIdent -> ClassEnv -> QualIdent -> Type -> [Export]+instExports m clsEnv cls ty =+  Export NoSpanInfo (qInstFunId m cls ty) :+    map (Export NoSpanInfo . qImplMethodId m cls ty) (classMethods cls clsEnv)++-- -----------------------------------------------------------------------------+-- Transforming the module+-- -----------------------------------------------------------------------------++type DictEnv = [(Pred, Expression Type)]++emptyDictEnv :: DictEnv+emptyDictEnv = []++class DictTrans a where+  dictTrans :: a PredType -> DTM (a Type)++instance DictTrans Module where+  dictTrans (Module spi li ps m es is ds) = do+    liftedDs <- concatMapM liftDecls ds+    stubDs <- concatMapM createStubs ds+    tcEnv <- getTyConsEnv+    clsEnv <- getClassEnv+    inEnv <- getInstEnv+    modifyValueEnv $ bindClassDecls m tcEnv clsEnv+    modifyValueEnv $ bindInstDecls m tcEnv clsEnv inEnv+    modifyTyConsEnv $ bindDictTypes m clsEnv+    transDs <- mapM dictTrans liftedDs+    modifyValueEnv $ dictTransValues+    modifyTyConsEnv $ dictTransTypes+    dictEs <- addExports es <$> concatMapM dictExports ds+    return $ Module spi li ps m dictEs is $ transDs ++ stubDs++-- We use and transform the type from the type constructor environment for+-- transforming a constructor declaration as it contains the reduced and+-- restricted predicate set for each data constructor.++-- The pattern declaration case of the DictTrans Decl instance converts+-- variable declarations with an overloaded type into function declarations.+-- This is necessary so that the compiler can add the implicit dictionary+-- arguments to the declaration.++instance DictTrans Decl where+  dictTrans (InfixDecl      p fix prec ops) = return $ InfixDecl p fix prec ops+  dictTrans (DataDecl        p tc tvs cs _) = do+    m <- getModuleIdent+    tcEnv <- getTyConsEnv+    let DataType _ _ cs' = head $ qualLookupTypeInfo (qualifyWith m tc) tcEnv+    return $ DataDecl p tc tvs (zipWith (dictTransConstrDecl tvs) cs cs') []+  dictTrans (ExternalDataDecl     p tc tvs) = return $ ExternalDataDecl p tc tvs+  dictTrans (NewtypeDecl     p tc tvs nc _) =+    return $ NewtypeDecl p tc tvs nc []+  dictTrans (TypeDecl          p tc tvs ty) = return $ TypeDecl p tc tvs ty+  dictTrans (FunctionDecl p      pty f eqs) =+    FunctionDecl p (transformPredType pty) f <$> mapM dictTrans eqs+  dictTrans (PatternDecl           p t rhs) = case t of+    VariablePattern _ pty@(PredType ps _) v | not (Set.null ps) ->+      dictTrans $ FunctionDecl p pty v [Equation p (FunLhs NoSpanInfo v []) rhs]+    _ -> withLocalDictEnv $ PatternDecl p <$> dictTrans t <*> dictTrans rhs+  dictTrans d@(FreeDecl                _ _) = return $ fmap unpredType d+  dictTrans d@(ExternalDecl            _ _) = return $ fmap transformPredType d+  dictTrans d                               =+    internalError $ "Dictionary.dictTrans: " ++ show d++dictTransConstrDecl :: [Ident] -> ConstrDecl -> DataConstr -> ConstrDecl+dictTransConstrDecl tvs (ConstrDecl p c tes) dc =+  ConstrDecl p c $ map (fromType $ tvs ++ bvs) (constrTypes dc)+  where bvs = nub $ bv tes+dictTransConstrDecl tvs (ConOpDecl p ty1 op ty2) dc =+  dictTransConstrDecl tvs (ConstrDecl p op [ty1, ty2]) dc+dictTransConstrDecl _ d _ = internalError $ "Dictionary.dictTrans: " ++ show d++instance DictTrans Equation where+  dictTrans (Equation p (FunLhs _ f ts) rhs) = withLocalValueEnv $ do+    m <- getModuleIdent+    pls <- matchPredList (varType m f) $+             foldr (TypeArrow . typeOf) (typeOf rhs) ts+    ts' <- addDictArgs pls ts+    modifyValueEnv $ bindPatterns ts'+    Equation p (FunLhs NoSpanInfo f ts') <$> dictTrans rhs+  dictTrans eq                             =+    internalError $ "Dictionary.dictTrans: " ++ show eq++instance DictTrans Rhs where+  dictTrans (SimpleRhs p _ e []) = simpleRhs p <$> dictTrans e+  dictTrans rhs                  =+    internalError $ "Dictionary.dictTrans: " ++ show rhs++instance DictTrans Pattern where+  dictTrans (LiteralPattern        _ pty l) =+    return $ LiteralPattern NoSpanInfo (unpredType pty) l+  dictTrans (VariablePattern       _ pty v) =+    return $ VariablePattern NoSpanInfo (unpredType pty) v+  dictTrans (ConstructorPattern _ pty c ts) = do+    pls <- matchPredList (conType c) $+             foldr (TypeArrow . typeOf) (unpredType pty) ts+    ConstructorPattern NoSpanInfo (unpredType pty) c <$> addDictArgs pls ts+  dictTrans (AsPattern               _ v t) =+    AsPattern NoSpanInfo v <$> dictTrans t+  dictTrans t                               =+    internalError $ "Dictionary.dictTrans: " ++ show t++instance DictTrans Expression where+  dictTrans (Literal     _ pty l) =+    return $ Literal NoSpanInfo (unpredType pty) l+  dictTrans (Variable    _ pty v) = do+    pls <- matchPredList (funType v) (unpredType pty)+    es <- mapM dictArg pls+    let ty = foldr (TypeArrow . typeOf) (unpredType pty) es+    return $ apply (Variable NoSpanInfo ty v) es+  dictTrans (Constructor _ pty c) = do+    pls <- matchPredList (conType c) (unpredType pty)+    es <- mapM dictArg pls+    let ty = foldr (TypeArrow . typeOf) (unpredType pty) es+    return $ apply (Constructor NoSpanInfo ty c) es+  dictTrans (Apply       _ e1 e2) =+    Apply NoSpanInfo <$> dictTrans e1 <*> dictTrans e2+  dictTrans (Typed       _ e qty) =+    Typed NoSpanInfo <$> dictTrans e <*> dictTransQualTypeExpr qty+  dictTrans (Lambda       _ ts e) = withLocalValueEnv $ withLocalDictEnv $ do+    ts' <- mapM dictTrans ts+    modifyValueEnv $ bindPatterns ts'+    mkLambda ts' <$> dictTrans e+  dictTrans (Let        _ _ ds e) = withLocalValueEnv $ do+    modifyValueEnv $ bindDecls ds+    mkLet <$> mapM dictTrans ds <*> dictTrans e+  dictTrans (Case    _ _ ct e as) =+    mkCase ct <$> dictTrans e <*> mapM dictTrans as+  dictTrans e                   =+    internalError $ "Dictionary.dictTrans: " ++ show e++-- Just like before in desugaring, we ignore the context in the type signature+-- of a typed expression, since there should be no possibility to provide an+-- non-empty context without scoped type-variables.+-- TODO: Verify++dictTransQualTypeExpr :: QualTypeExpr -> DTM QualTypeExpr+dictTransQualTypeExpr (QualTypeExpr spi _ ty) = return $ QualTypeExpr spi [] ty++instance DictTrans Alt where+  dictTrans (Alt p t rhs) = withLocalValueEnv $ withLocalDictEnv $ do+    t' <- dictTrans t+    modifyValueEnv $ bindPattern t'+    Alt p t' <$> dictTrans rhs++addDictArgs :: [Pred] -> [Pattern PredType] -> DTM [Pattern Type]+addDictArgs pls ts = do+  dictVars <- mapM (freshVar "_#dict" . rtDictType) pls+  clsEnv <- getClassEnv+  modifyDictEnv $ (++) $ dicts clsEnv $ zip pls (map (uncurry mkVar) dictVars)+  (++) (map (uncurry (VariablePattern NoSpanInfo )) dictVars)+         <$> mapM dictTrans ts+  where dicts clsEnv vs+          | null vs = vs+          | otherwise = vs ++ dicts clsEnv (concatMap (superDicts clsEnv) vs)+        superDicts clsEnv (Pred cls ty, e) =+          map (superDict cls ty e) (superClasses cls clsEnv)+        superDict cls ty e scls =+          (Pred scls ty, Apply NoSpanInfo (superDictExpr cls scls ty) e)+        superDictExpr cls scls ty =+          Variable NoSpanInfo (superDictStubType cls scls ty)+            (qSuperDictStubId cls scls)++-- The function 'dictArg' constructs the dictionary argument for a predicate+-- from the predicates of a class method or an overloaded function. It checks+-- whether a dictionary for the predicate is available in the dictionary+-- environment, which is the case when the predicate's type is a type variable,+-- and uses 'instDict' otherwise in order to supply a new dictionary using the+-- appropriate instance dictionary construction function. If the corresponding+-- instance declaration has a non-empty context, the dictionary construction+-- function is applied to the dictionaries computed for the context instantiated+-- at the appropriate types.++dictArg :: Pred -> DTM (Expression Type)+dictArg p = maybeM (instDict p) return (lookup p <$> getDictEnv)++instDict :: Pred -> DTM (Expression Type)+instDict p = instPredList p >>= flip (uncurry instFunApp) p++instFunApp :: ModuleIdent -> [Pred] -> Pred -> DTM (Expression Type)+instFunApp m pls p@(Pred cls ty) = apply (Variable NoSpanInfo ty' f)+  <$> mapM dictArg pls+  where f   = qInstFunId m cls ty+        ty' = foldr1 TypeArrow $ map rtDictType $ pls ++ [p]++instPredList :: Pred -> DTM (ModuleIdent, [Pred])+instPredList (Pred cls ty) = case unapplyType True ty of+  (TypeConstructor tc, tys) -> do+    inEnv <- getInstEnv+    case lookupInstInfo (cls, tc) inEnv of+      Just (m, ps, _) -> return (m, expandAliasType tys $ Set.toAscList ps)+      Nothing -> internalError $ "Dictionary.instPredList: " ++ show (cls, tc)+  _ -> internalError $ "Dictionary.instPredList: " ++ show ty++-- When adding dictionary arguments on the left hand side of an equation and+-- in applications, respectively, the compiler must unify the function's type+-- with the concrete instance at which that type is used in order to determine+-- the correct context.++-- Polymorphic methods make things a little bit more complicated. When an+-- instance dictionary constructor is applied to an instance method, the+-- suffix of the instance method type's context that corresponds to the+-- additional constraints of the type class method must be discarded and+-- no dictionaries must be added for these constraints. Unfortunately, the+-- dictionary transformation has already been applied to the component types+-- of the dictionary constructor. Therefore, the function 'matchPredList'+-- tries to find a suffix of the context whose transformation matches the+-- initial arrows of the instance type.++matchPredList :: (ValueEnv -> TypeScheme) -> Type -> DTM [Pred]+matchPredList tySc ty2 = do+  ForAll _ (PredType ps ty1) <- tySc <$> getValueEnv+  return $ foldr (\(pls1, pls2) pls' ->+                   fromMaybe pls' $ qualMatch pls1 ty1 pls2 ty2)+                 (internalError $ "Dictionary.matchPredList: " ++ show ps)+                 (splits $ Set.toAscList ps)++qualMatch :: [Pred] -> Type -> [Pred] -> Type -> Maybe [Pred]+qualMatch pls1 ty1 pls2 ty2 = case predListMatch pls2 ty2 of+  Just ty2' -> Just $ subst (matchType ty1 ty2' idSubst) pls1+  Nothing -> Nothing++predListMatch :: [Pred] -> Type -> Maybe Type+predListMatch []     ty = Just ty+predListMatch (p:ps) ty = case ty of+  TypeForall _ ty'                                 -> predListMatch (p : ps) ty'+  TypeArrow ty1 ty2 | ty1 == rtDictType (instPred p) -> predListMatch ps ty2+  _                                                -> Nothing++splits :: [a] -> [([a], [a])]+splits xs = zip (inits xs) (tails xs)++-- -----------------------------------------------------------------------------+-- Optimizing method calls+-- -----------------------------------------------------------------------------++-- Whenever a type class method is applied at a known type, the compiler can+-- apply the type instance's implementation directly.++type SpecEnv = Map.Map (QualIdent, QualIdent) QualIdent++emptySpEnv :: SpecEnv+emptySpEnv = Map.empty++initSpEnv :: ClassEnv -> InstEnv -> SpecEnv+initSpEnv clsEnv = foldr (uncurry bindInstance) emptySpEnv . Map.toList+  where bindInstance (cls, tc) (m, _, _) =+          flip (foldr $ bindInstanceMethod m cls tc) $ classMethods cls clsEnv+        bindInstanceMethod m cls tc f = Map.insert (f', d) f''+          where f'  = qualifyLike cls f+                d   = qInstFunId m cls ty+                f'' = qImplMethodId m cls ty f+                ty  = TypeConstructor tc++class Specialize a where+  specialize :: a Type -> DTM (a Type)++instance Specialize Module where+  specialize (Module spi li ps m es is ds) = do+    clsEnv <- getClassEnv+    inEnv <- getInstEnv+    setSpEnv $ initSpEnv clsEnv inEnv+    Module spi li ps m es is <$> mapM specialize ds++instance Specialize Decl where+  specialize (FunctionDecl p ty f eqs) =+    FunctionDecl p ty f <$> mapM specialize eqs+  specialize (PatternDecl     p t rhs) = PatternDecl p t <$> specialize rhs+  specialize d                         = return d++instance Specialize Equation where+  specialize (Equation p lhs rhs) = Equation p lhs <$> specialize rhs++instance Specialize Rhs where+  specialize (SimpleRhs p _ e []) = simpleRhs p <$> specialize e+  specialize rhs                  =+    internalError $ "Dictionary.specialize: " ++ show rhs++instance Specialize Expression where+  specialize e = specialize' e []++specialize' :: Expression Type -> [Expression Type] -> DTM (Expression Type)+specialize' l@(Literal     _ _ _) es = return $ apply l es+specialize' v@(Variable   _ _ v') es = do+  spEnv <- getSpEnv+  return $ case Map.lookup (v', f) spEnv of+    Just f' -> apply (Variable NoSpanInfo ty' f') $ es'' ++ es'+    Nothing -> apply v es+  where d:es' = es+        (Variable _ _ f, es'') = unapply d []+        ty' = foldr (TypeArrow . typeOf) (typeOf $ Apply NoSpanInfo v d) es''+specialize' c@(Constructor _ _ _) es = return $ apply c es+specialize' (Typed       _ e qty) es = do+  e' <- specialize e+  return $ apply (Typed NoSpanInfo e' qty) es+specialize' (Apply       _ e1 e2) es = do+  e2' <- specialize e2+  specialize' e1 $ e2' : es+specialize' (Lambda       _ ts e) es = do+  e' <- specialize e+  return $ apply (Lambda NoSpanInfo ts e') es+specialize' (Let        _ _ ds e) es = do+  ds' <- mapM specialize ds+  e' <- specialize e+  return $ apply (mkLet ds' e') es+specialize' (Case    _ _ ct e as) es = do+  e' <- specialize e+  as' <- mapM specialize as+  return $ apply (mkCase ct e' as') es+specialize' e                   _  =+  internalError $ "Dictionary.specialize': " ++ show e++instance Specialize Alt where+  specialize (Alt p t rhs) = Alt p t <$> specialize rhs++-- -----------------------------------------------------------------------------+-- Cleaning up+-- -----------------------------------------------------------------------------++-- After we have transformed the module we have to remove class exports from+-- the export list and type classes from the type constructor environment.+-- Furthermore, we may have to remove some infix declarations and operators+-- from the precedence environment as functions with class constraint have+-- been supplemented with addiontal dictionary arguments during the dictionary+-- transformation.++cleanup :: Module a -> DTM (Module a)+cleanup (Module spi li ps m es is ds) = do+  cleanedEs <- traverse cleanupExportSpec es+  cleanedDs <- concatMapM cleanupInfixDecl ds+  cleanupTyConsEnv+  cleanupPrecEnv+  return $ Module spi li ps m cleanedEs is cleanedDs++cleanupExportSpec :: ExportSpec -> DTM ExportSpec+cleanupExportSpec (Exporting p es) = Exporting p <$> concatMapM cleanupExport es++cleanupExport :: Export -> DTM [Export]+cleanupExport e@(Export             _ _) = return [e]+cleanupExport e@(ExportTypeWith spi tc cs) = do+  tcEnv <- getTyConsEnv+  case qualLookupTypeInfo tc tcEnv of+    [TypeClass _ _ _] -> return $ map (Export spi . qualifyLike tc) cs+    _                 -> return [e]+cleanupExport e                        =+  internalError $ "Dictionary.cleanupExport: " ++ show e++cleanupInfixDecl :: Decl a -> DTM [Decl a]+cleanupInfixDecl (InfixDecl p fix pr ops) = do+  m <- getModuleIdent+  vEnv <- getValueEnv+  let opArity = arrowArity . rawType . flip opType vEnv . qualifyWith m+      ops' = filter ((== 2) . opArity) ops+  return [InfixDecl p fix pr ops' | not (null ops')]+cleanupInfixDecl d                        = return [d]++cleanupTyConsEnv :: DTM ()+cleanupTyConsEnv = getTyConsEnv >>= mapM_ (cleanupTyCons . fst) . allBindings++cleanupTyCons :: QualIdent -> DTM ()+cleanupTyCons tc = do+  tcEnv <- getTyConsEnv+  case qualLookupTypeInfo tc tcEnv of+    [TypeClass _ _ _] -> modifyTyConsEnv $ qualUnbindTopEnv tc+    _                 -> return ()++cleanupPrecEnv :: DTM ()+cleanupPrecEnv = getPrecEnv >>= mapM_ (cleanupOp . fst) . allBindings++cleanupOp :: QualIdent -> DTM ()+cleanupOp op = do+  opArity <- arrowArity . rawType . opType op <$> getValueEnv+  when (opArity /= 2) $ modifyPrecEnv $ qualUnbindTopEnv op++-- -----------------------------------------------------------------------------+-- Transforming interfaces+-- -----------------------------------------------------------------------------++-- The following functions expect an already transformed value environment.+-- The transformation of interface declarations with it is quite simple and+-- straightforward.++dictTransInterfaces :: ValueEnv -> ClassEnv -> InterfaceEnv -> InterfaceEnv+dictTransInterfaces vEnv clsEnv = fmap $ dictTransInterface vEnv clsEnv++dictTransInterface :: ValueEnv -> ClassEnv -> Interface -> Interface+dictTransInterface vEnv clsEnv (Interface m is ds) =+  Interface m is $ concatMap (dictTransIDecl m vEnv clsEnv) ds++dictTransIDecl :: ModuleIdent -> ValueEnv -> ClassEnv -> IDecl -> [IDecl]+dictTransIDecl m vEnv _      d@(IInfixDecl         _ _ _ op)+  | arrowArity (rawType $ opType (qualQualify m op) vEnv) /= 2 = []+  | otherwise = [d]+dictTransIDecl _ _    _      d@(HidingDataDecl      _ _ _ _) = [d]+dictTransIDecl m _    _      (IDataDecl    p tc k tvs cs hs) =+  [IDataDecl p tc k tvs (map (dictTransIConstrDecl m tvs) cs) hs]+dictTransIDecl _ _    _      d@(INewtypeDecl    _ _ _ _ _ _) = [d]+dictTransIDecl _ _    _      d@(ITypeDecl         _ _ _ _ _) = [d]+dictTransIDecl m vEnv _      (IFunctionDecl       _ f _ _ _) =+  [iFunctionDeclFromValue m vEnv (qualQualify m f)]+dictTransIDecl _ _    _      (HidingClassDecl  p _ cls k tv) =+  [HidingDataDecl p (qDictTypeId cls) (fmap (flip ArrowKind Star) k) [tv]]+dictTransIDecl m vEnv clsEnv (IClassDecl   p _ cls k _ _ hs) =+  dictDecl : defaults ++ methodStubs ++ superDictStubs+  where qcls  = qualQualify m cls+        sclss = superClasses qcls clsEnv+        ms    = classMethods qcls clsEnv+        dictDecl    = IDataDecl p (qDictTypeId cls)+                        (fmap (flip ArrowKind Star) k)+                        [head identSupply] [constrDecl] []+        constrDecl  = iConstrDeclFromDataConstructor m vEnv $ qDictConstrId qcls+        defaults    = map (iFunctionDeclFromValue m vEnv .+                            qDefaultMethodId qcls) ms+        methodStubs = map (iFunctionDeclFromValue m vEnv . qualifyLike qcls) $+                        filter (`notElem` hs) ms+        superDictStubs = map (iFunctionDeclFromValue m vEnv .+                               qSuperDictStubId qcls) sclss+dictTransIDecl m vEnv clsEnv (IInstanceDecl _ _ cls ty _ mm) =+  iFunctionDeclFromValue m vEnv (qInstFunId m' qcls ty') :+    map (iFunctionDeclFromValue m vEnv . qImplMethodId m' qcls ty') ms+  where m'   = fromMaybe m mm+        qcls = qualQualify m cls+        ty'  = toQualType m [] ty+        ms   = classMethods qcls clsEnv++dictTransIConstrDecl :: ModuleIdent -> [Ident] -> ConstrDecl -> ConstrDecl+dictTransIConstrDecl _ _ (ConOpDecl p ty1 op ty2) = ConstrDecl p op [ty1, ty2]+dictTransIConstrDecl _ _ cd                       = cd++iFunctionDeclFromValue :: ModuleIdent -> ValueEnv -> QualIdent -> IDecl+iFunctionDeclFromValue m vEnv f = case qualLookupValue f vEnv of+  [Value _ _ a (ForAll _ pty)] ->+    IFunctionDecl NoPos (qualUnqualify m f) Nothing a $+      fromQualPredType m identSupply pty+  _ -> internalError $ "Dictionary.iFunctionDeclFromValue: " ++ show f++iConstrDeclFromDataConstructor :: ModuleIdent -> ValueEnv -> QualIdent+                               -> ConstrDecl+iConstrDeclFromDataConstructor m vEnv c = case qualLookupValue c vEnv of+  [DataConstructor _ _ _ (ForAll _ pty)] ->+    ConstrDecl NoSpanInfo (unqualify c) tys+    where tys = map (fromQualType m identSupply) $ arrowArgs $ unpredType pty+  _ -> internalError $ "Dictionary.iConstrDeclFromDataConstructor: " ++ show c++-- -----------------------------------------------------------------------------+-- Functions for naming newly created types, functions and parameters+-- -----------------------------------------------------------------------------++dictTypeId :: QualIdent -> Ident+dictTypeId cls = mkIdent $ "_Dict#" ++ idName (unqualify cls)++qDictTypeId :: QualIdent -> QualIdent+qDictTypeId cls = qualifyLike cls $ dictTypeId cls++dictConstrId :: QualIdent -> Ident+dictConstrId = dictTypeId++qDictConstrId :: QualIdent -> QualIdent+qDictConstrId cls = qualifyLike cls $ dictConstrId cls++defaultMethodId :: QualIdent -> Ident -> Ident+defaultMethodId cls f = mkIdent $ "_def#" ++ idName f ++ '#' : qualName cls++qDefaultMethodId :: QualIdent -> Ident -> QualIdent+qDefaultMethodId cls = qualifyLike cls . defaultMethodId cls++superDictStubId :: QualIdent -> QualIdent -> Ident+superDictStubId cls scls = mkIdent $+  "_super#" ++ qualName cls ++ '#' : qualName scls++qSuperDictStubId :: QualIdent -> QualIdent -> QualIdent+qSuperDictStubId cls = qualifyLike cls . superDictStubId cls++instFunId :: QualIdent -> Type -> Ident+instFunId cls ty = mkIdent $+  "_inst#" ++ qualName cls ++ '#' : qualName (rootOfType ty)++qInstFunId :: ModuleIdent -> QualIdent -> Type -> QualIdent+qInstFunId m cls = qualifyWith m . instFunId cls++implMethodId :: QualIdent -> Type -> Ident -> Ident+implMethodId cls ty f = mkIdent $+  "_impl#" ++ idName f ++ '#' : qualName cls ++ '#' : qualName (rootOfType ty)++qImplMethodId :: ModuleIdent -> QualIdent -> Type -> Ident -> QualIdent+qImplMethodId m cls ty = qualifyWith m . implMethodId cls ty++-- -----------------------------------------------------------------------------+-- Generating variables+-- -----------------------------------------------------------------------------++freshVar :: String -> Type -> DTM (Type, Ident)+freshVar name ty = ((,) ty) . mkIdent . (name ++) .  show <$> getNextId++-- -----------------------------------------------------------------------------+-- Auxiliary functions+-- -----------------------------------------------------------------------------++-- The function 'dictType' returns the type of the dictionary corresponding to+-- a particular C-T instance.++rtDictType :: Pred -> Type+rtDictType = TypeArrow unitType . dictType++dictType :: Pred -> Type+dictType (Pred cls ty) = TypeApply (TypeConstructor $ qDictTypeId cls) ty++-- The function 'transformPredType' replaces each predicate with a new+-- dictionary type argument.++transformPredType :: PredType -> Type+transformPredType (PredType ps ty) =+  foldr (TypeArrow . rtDictType) ty $ Set.toList ps++-- The function 'transformMethodPredType' first deletes the implicit class+-- constraint and then transforms the resulting predicated type as above.++transformMethodPredType :: PredType -> Type+transformMethodPredType (PredType ps ty) =+  transformPredType $ PredType (Set.deleteMin ps) ty++-- The function 'generalizeMethodType' generalizes an already transformed+-- method type to a forall type by quantifying all occuring type variables+-- except for the class variable whose index is 0.+generalizeMethodType :: Type -> Type+generalizeMethodType ty+  | null tvs  = ty+  | otherwise = TypeForall tvs ty+  where tvs = nub $ filter (/= 0) $ typeVars ty++instTypeVar :: Int -> Int+instTypeVar tv = -1 - tv++instType :: Type -> Type+instType (TypeConstructor tc) = TypeConstructor tc+instType (TypeVariable    tv) = TypeVariable (instTypeVar tv)+instType (TypeApply  ty1 ty2) = TypeApply (instType ty1) (instType ty2)+instType (TypeArrow  ty1 ty2) = TypeArrow (instType ty1) (instType ty2)+instType (TypeForall  tvs ty) = TypeForall (map instTypeVar tvs) (instType ty)+instType ty = ty++instPred :: Pred -> Pred+instPred (Pred cls ty) = Pred cls (instType ty)++unRenameIdentIf :: Bool -> Ident -> Ident+unRenameIdentIf b = if b then unRenameIdent else id++-- The string for the error message for a class method's default method+-- implementation has to be constructed in its desugared form since the+-- desugaring has already taken place.++preludeError :: Type -> String -> Expression PredType+preludeError a =+  Apply NoSpanInfo (Variable NoSpanInfo+                     (predType (TypeArrow stringType a)) qErrorId) . stringExpr++stringExpr :: String -> Expression PredType+stringExpr = foldr (consExpr . Literal NoSpanInfo (predType charType) . Char)+               nilExpr+  where+  nilExpr = Constructor NoSpanInfo (predType stringType) qNilId+  consExpr = (Apply NoSpanInfo) . (Apply NoSpanInfo)+    (Constructor NoSpanInfo (predType $ consType charType) qConsId)++-- The function 'varType' is able to lookup both local and global identifiers.+-- Since the environments have been qualified before, global declarations are+-- only visible under their original name whereas local declarations are always+-- entered unqualified.++varType :: ModuleIdent -> Ident -> ValueEnv -> TypeScheme+varType m v vEnv = case qualLookupValue (qualify v) vEnv of+  Value _ _ _ tySc : _ -> tySc+  Label _ _   tySc : _ -> tySc+  _ -> case qualLookupValue (qualifyWith m v) vEnv of+    Value _ _ _ tySc : _ -> tySc+    Label _ _   tySc : _ -> tySc+    _ -> internalError $ "Dictionary.varType: " ++ show v++conType :: QualIdent -> ValueEnv -> TypeScheme+conType c vEnv = case qualLookupValue c vEnv of+  [DataConstructor  _ _ _ (ForAll n pty)] -> ForAll n pty+  [NewtypeConstructor _ _ (ForAll n pty)] -> ForAll n pty+  _ -> internalError $ "Dictionary.conType: " ++ show c++funType :: QualIdent -> ValueEnv -> TypeScheme+funType f vEnv = case qualLookupValue f vEnv of+  [Value _ _ _ tySc] -> tySc+  [Label _ _   tySc] -> tySc+  _ -> internalError $ "Dictionary.funType " ++ show f++opType :: QualIdent -> ValueEnv -> TypeScheme+opType op vEnv = case qualLookupValue op vEnv of+  [DataConstructor  _ _ _ (ForAll n pty)] -> ForAll n pty+  [NewtypeConstructor _ _ (ForAll n pty)] -> ForAll n pty+  [Value _ _ _                             tySc] -> tySc+  [Label _ _                               tySc] -> tySc+  _ -> internalError $ "Dictionary.opType " ++ show op
+ src/Transformations/Lift.hs view
@@ -0,0 +1,451 @@+{- |+    Module      :  $Header$+    Description :  Lifting of lambda-expressions and local functions+    Copyright   :  (c) 2001 - 2003 Wolfgang Lux+                       2011 - 2015 Björn Peemöller+                       2016 - 2017 Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++   After desugaring and simplifying the code, the compiler lifts all local+   function declarations to the top-level keeping only local variable+   declarations. The algorithm used here is similar to Johnsson's, consisting+   of two phases. First, we abstract each local function declaration,+   adding its free variables as initial parameters and update all calls+   to take these variables into account. Second, all local function+   declarations are collected and lifted to the top-level.+-}+{-# LANGUAGE CPP #-}+module Transformations.Lift (lift) where++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative        ((<$>), (<*>))+#endif+import           Control.Arrow              (first)+import qualified Control.Monad.State as S   (State, runState, gets, modify)+import           Data.List+import qualified Data.Map            as Map (Map, empty, insert, lookup)+import           Data.Maybe                 (mapMaybe, fromJust)+import qualified Data.Set            as Set (fromList, toList, unions)++import Curry.Base.Ident+import Curry.Base.SpanInfo+import Curry.Syntax++import Base.AnnotExpr+import Base.Expr+import Base.Messages                        (internalError)+import Base.SCC+import Base.Types+import Base.TypeSubst+import Base.Typing+import Base.Utils++import Env.Value++lift :: ValueEnv -> Module Type -> (Module Type, ValueEnv)+lift vEnv (Module spi li ps m es is ds) = (lifted, valueEnv s')+  where+  (ds', s') = S.runState (mapM (absDecl "" []) ds) initState+  initState = LiftState m vEnv Map.empty+  lifted    = Module spi li ps m es is $ concatMap liftFunDecl ds'++-- -----------------------------------------------------------------------------+-- Abstraction+-- -----------------------------------------------------------------------------++-- Besides adding the free variables to every (local) function, the+-- abstraction pass also has to update the type environment in order to+-- reflect the new types of the abstracted functions. As usual, we use a+-- state monad transformer in order to pass the type environment+-- through. The environment constructed in the abstraction phase maps+-- each local function declaration onto its replacement expression,+-- i.e. the function applied to its free variables. In order to generate+-- correct type annotations for an inserted replacement expression, we also+-- save a function's original type. The original type is later unified with+-- the concrete type of the replaced expression to obtain a type substitution+-- which is then applied to the replacement expression.++type AbstractEnv = Map.Map Ident (Expression Type, Type)++data LiftState = LiftState+  { moduleIdent :: ModuleIdent+  , valueEnv    :: ValueEnv+  , abstractEnv :: AbstractEnv+  }++type LiftM a = S.State LiftState a++getModuleIdent :: LiftM ModuleIdent+getModuleIdent = S.gets moduleIdent++getValueEnv :: LiftM ValueEnv+getValueEnv = S.gets valueEnv++modifyValueEnv :: (ValueEnv -> ValueEnv) -> LiftM ()+modifyValueEnv f = S.modify $ \s -> s { valueEnv = f $ valueEnv s }++getAbstractEnv :: LiftM AbstractEnv+getAbstractEnv = S.gets abstractEnv++withLocalAbstractEnv :: AbstractEnv -> LiftM a -> LiftM a+withLocalAbstractEnv ae act = do+  old <- getAbstractEnv+  S.modify $ \s -> s { abstractEnv = ae }+  res <- act+  S.modify $ \s -> s { abstractEnv = old }+  return res++absDecl :: String -> [Ident] -> Decl Type -> LiftM (Decl Type)+absDecl _   lvs (FunctionDecl p ty f eqs) = FunctionDecl p ty f+                                            <$> mapM (absEquation lvs) eqs+absDecl pre lvs (PatternDecl     p t rhs) = PatternDecl p t+                                            <$> absRhs pre lvs rhs+absDecl _   _   d                         = return d++absEquation :: [Ident] -> Equation Type -> LiftM (Equation Type)+absEquation lvs (Equation p lhs@(FunLhs _ f ts) rhs) =+  Equation p lhs <$> absRhs (idName f ++ ".") lvs' rhs+  where lvs' = lvs ++ bv ts+absEquation _ _ = error "Lift.absEquation: no pattern match"++absRhs :: String -> [Ident] -> Rhs Type -> LiftM (Rhs Type)+absRhs pre lvs (SimpleRhs p _ e _) = simpleRhs p <$> absExpr pre lvs e+absRhs _   _   _                   = error "Lift.absRhs: no simple RHS"++-- Within a declaration group we have to split the list of declarations+-- into the function and value declarations. Only the function+-- declarations are affected by the abstraction algorithm; the value+-- declarations are left unchanged except for abstracting their right+-- hand sides.++-- The abstraction of a recursive declaration group is complicated by the+-- fact that not all functions need to call each in a recursive+-- declaration group. E.g., in the following example neither 'g' nor 'h'+-- call each other.+--+--   f = g True+--     where x = h 1+--           h z = y + z+--           y = g False+--           g z = if z then x else 0+--+-- Because of this fact, 'g' and 'h' can be abstracted separately by adding+-- only 'y' to 'h' and 'x' to 'g'. On the other hand, in the following example+--+--   f x y = g 4+--     where g p = h p + x+--           h q = k + y + q+--           k = g x+--+-- the local function 'g' uses 'h', so the free variables+-- of 'h' have to be added to 'g' as well. However, because+-- 'h' does not call 'g' it is sufficient to add only+-- 'k' and 'y' (and not 'x') to its definition. We handle this by computing+-- the dependency graph between the functions and splitting this graph into+-- its strongly connected components. Each component is then processed+-- separately, adding the free variables in the group to its functions.++-- We have to be careful with local declarations within desugared case+-- expressions. If some of the cases have guards, e.g.,+--+--   case e of+--     x | x < 1 -> 1+--     x -> let double y = y * y in double x+--+-- the desugarer at present may duplicate code. While there is no problem+-- with local variable declaration being duplicated, we must avoid to+-- lift local function declarations more than once. Therefore+-- 'absFunDecls' transforms only those function declarations+-- that have not been lifted and discards the other declarations. Note+-- that it is easy to check whether a function has been lifted by+-- checking whether an entry for its transformed name is present+-- in the value environment.++absDeclGroup :: String -> [Ident] -> [Decl Type] -> Expression Type+             -> LiftM (Expression Type)+absDeclGroup pre lvs ds e = do+  m <- getModuleIdent+  absFunDecls pre lvs' (scc bv (qfv m) fds) vds e+  where lvs' = lvs ++ bv vds+        (fds, vds) = partition isFunDecl ds++absFunDecls :: String -> [Ident] -> [[Decl Type]] -> [Decl Type]+            -> Expression Type -> LiftM (Expression Type)+absFunDecls pre lvs []         vds e = do+  vds' <- mapM (absDecl pre lvs) vds+  e' <- absExpr pre lvs e+  return (mkLet vds' e')+absFunDecls pre lvs (fds:fdss) vds e = do+  m <- getModuleIdent+  env <- getAbstractEnv+  vEnv <- getValueEnv+  let -- defined functions+      fs      = bv fds+      -- function types+      ftys    = map extractFty fds+      extractFty (FunctionDecl _ _ f (Equation _ (FunLhs _ _ ts) rhs : _)) =+        (f, foldr TypeArrow (typeOf rhs) $ map typeOf ts)+      extractFty _                                                         =+        internalError "Lift.absFunDecls.extractFty"+      -- typed free variables on the right-hand sides+      fvsRhs  = Set.unions+                  [ Set.fromList (filter (not . isDummyType . fst)+                                         (maybe [(ty, v)]+                                                (qafv' ty)+                                                (Map.lookup v env)))+                  | (ty, v) <- concatMap (qafv m) fds ]+      -- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!+      -- !!! HACK: When calculating the typed free variables on the     !!!+      -- !!! right-hand side, we have to filter out the ones annotated  !!!+      -- !!! with dummy types (see below). Additionally, we have to be  !!!+      -- !!! careful when we calculate the typed free variables in a    !!!+      -- !!! replacement expression: We have to unify the original      !!!+      -- !!! function type with the instantiated function type in order !!!+      -- !!! to obtain a type substitution that can then be applied to  !!!+      -- !!! the typed free variables in the replacement expression.    !!!+      -- !!! This is analogous to the procedure when inserting a        !!!+      -- !!! replacement expression with a correct type annotation      !!!+      -- !!! (see 'absType' in 'absExpr' below).                        !!!+      -- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!+      qafv' ty (re, fty) =+        let unifier = matchType fty ty idSubst+        in  map (\(ty', v) -> (subst unifier ty', v)) $ qafv m re+      -- free variables that are local+      fvs     = filter ((`elem` lvs) . snd) (Set.toList fvsRhs)+      -- extended abstraction environment+      env'    = foldr bindF env fs+      -- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!+      -- !!! HACK: Since we do not know how to annotate the function    !!!+      -- !!! call within the replacement expression until the replace-  !!!                          !!!+      -- !!! ment expression is actually inserted (see 'absType' in     !!!+      -- !!! 'absExpr' below), we use a dummy type for this. In turn,   !!!+      -- !!! this dummy type has to be filtered out when calculating    !!!+      -- !!! the typed free variables on right-hand sides (see above).  !!!                                             !!!+      -- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!+      bindF f =+        Map.insert f ( apply (mkFun m pre dummyType f) (map (uncurry mkVar) fvs)+                     , fromJust $ lookup f ftys )+      -- newly abstracted functions+      fs'     = filter (\f -> null $ lookupValue (liftIdent pre f) vEnv) fs+  withLocalAbstractEnv env' $ do+    -- add variables to functions+    fds' <- mapM (absFunDecl pre fvs lvs) [d | d <- fds, any (`elem` fs') (bv d)]+    -- abstract remaining declarations+    e'   <- absFunDecls pre lvs fdss vds e+    return (mkLet fds' e')++-- When the free variables of a function are abstracted, the type of the+-- function must be changed as well.++absFunDecl :: String -> [(Type, Ident)] -> [Ident] -> Decl Type+           -> LiftM (Decl Type)+absFunDecl pre fvs lvs (FunctionDecl p _ f eqs) = do+  m <- getModuleIdent+  d <- absDecl pre lvs $ FunctionDecl p undefined f' eqs'+  let FunctionDecl _ _ _ eqs'' = d+  modifyValueEnv $ bindGlobalInfo+    (\qf tySc -> Value qf Nothing (eqnArity $ head eqs') tySc) m f' $+                 polyType ty''+  return $ FunctionDecl p ty'' f' eqs''+  where f' = liftIdent pre f+        ty' = foldr TypeArrow (typeOf rhs') (map typeOf ts')+          where Equation _ (FunLhs _ _ ts') rhs' = head eqs'+        ty'' = genType ty'+        eqs' = map addVars eqs+        genType ty''' = subst (foldr2 bindSubst idSubst tvs tvs') ty'''+          where tvs = nub (typeVars ty''')+                tvs' = map TypeVariable [0 ..]+        addVars (Equation p' (FunLhs _ _ ts) rhs) =+          Equation p' (FunLhs NoSpanInfo+            f' (map (uncurry (VariablePattern NoSpanInfo)) fvs ++ ts)) rhs+        addVars _ = error "Lift.absFunDecl.addVars: no pattern match"+absFunDecl pre _ _ (ExternalDecl p vs) = ExternalDecl p <$> mapM (absVar pre) vs+absFunDecl _ _ _ _ = error "Lift.absFunDecl: no pattern match"++absVar :: String -> Var Type -> LiftM (Var Type)+absVar pre (Var ty f) = do+  m <- getModuleIdent+  modifyValueEnv $ bindGlobalInfo+    (\qf tySc -> Value qf Nothing (arrowArity ty) tySc) m f' $ polyType ty+  return $ Var ty f'+  where f' = liftIdent pre f++absExpr :: String -> [Ident] -> Expression Type -> LiftM (Expression Type)+absExpr _   _   l@(Literal     _ _ _) = return l+absExpr pre lvs var@(Variable _ ty v)+  | isQualified v = return var+  | otherwise     = do+    getAbstractEnv >>= \env -> case Map.lookup (unqualify v) env of+      Nothing       -> return var+      Just (e, fty) -> let unifier = matchType fty ty idSubst+                       in  absExpr pre lvs $ fmap (subst unifier) $ absType ty e+  where -- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!+        -- !!! HACK: When inserting the replacement expression for an     !!!+        -- !!! abstracted function, we have to unify the original         !!!+        -- !!! function type with the instantiated function type in order !!!+        -- !!! to obtain a type substitution that can then be applied to  !!!+        -- !!! the type annotations in the replacement expression.        !!!+        -- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!+        absType ty' (Variable spi _ v') = Variable spi ty' v'+        absType ty' (Apply   spi e1 e2) =+          Apply spi (absType (TypeArrow (typeOf e2) ty') e1) e2+        absType _ _ = internalError "Lift.absExpr.absType"+absExpr _   _   c@(Constructor _ _ _) = return c+absExpr pre lvs (Apply       spi e1 e2) = Apply spi <$> absExpr pre lvs e1+                                                    <*> absExpr pre lvs e2+absExpr pre lvs (Let          _ _ ds e) = absDeclGroup pre lvs ds e+absExpr pre lvs (Case      _ _ ct e bs) =+  mkCase ct <$> absExpr pre lvs e <*> mapM (absAlt pre lvs) bs+absExpr pre lvs (Typed        spi e ty) =+  flip (Typed spi) ty <$> absExpr pre lvs e+absExpr _   _   e                   = internalError $ "Lift.absExpr: " ++ show e++absAlt :: String -> [Ident] -> Alt Type -> LiftM (Alt Type)+absAlt pre lvs (Alt p t rhs) = Alt p t <$> absRhs pre lvs' rhs+  where lvs' = lvs ++ bv t++-- -----------------------------------------------------------------------------+-- Lifting+-- -----------------------------------------------------------------------------++-- After the abstraction pass, all local function declarations are lifted+-- to the top-level.++liftFunDecl :: Eq a => Decl a -> [Decl a]+liftFunDecl (FunctionDecl p a f eqs) =+  FunctionDecl p a f eqs' : map renameFunDecl (concat dss')+  where (eqs', dss') = unzip $ map liftEquation eqs+liftFunDecl d                        = [d]++liftVarDecl :: Eq a => Decl a -> (Decl a, [Decl a])+liftVarDecl (PatternDecl   p t rhs) = (PatternDecl p t rhs', ds')+  where (rhs', ds') = liftRhs rhs+liftVarDecl ex@(FreeDecl       _ _) = (ex, [])+liftVarDecl _ = error "Lift.liftVarDecl: no pattern match"++liftEquation :: Eq a => Equation a -> (Equation a, [Decl a])+liftEquation (Equation p lhs rhs) = (Equation p lhs rhs', ds')+  where (rhs', ds') = liftRhs rhs++liftRhs :: Eq a => Rhs a -> (Rhs a, [Decl a])+liftRhs (SimpleRhs p _ e _) = first (simpleRhs p) (liftExpr e)+liftRhs _                   = error "Lift.liftRhs: no pattern match"++liftDeclGroup :: Eq a => [Decl a] -> ([Decl a], [Decl a])+liftDeclGroup ds = (vds', concat (map liftFunDecl fds ++ dss'))+  where (fds , vds ) = partition isFunDecl ds+        (vds', dss') = unzip $ map liftVarDecl vds++liftExpr :: Eq a => Expression a -> (Expression a, [Decl a])+liftExpr l@(Literal     _ _ _) = (l, [])+liftExpr v@(Variable    _ _ _) = (v, [])+liftExpr c@(Constructor _ _ _) = (c, [])+liftExpr (Apply       spi e1 e2) = (Apply spi e1' e2', ds1 ++ ds2)+  where (e1', ds1) = liftExpr e1+        (e2', ds2) = liftExpr e2+liftExpr (Let        _ _ ds e) = (mkLet ds' e', ds1 ++ ds2)+  where (ds', ds1) = liftDeclGroup ds+        (e' , ds2) = liftExpr e+liftExpr (Case    _ _ ct e alts) = (mkCase ct e' alts', concat $ ds' : dss')+  where (e'   , ds' ) = liftExpr e+        (alts', dss') = unzip $ map liftAlt alts+liftExpr (Typed        spi e ty) =+  (Typed spi e' ty, ds) where (e', ds) = liftExpr e+liftExpr _ = internalError "Lift.liftExpr"++liftAlt :: Eq a => Alt a -> (Alt a, [Decl a])+liftAlt (Alt p t rhs) = (Alt p t rhs', ds') where (rhs', ds') = liftRhs rhs++-- -----------------------------------------------------------------------------+-- Renaming+-- -----------------------------------------------------------------------------++-- After all local function declarations have been lifted to top-level, we+-- may have to rename duplicate function arguments. Due to polymorphic let+-- declarations it could happen that an argument was added multiple times+-- instantiated with different types during the abstraction pass beforehand.++type RenameMap a = [((a, Ident), Ident)]++renameFunDecl :: Eq a => Decl a -> Decl a+renameFunDecl (FunctionDecl p a f eqs) =+  FunctionDecl p a f (map renameEquation eqs)+renameFunDecl d                        = d++renameEquation :: Eq a => Equation a -> Equation a+renameEquation (Equation p lhs rhs) = Equation p lhs' (renameRhs rm rhs)+  where (rm, lhs') = renameLhs lhs++renameLhs :: Eq a => Lhs a -> (RenameMap a, Lhs a)+renameLhs (FunLhs spi f ts) = (rm, FunLhs spi f ts')+  where (rm, ts') = foldr renamePattern ([], []) ts+renameLhs _             = error "Lift.renameLhs"++renamePattern :: Eq a => Pattern a -> (RenameMap a, [Pattern a])+              -> (RenameMap a, [Pattern a])+renamePattern (VariablePattern spi a v) (rm, ts)+  | v `elem` varPatNames ts =+    let v' = updIdentName (++ ("." ++ show (length rm))) v+    in  (((a, v), v') : rm, VariablePattern spi a v' : ts)+renamePattern t                     (rm, ts) = (rm, t : ts)++renameRhs :: Eq a => RenameMap a -> Rhs a -> Rhs a+renameRhs rm (SimpleRhs p _ e _) = simpleRhs p (renameExpr rm e)+renameRhs _  _                   = error "Lift.renameRhs"++renameExpr :: Eq a => RenameMap a -> Expression a -> Expression a+renameExpr _  l@(Literal       _ _ _) = l+renameExpr rm v@(Variable   spi a v')+  | isQualified v' = v+  | otherwise      = case lookup (a, unqualify v') rm of+                       Just v'' -> Variable spi a (qualify v'')+                       _        -> v+renameExpr _  c@(Constructor _ _ _) = c+renameExpr rm (Typed       spi e ty) = Typed spi (renameExpr rm e) ty+renameExpr rm (Apply       spi e1 e2) =+  Apply spi (renameExpr rm e1) (renameExpr rm e2)+renameExpr rm (Let       _ _ ds e) =+  mkLet (map (renameDecl rm) ds) (renameExpr rm e)+renameExpr rm (Case    _ _ ct e alts) =+  mkCase ct (renameExpr rm e) (map (renameAlt rm) alts)+renameExpr _  _                   = error "Lift.renameExpr"++renameDecl :: Eq a => RenameMap a -> Decl a -> Decl a+renameDecl rm (PatternDecl p t rhs) = PatternDecl p t (renameRhs rm rhs)+renameDecl _  d                     = d++renameAlt :: Eq a => RenameMap a -> Alt a -> Alt a+renameAlt rm (Alt p t rhs) = Alt p t (renameRhs rm rhs)++-- ---------------------------------------------------------------------------+-- Auxiliary definitions+-- ---------------------------------------------------------------------------++isFunDecl :: Decl a -> Bool+isFunDecl (FunctionDecl _ _ _ _) = True+isFunDecl (ExternalDecl _ _    ) = True+isFunDecl _                      = False++mkFun :: ModuleIdent -> String -> a -> Ident -> Expression a+mkFun m pre a = Variable NoSpanInfo a . qualifyWith m . liftIdent pre++liftIdent :: String -> Ident -> Ident+liftIdent prefix x = renameIdent (mkIdent $ prefix ++ showIdent x) $ idUnique x++varPatNames :: [Pattern a] -> [Ident]+varPatNames = mapMaybe varPatName++varPatName :: Pattern a -> Maybe Ident+varPatName (VariablePattern _ _ i) = Just i+varPatName _                     = Nothing++dummyType :: Type+dummyType = TypeForall [] undefined++isDummyType :: Type -> Bool+isDummyType (TypeForall [] _) = True+isDummyType _                 = False
+ src/Transformations/Newtypes.hs view
@@ -0,0 +1,113 @@+{- |+  Module      :  $Header$+  Description :  Removing newtype constructors+  Copyright   :  (c) 2017        Finn Teegen+  License     :  BSD-3-clause++  Maintainer  :  fte@informatik.uni-kiel.de+  Stability   :  experimental+  Portability :  portable++  After inserting dictionaries, the compiler removes all occurences of+  newtype declarations. Applications 'N x' in patterns and expressions,+  where 'N' is a newtype constructor, are replaced by a 'x'. The newtype+  declarations are replaced by type synonyms and partial applications of+  newtype constructors are changed into calls to 'Prelude.id'.+-}+{-# LANGUAGE CPP #-}+module Transformations.Newtypes (removeNewtypes) where++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative        ((<$>), (<*>))+#endif+import qualified Control.Monad.Reader as R++import Curry.Base.Ident+import Curry.Syntax++import Base.Messages (internalError)+import Base.Types++import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)++removeNewtypes :: Bool -> ValueEnv -> Module Type -> Module Type+removeNewtypes remNT vEnv mdl+  | remNT     = R.runReader (nt mdl) vEnv+  | otherwise = mdl++type NTM a = R.Reader ValueEnv a++class Show a => Newtypes a where+  nt :: a -> NTM a++instance Newtypes a => Newtypes [a] where+  nt = mapM nt++instance Show a => Newtypes (Module a) where+  nt (Module spi li ps m es is ds) = Module spi li ps m es is <$> mapM nt ds++instance Show a => Newtypes (Decl a) where+  nt d@(InfixDecl       _ _ _ _) = return d+  nt d@(DataDecl      _ _ _ _ _) = return d+  nt d@(ExternalDataDecl  _ _ _) = return d+  nt (NewtypeDecl p tc vs nc []) = return $ TypeDecl p tc vs $ nconstrType nc+  nt d@(TypeDecl        _ _ _ _) = return d+  nt (FunctionDecl    p a f eqs) = FunctionDecl p a f <$> nt eqs+  nt d@(ExternalDecl        _ _) = return d+  nt (PatternDecl       p t rhs) = PatternDecl p <$> nt t <*> nt rhs+  nt d@(FreeDecl            _ _) = return d+  nt d                           = internalError $+    "Newtypes.Newtypes.nt: unexpected declaration: " ++ show d++instance Show a => Newtypes (Equation a) where+  nt (Equation p lhs rhs) = Equation p <$> nt lhs <*> nt rhs++instance Show a => Newtypes (Lhs a) where+  nt (FunLhs spi f ts) = FunLhs spi f <$> nt ts+  nt lhs           = internalError $+    "Newtypes.Newtypes.nt: unexpected left-hand-side: " ++ show lhs++instance Show a => Newtypes (Rhs a) where+  nt (SimpleRhs p li e []) = flip (SimpleRhs p li) [] <$> nt e+  nt rhs                   = internalError $+    "Newtypes.Newtypes.nt: unexpected right-hand-side: " ++ show rhs++instance Show a => Newtypes (Pattern a) where+  nt t@(LiteralPattern        _ _ _) = return t+  nt t@(VariablePattern       _ _ _) = return t+  nt (ConstructorPattern spi a c ts) = case ts of+    [t] -> do+      isNc <- isNewtypeConstr c+      if isNc then nt t+              else ConstructorPattern spi a c <$> ((: []) <$> nt t)+    _   -> ConstructorPattern spi a c <$> mapM nt ts+  nt (AsPattern             spi v t) = AsPattern spi v <$> nt t+  nt t                               = internalError $+    "Newtypes.Newtypes.nt: unexpected pattern: " ++ show t++instance Show a => Newtypes (Expression a) where+  nt e@(Literal   _   _ _) = return e+  nt e@(Variable    _ _ _) = return e+  nt (Constructor spi a c) = do+    isNc <- isNewtypeConstr c+    return $ if isNc then Variable spi a qIdId else Constructor spi a c+  nt (Apply     spi e1 e2) = case e1 of+    Constructor _ _ c -> do+      isNc <- isNewtypeConstr c+      if isNc then nt e2 else Apply spi <$> nt e1 <*> nt e2+    _ -> Apply spi <$> nt e1 <*> nt e2+  nt (Case spi li ct e as) = Case spi li ct <$> nt e <*> mapM nt as+  nt (Let     spi li ds e) = Let spi li <$> nt ds <*> nt e+  nt (Typed     spi e qty) = flip (Typed spi) qty <$> nt e+  nt e                 = internalError $+    "Newtypes.Newtypes.nt: unexpected expression: " ++ show e++instance Show a => Newtypes (Alt a) where+  nt (Alt p t rhs) = Alt p <$> nt t <*> nt rhs++isNewtypeConstr :: QualIdent -> NTM Bool+isNewtypeConstr c = R.ask >>= \vEnv -> return $+  case qualLookupValue c vEnv of+    [NewtypeConstructor _ _ _] -> True+    [DataConstructor  _ _ _ _] -> False+    _ -> internalError $ "Newtypes.isNewtypeConstr: " ++ show c
+ src/Transformations/Qual.hs view
@@ -0,0 +1,250 @@+{- |+    Module      :  $Header$+    Description :  Proper Qualification+    Copyright   :  (c) 2001 - 2004 Wolfgang Lux+                       2005        Martin Engelke+                       2011 - 2015 Björn Peemöller+                       2016 - 2017 Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    After checking the module and before starting the translation into the+    intermediate language, the compiler properly qualifies all type+    constructors, data constructors and (global) functions+    occurring in a pattern or expression such that their module prefix+    matches the module of their definition.+    This is done also for functions and constructors declared+    in the current module.+    Only functions and variables declared in local declarations groups+    as well as function arguments remain unchanged.+-}+{-# LANGUAGE CPP #-}+module Transformations.Qual (qual) where++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative       ((<$>), (<*>), pure)+#endif+import qualified Control.Monad.Reader as R (Reader, asks, runReader)+import           Data.Traversable+import           Prelude hiding            (mapM)++import Curry.Base.Ident+import Curry.Syntax++import Base.TopEnv         (origName)++import Env.TypeConstructor (TCEnv   , qualLookupTypeInfo)+import Env.Value           (ValueEnv, qualLookupValue)++data QualEnv = QualEnv+  { moduleIdent :: ModuleIdent+  , tyConsEnv   :: TCEnv+  , valueEnv    :: ValueEnv+  }++type Qual a = a -> R.Reader QualEnv a++qual :: ModuleIdent -> TCEnv -> ValueEnv -> Module a -> Module a+qual m tcEnv tyEnv mdl = R.runReader (qModule mdl) (QualEnv m tcEnv tyEnv)++qModule :: Qual (Module a)+qModule (Module spi li ps m es is ds) = do+  es' <- qExportSpec es+  ds' <- mapM qDecl  ds+  return (Module spi li ps m es' is ds')++qExportSpec :: Qual (Maybe ExportSpec)+qExportSpec Nothing                 = return Nothing+qExportSpec (Just (Exporting p es)) = (Just . Exporting p) <$> mapM qExport es++qExport :: Qual Export+qExport (Export            spi x) = Export spi <$> qIdent x+qExport (ExportTypeWith spi t cs) = flip (ExportTypeWith spi) cs <$> qConstr t+qExport (ExportTypeAll     spi t) = ExportTypeAll spi <$> qConstr t+qExport m@(ExportModule      _ _) = return m++qDecl :: Qual (Decl a)+qDecl i@(InfixDecl             _ _ _ _) = return i+qDecl (DataDecl         p n vs cs clss) = DataDecl p n vs <$>+  mapM qConstrDecl cs <*> mapM qClass clss+qDecl e@(ExternalDataDecl        _ _ _) = return e+qDecl (NewtypeDecl      p n vs nc clss) = NewtypeDecl p n vs <$>+  qNewConstrDecl nc <*> mapM qClass clss+qDecl (TypeDecl              p n vs ty) = TypeDecl p n vs <$> qTypeExpr ty+qDecl (TypeSig                p fs qty) = TypeSig p fs <$> qQualTypeExpr qty+qDecl (FunctionDecl          a p f eqs) = FunctionDecl a p f <$> mapM qEquation eqs+qDecl e@(ExternalDecl              _ _) = return e+qDecl (PatternDecl             p t rhs) = PatternDecl p <$> qPattern t <*> qRhs rhs+qDecl vs@(FreeDecl                 _ _) = return vs+qDecl (DefaultDecl               p tys) = DefaultDecl p <$> mapM qTypeExpr tys+qDecl (ClassDecl     p li cx cls tv ds) = ClassDecl p li <$>+  qContext cx <*> pure cls <*> pure tv <*> mapM qDecl ds+qDecl (InstanceDecl p li cx qcls ty ds) = InstanceDecl p li <$>+  qContext cx <*> qClass qcls <*> qTypeExpr ty <*> mapM qDecl ds++qConstrDecl :: Qual ConstrDecl+qConstrDecl (ConstrDecl p      n tys) =+  ConstrDecl p n <$> mapM qTypeExpr tys+qConstrDecl (ConOpDecl  p ty1 op ty2) =+  ConOpDecl p <$> qTypeExpr ty1 <*> pure op <*> qTypeExpr ty2+qConstrDecl (RecordDecl p       c fs) =+  RecordDecl p c <$> mapM qFieldDecl fs++qNewConstrDecl :: Qual NewConstrDecl+qNewConstrDecl (NewConstrDecl p n ty)+  = NewConstrDecl p n <$> qTypeExpr ty+qNewConstrDecl (NewRecordDecl p n (f, ty))+  = (\ty' -> NewRecordDecl p n (f, ty')) <$> qTypeExpr ty++qFieldDecl :: Qual FieldDecl+qFieldDecl (FieldDecl p fs ty) = FieldDecl p fs <$> qTypeExpr ty++qConstraint :: Qual Constraint+qConstraint (Constraint spi cls ty) =+  Constraint spi <$> qClass cls <*> qTypeExpr ty++qContext :: Qual Context+qContext = mapM qConstraint++qTypeExpr :: Qual TypeExpr+qTypeExpr (ConstructorType     spi c) = ConstructorType spi <$> qConstr c+qTypeExpr (ApplyType     spi ty1 ty2) = ApplyType spi <$> qTypeExpr ty1+                                              <*> qTypeExpr ty2+qTypeExpr v@(VariableType        _ _) = return v+qTypeExpr (TupleType         spi tys) = TupleType spi <$> mapM qTypeExpr tys+qTypeExpr (ListType           spi ty) = ListType spi  <$> qTypeExpr ty+qTypeExpr (ArrowType     spi ty1 ty2) = ArrowType spi <$> qTypeExpr ty1+                                              <*> qTypeExpr ty2+qTypeExpr (ParenType          spi ty) = ParenType spi <$> qTypeExpr ty+qTypeExpr (ForallType      spi vs ty) = ForallType spi vs <$> qTypeExpr ty++qQualTypeExpr :: Qual QualTypeExpr+qQualTypeExpr (QualTypeExpr spi cx ty) = QualTypeExpr spi <$> qContext cx+                                                          <*> qTypeExpr ty++qEquation :: Qual (Equation a)+qEquation (Equation p lhs rhs) = Equation p <$> qLhs lhs <*> qRhs rhs++qLhs :: Qual (Lhs a)+qLhs (FunLhs sp    f ts) = FunLhs sp       f  <$> mapM qPattern ts+qLhs (OpLhs sp t1 op t2) = flip (OpLhs sp) op <$> qPattern t1 <*> qPattern t2+qLhs (ApLhs sp   lhs ts) = ApLhs sp           <$> qLhs lhs <*> mapM qPattern ts++qPattern :: Qual (Pattern a)+qPattern l@(LiteralPattern          _ _ _) = return l+qPattern n@(NegativePattern         _ _ _) = return n+qPattern v@(VariablePattern         _ _ _) = return v+qPattern (ConstructorPattern   spi a c ts) =+  ConstructorPattern spi a <$> qIdent c <*> mapM qPattern ts+qPattern (InfixPattern     spi a t1 op t2) =+  InfixPattern spi a <$> qPattern t1 <*> qIdent op <*> qPattern t2+qPattern (ParenPattern              spi t) = ParenPattern spi <$> qPattern t+qPattern (RecordPattern        spi a c fs) = RecordPattern spi a <$> qIdent c+                                          <*> mapM (qField qPattern) fs+qPattern (TuplePattern             spi ts) =+  TuplePattern spi <$> mapM qPattern ts+qPattern (ListPattern            spi a ts) =+  ListPattern spi a <$> mapM qPattern ts+qPattern (AsPattern               spi v t) = AsPattern spi v <$> qPattern t+qPattern (LazyPattern               spi t) = LazyPattern spi <$> qPattern t+qPattern (FunctionPattern      spi a f ts) =+  FunctionPattern spi a <$> qIdent f <*> mapM qPattern ts+qPattern (InfixFuncPattern spi a t1 op t2) =+  InfixFuncPattern spi a <$> qPattern t1 <*> qIdent op <*> qPattern t2++qRhs :: Qual (Rhs a)+qRhs (SimpleRhs spi li e ds) =+  SimpleRhs  spi li <$> qExpr e           <*> mapM qDecl ds+qRhs (GuardedRhs spi li es ds) =+  GuardedRhs spi li <$> mapM qCondExpr es <*> mapM qDecl ds++qCondExpr :: Qual (CondExpr a)+qCondExpr (CondExpr p g e) = CondExpr p <$> qExpr g <*> qExpr e++qExpr :: Qual (Expression a)+qExpr l@(Literal             _ _ _) = return l+qExpr (Variable            spi a v) = Variable     spi a <$> qIdent v+qExpr (Constructor         spi a c) = Constructor  spi a <$> qIdent c+qExpr (Paren                 spi e) = Paren        spi   <$> qExpr e+qExpr (Typed             spi e qty) = Typed        spi   <$> qExpr e+                                                         <*> qQualTypeExpr qty+qExpr (Record           spi a c fs) =+  Record spi a <$> qIdent c <*> mapM (qField qExpr) fs+qExpr (RecordUpdate       spi e fs) =+  RecordUpdate spi <$> qExpr e <*> mapM (qField qExpr) fs+qExpr (Tuple                spi es) = Tuple          spi <$> mapM qExpr es+qExpr (List               spi a es) = List           spi a <$> mapM qExpr es+qExpr (ListCompr          spi e qs) = ListCompr      spi <$> qExpr e+                                                         <*> mapM qStmt qs+qExpr (EnumFrom              spi e) = EnumFrom       spi <$> qExpr e+qExpr (EnumFromThen      spi e1 e2) = EnumFromThen   spi <$> qExpr e1+                                                         <*> qExpr e2+qExpr (EnumFromTo        spi e1 e2) = EnumFromTo     spi <$> qExpr e1+                                                         <*> qExpr e2+qExpr (EnumFromThenTo spi e1 e2 e3) = EnumFromThenTo spi <$> qExpr e1+                                                         <*> qExpr e2+                                                         <*> qExpr e3+qExpr (UnaryMinus            spi e) = UnaryMinus     spi <$> qExpr e+qExpr (Apply             spi e1 e2) = Apply          spi <$> qExpr e1+                                                         <*> qExpr e2+qExpr (InfixApply     spi e1 op e2) = InfixApply     spi <$> qExpr e1+                                                         <*> qInfixOp op+                                                         <*> qExpr e2+qExpr (LeftSection        spi e op) = LeftSection  spi <$> qExpr e+                                                       <*> qInfixOp op+qExpr (RightSection       spi op e) = RightSection spi <$> qInfixOp op+                                                       <*> qExpr e+qExpr (Lambda             spi ts e) = Lambda       spi <$> mapM qPattern ts+                                                       <*> qExpr e+qExpr (Let             spi li ds e) = Let spi li <$> mapM qDecl ds  <*> qExpr e+qExpr (Do             spi li sts e) = Do  spi li <$> mapM qStmt sts <*> qExpr e+qExpr (IfThenElse     spi e1 e2 e3) = IfThenElse spi <$> qExpr e1 <*> qExpr e2+                                                     <*> qExpr e3+qExpr (Case         spi li ct e as) = Case spi li ct <$> qExpr e <*> mapM qAlt as++qStmt :: Qual (Statement a)+qStmt (StmtExpr spi     e) = StmtExpr spi    <$> qExpr e+qStmt (StmtBind spi t   e) = StmtBind spi    <$> qPattern t <*> qExpr e+qStmt (StmtDecl spi li ds) = StmtDecl spi li <$> mapM qDecl ds++qAlt :: Qual (Alt a)+qAlt (Alt p t rhs) = Alt p <$> qPattern t <*> qRhs rhs++qField :: Qual a -> Qual (Field a)+qField q (Field p l x) = Field p <$> qIdent l <*> q x++qInfixOp :: Qual (InfixOp a)+qInfixOp (InfixOp     a op) = InfixOp     a <$> qIdent op+qInfixOp (InfixConstr a op) = InfixConstr a <$> qIdent op++qIdent :: Qual QualIdent+qIdent x | isQualified x                = x'+         | hasGlobalScope (unqualify x) = x'+         | otherwise                    = return x+  where+  x' = do+    m     <- R.asks moduleIdent+    tyEnv <- R.asks valueEnv+    return $ case qualLookupValue x tyEnv of+      [y] -> origName y+      _   -> case qualLookupValue qmx tyEnv of+        [y] -> origName y+        _   -> qmx+        where qmx = qualQualify m x++qConstr :: Qual QualIdent+qConstr x = do+  m     <- R.asks moduleIdent+  tcEnv <- R.asks tyConsEnv+  return $ case qualLookupTypeInfo x tcEnv of+    [y] -> origName y+    _   -> case qualLookupTypeInfo qmx tcEnv of+      [y] -> origName y+      _   -> qmx+      where qmx = qualQualify m x++qClass :: Qual QualIdent+qClass = qConstr
+ src/Transformations/Simplify.hs view
@@ -0,0 +1,347 @@+{- |+    Module      :  $Header$+    Description :  Optimizing the Desugared Code+    Copyright   :  (c) 2003        Wolfgang Lux+                                   Martin Engelke+                       2011 - 2015 Björn Peemöller+                       2016        Finn Teegen+    License     :  BSD-3-clause++    Maintainer  :  bjp@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++   After desugaring the source code, but before lifting local+   declarations, the compiler performs a few simple optimizations to+   improve the efficiency of the generated code. In addition, the+   optimizer replaces pattern bindings with simple variable bindings and+   selector functions.++   Currently, the following optimizations are implemented:++     * Under certain conditions, inline local function definitions.+     * Remove unused declarations.+     * Compute minimal binding groups for let expressions.+     * Remove pattern bindings to constructor terms+     * Inline simple constants.+-}+{-# LANGUAGE CPP #-}+module Transformations.Simplify (simplify) where++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative        ((<$>), (<*>))+#endif+import           Control.Monad.Extra        (concatMapM)+import           Control.Monad.State as S   (State, runState, gets, modify)+import qualified Data.Map            as Map (Map, empty, insert, lookup)++import Curry.Base.Ident+import Curry.Base.SpanInfo+import Curry.Syntax++import Base.Expr+import Base.Messages (internalError)+import Base.SCC+import Base.Types+import Base.Typing+import Base.Utils++import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)++-- -----------------------------------------------------------------------------+-- Simplification+-- -----------------------------------------------------------------------------++simplify :: ValueEnv -> Module Type -> (Module Type, ValueEnv)+simplify vEnv mdl@(Module _ _ _ m _ _ _) = (mdl', valueEnv s')+  where (mdl', s') = S.runState (simModule mdl) (SimplifyState m vEnv 1)++-- -----------------------------------------------------------------------------+-- Internal state monad+-- -----------------------------------------------------------------------------++data SimplifyState = SimplifyState+  { moduleIdent :: ModuleIdent -- read-only!+  , valueEnv    :: ValueEnv    -- updated for new pattern selection functions+  , nextId      :: Int         -- counter+  }++type SIM = S.State SimplifyState++getModuleIdent :: SIM ModuleIdent+getModuleIdent = S.gets moduleIdent++getNextId :: SIM Int+getNextId = do+  nid <- S.gets nextId+  S.modify $ \s -> s { nextId = succ nid }+  return nid++getFunArity :: QualIdent -> SIM Int+getFunArity f = do+  vEnv <- getValueEnv+  return $ case qualLookupValue f vEnv of+    [Value _ _ a _] -> a+    [Label   _ _ _] -> 1+    _               -> internalError $ "Simplify.funType " ++ show f++getValueEnv :: SIM ValueEnv+getValueEnv = S.gets valueEnv++freshIdent :: (Int -> Ident) -> SIM Ident+freshIdent f = f <$> getNextId++-- -----------------------------------------------------------------------------+-- Simplification+-- -----------------------------------------------------------------------------++simModule :: Module Type -> SIM (Module Type)+simModule (Module spi li ps m es is ds) = Module spi li ps m es is+                                       <$> mapM (simDecl Map.empty) ds++-- Inline an expression for a variable+type InlineEnv = Map.Map Ident (Expression Type)++simDecl :: InlineEnv -> Decl Type -> SIM (Decl Type)+simDecl env (FunctionDecl p ty f eqs) = FunctionDecl p ty f+                                        <$> concatMapM (simEquation env) eqs+simDecl env (PatternDecl     p t rhs) = PatternDecl p t <$> simRhs env rhs+simDecl _   d                         = return d++simEquation :: InlineEnv -> Equation Type -> SIM [Equation Type]+simEquation env (Equation p lhs rhs) = do+  rhs'  <- simRhs env rhs+  inlineFun env p lhs rhs'++simRhs :: InlineEnv -> Rhs Type -> SIM (Rhs Type)+simRhs env (SimpleRhs  p _ e _) = simpleRhs p <$> simExpr env e+simRhs _   (GuardedRhs _ _ _ _) = error "Simplify.simRhs: guarded rhs"++-- -----------------------------------------------------------------------------+-- Inlining of Functions+-- -----------------------------------------------------------------------------++-- After simplifying the right hand side of an equation, the compiler+-- transforms declarations of the form+--+--   f t_1 ... t_{k-l} x_{k-l+1} ... x_k =+--     let g y_1 ... y_l = e+--     in  g x_{k-l+1} ... x_k+--+-- into the equivalent definition+--+--   f t_1 ... t_{k-l} x_{k-l+1} x_k = let y_1   = x_{k-l+1}+--                                              ...+--                                         y_l   = x_k+--                                     in  e+--+-- where the arities of 'f' and 'g' are 'k' and 'l', respectively, and+-- 'x_{k-l+1}, ... ,x_k' are variables. The transformation can obviously be+-- generalized to the case where 'g' is defined by more than one equation.+-- However, we must be careful not to change the evaluation mode of arguments.+-- Therefore, the transformation is applied only all of the arguments of 'g'+-- are variables.+--+-- This transformation is actually just a special case of inlining a+-- (local) function definition. We are unable to handle the general case+-- because it would require to represent the pattern matching code+-- explicitly in a Curry expression.++inlineFun :: InlineEnv -> SpanInfo -> Lhs Type -> Rhs Type+          -> SIM [Equation Type]+inlineFun env p lhs rhs = do+  m <- getModuleIdent+  case rhs of+    SimpleRhs _ _ (Let _ _ [FunctionDecl _ _ f' eqs'] e) _+      | -- @f'@ is not recursive+        f' `notElem` qfv m eqs'+        -- @f'@ does not perform any pattern matching+        && and [all isVariablePattern ts1 | Equation _ (FunLhs _ _ ts1) _ <- eqs']+      -> do+        let a = eqnArity $ head eqs'+            (n, vs', e') = etaReduce 0 [] (reverse (snd $ flatLhs lhs)) e+        if  -- the eta-reduced rhs of @f@ is a call to @f'@+            setSpanInfo NoSpanInfo e' == Variable NoSpanInfo (typeOf e') (qualify f')+            -- @f'@ was fully applied before eta-reduction+            && n  == a+          then mapM (mergeEqns p vs') eqs'+          else return [Equation p lhs rhs]+    _ -> return [Equation p lhs rhs]+  where+  etaReduce n1 vs (VariablePattern _ ty v : ts1)+                  (Apply _ e1 (Variable _ _ v'))+    | qualify v == v' = etaReduce (n1 + 1) ((ty, v) : vs) ts1 e1+  etaReduce n1 vs _ e1 = (n1, vs, e1)++  mergeEqns p1 vs (Equation _ (FunLhs _ _ ts2) (SimpleRhs p2 _ e _))+    = Equation p1 lhs <$> simRhs env (simpleRhs p2 (mkLet ds e))+      where+      ds = zipWith (\t v -> PatternDecl NoSpanInfo t (simpleRhs p2 (uncurry mkVar v)))+                   ts2+                   vs+  mergeEqns _ _ _ = error "Simplify.inlineFun.mergeEqns: no pattern match"++-- -----------------------------------------------------------------------------+-- Simplification of Expressions+-- -----------------------------------------------------------------------------++-- Variables that are bound to (simple) constants and aliases to other+-- variables are substituted. In terms of conventional compiler technology,+-- these optimizations correspond to constant propagation and copy propagation,+-- respectively. The transformation is applied recursively to a substituted+-- variable in order to handle chains of variable definitions.++-- Applications of let-expressions and case-expressions to other expressions+-- are simplified according to the following rules:+--   (let ds in e_1)            e_2 -> let ds in (e1 e2)+--   (case e_1 of p'_n -> e'_n) e_2 -> case e_1 of p'_n -> (e'n e_2)++-- The bindings of a let expression are sorted topologically in+-- order to split them into minimal binding groups. In addition,+-- local declarations occurring on the right hand side of a pattern+-- declaration are lifted into the enclosing binding group using the+-- equivalence (modulo alpha-conversion) of 'let x = let ds in e_1 in e_2'+-- and 'let ds; x = e_1 in e_2'.+-- This transformation avoids the creation of some redundant lifted+-- functions in later phases of the compiler.++simExpr :: InlineEnv -> Expression Type -> SIM (Expression Type)+simExpr _   l@(Literal     _ _ _) = return l+simExpr _   c@(Constructor _ _ _) = return c+-- subsitution of variables+simExpr env v@(Variable   _ ty x)+  | isQualified x = return v+  | otherwise     =+    maybe (return v) (simExpr env . withType ty) (Map.lookup (unqualify x) env)+-- simplification of application+simExpr env (Apply       _ e1 e2) = case e1 of+  Let _ _ ds e'     -> simExpr env (mkLet ds (Apply NoSpanInfo e' e2))+  Case _ _ ct e' bs -> simExpr env (mkCase ct e' (map (applyToAlt e2) bs))+  _                 -> Apply NoSpanInfo <$> simExpr env e1 <*> simExpr env e2+  where+  applyToAlt e (Alt        p t rhs) = Alt p t (applyToRhs e rhs)+  applyToRhs e (SimpleRhs  p _ e1' _) = simpleRhs p (Apply NoSpanInfo e1' e)+  applyToRhs _ (GuardedRhs _ _ _ _) = error "Simplify.simExpr.applyRhs: Guarded rhs"+-- simplification of declarations+simExpr env (Let        _ _ ds e) = do+  m   <- getModuleIdent+  dss <- mapM sharePatternRhs ds+  simplifyLet env (scc bv (qfv m) (foldr hoistDecls [] (concat dss))) e+simExpr env (Case    _ _ ct e bs) =+  mkCase ct <$> simExpr env e <*> mapM (simplifyAlt env) bs+simExpr env (Typed       _ e qty) =+  flip (Typed NoSpanInfo) qty <$> simExpr env e+simExpr _   _                     = error "Simplify.simExpr: no pattern match"++-- Simplify a case alternative+simplifyAlt :: InlineEnv -> Alt Type -> SIM (Alt Type)+simplifyAlt env (Alt p t rhs) = Alt p t <$> simRhs env rhs++-- Transform a pattern declaration @t = e@ into two declarations+-- @t = v, v = e@ whenever @t@ is not a variable. This is used to share+-- the expression @e@ using the fresh variable @v@.+sharePatternRhs :: Decl Type -> SIM [Decl Type]+--TODO: change to patterns instead of case+sharePatternRhs (PatternDecl p t rhs) = case t of+  VariablePattern _ _ _ -> return [PatternDecl p t rhs]+  _                     -> do+    let ty = typeOf t+    v  <- freshIdent patternId+    return [ PatternDecl p t                      (simpleRhs p (mkVar ty v))+           , PatternDecl p (VariablePattern NoSpanInfo ty v) rhs+           ]+  where patternId n = mkIdent ("_#pat" ++ show n)+sharePatternRhs d                     = return [d]++-- Lift up nested let declarations in pattern declarations, i.e., replace+-- @let p = let ds' in e'; ds in e@ by @let ds'; p = e'; ds in e@.+hoistDecls :: Decl a -> [Decl a] -> [Decl a]+hoistDecls (PatternDecl p t (SimpleRhs p' _ (Let _ _ ds' e) _)) ds+ = foldr hoistDecls ds (PatternDecl p t (simpleRhs p' e) : ds')+hoistDecls d ds = d : ds++-- The declaration groups of a let expression are first processed from+-- outside to inside, simplifying the right hand sides and collecting+-- inlineable expressions on the fly. At present, only simple constants+-- and aliases to other variables are inlined. A constant is considered+-- simple if it is either a literal, a constructor, or a non-nullary+-- function. Note that it is not possible to define nullary functions in+-- local declarations in Curry. Thus, an unqualified name always refers+-- to either a variable or a non-nullary function. Applications of+-- constructors and partial applications of functions to at least one+-- argument are not inlined because the compiler has to allocate space+-- for them, anyway. In order to prevent non-termination, recursive+-- binding groups are not processed for inlining.++-- With the list of inlineable expressions, the body of the let is+-- simplified and then the declaration groups are processed from inside+-- to outside to construct the simplified, nested let expression. In+-- doing so, unused bindings are discarded. In addition, all pattern+-- bindings are replaced by simple variable declarations using selector+-- functions to access the pattern variables.++simplifyLet :: InlineEnv -> [[Decl Type]] -> Expression Type+            -> SIM (Expression Type)+simplifyLet env []       e = simExpr env e+simplifyLet env (ds:dss) e = do+  m     <- getModuleIdent+  ds'   <- mapM (simDecl env) ds  -- simplify declarations+  env'  <- inlineVars env ds'     -- inline a simple variable binding+  e'    <- simplifyLet env' dss e -- simplify remaining bindings+  ds''  <- concatMapM (expandPatternBindings (qfv m ds' ++ qfv m e')) ds'+  return $ foldr (mkLet' m) e' (scc bv (qfv m) ds'')++inlineVars :: InlineEnv -> [Decl Type] -> SIM InlineEnv+inlineVars env ds = case ds of+  [PatternDecl _ (VariablePattern _ _ v) (SimpleRhs _ _ e _)] -> do+    allowed <- canInlineVar v e+    return $ if allowed then Map.insert v e env else env+  _ -> return env+  where+  canInlineVar _ (Literal     _ _ _) = return True+  canInlineVar _ (Constructor _ _ _) = return True+  canInlineVar v (Variable   _ _ v')+    | isQualified v'             = (> 0) <$> getFunArity v'+    | otherwise                  = return $ v /= unqualify v'+  canInlineVar _ _               = return False++mkLet' :: ModuleIdent -> [Decl Type] -> Expression Type -> Expression Type+mkLet' m [FreeDecl p vs] e+  | null vs'  = e+  | otherwise = mkLet [FreeDecl p vs'] e -- remove unused free variables+  where vs' = filter ((`elem` qfv m e) . varIdent) vs+mkLet' m [PatternDecl _ (VariablePattern _ ty v) (SimpleRhs _ _ e _)] (Variable _ _ v')+  | v' == qualify v && v `notElem` qfv m e = withType ty e -- inline single binding+mkLet' m ds e+  | not (any (`elem` qfv m e) (bv ds)) = e -- removed unused bindings+  | otherwise                              = mkLet ds e++-- In order to implement lazy pattern matching in local declarations,+-- pattern declarations 't = e' where 't' is not a variable+-- are transformed into a list of declarations+-- 'v_0 = e; v_1 = f_1 v_0; ...; v_n = f_n v_0' where 'v_0' is a fresh+-- variable, 'v_1,...,v_n' are the variables occurring in 't' and the+-- auxiliary functions 'f_i' are defined by 'f_i t = v_i' (see also+-- appendix D.8 of the Curry report). The bindings 'v_0 = e' are introduced+-- before splitting the declaration groups of the enclosing let expression+-- (cf. the 'Let' case in 'simExpr' above) so that they are placed in their own+-- declaration group whenever possible. In particular, this ensures that+-- the new binding is discarded when the expression 'e' is itself a variable.++-- fvs contains all variables used in the declarations and the body+-- of the let expression.+expandPatternBindings :: [Ident] -> Decl Type -> SIM [Decl Type]+expandPatternBindings fvs d@(PatternDecl p t (SimpleRhs _ _ e _)) = case t of+  VariablePattern _ _ _ -> return [d]+  _                     ->+    -- used variables+    mapM mkSelectorDecl (filter ((`elem` fvs) . fst3) (patternVars t))+  where+    pty = typeOf t -- type of pattern+    mkSelectorDecl (v, _, vty) = do+      let fty = TypeArrow pty vty+      f <- freshIdent (updIdentName (++ '#' : idName v) . fpSelectorId)+      return $ varDecl p vty v $+        mkLet [funDecl p fty f [t] (mkVar vty v)]+        (Apply NoSpanInfo (mkVar fty f) e)+expandPatternBindings _ d = return [d]
− src/TypeCheck.lhs 
@@ -1,1331 +0,0 @@--% $Id: TypeCheck.lhs,v 1.90 2004/11/06 18:34:07 wlux Exp $-%-% Copyright (c) 1999-2004, Wolfgang Lux-% See LICENSE for the full license.-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-%-\nwfilename{TypeCheck.lhs}-\section{Type Checking Curry Programs}-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 algorithm-W~\cite{DamasMilner82:Principal} for inferring the types of-unannotated declarations, but allows for polymorphic recursion when a-type annotation is present.-\begin{verbatim}--> module TypeCheck(typeCheck) where--> import Text.PrettyPrint.HughesPJ-> import Control.Monad.State as S-> import Data.List-> import Data.Maybe-> import qualified Data.Map as Map-> import qualified Data.Set as Set--> import Curry.Base.Position-> import Curry.Base.Ident-> import Curry.Syntax-> import Curry.Syntax.Pretty-> import Curry.Syntax.Utils---> import Base-> import Types-> import TopEnv-> import SCC-> import TypeSubst-> import Utils--> infixl 5 $-$--> ($-$) :: Doc -> Doc -> Doc-> x $-$ y = x $$ space $$ y--\end{verbatim}-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.-\begin{verbatim}--> typeCheck :: ModuleIdent -> TCEnv -> ValueEnv -> [Decl] -> (TCEnv,ValueEnv)-> typeCheck m tcEnv tyEnv ds =->   run (tcDecls m tcEnv' Map.empty vds >>->        S.lift S.get >>= \theta -> S.get >>= \tyEnv' ->->        return (tcEnv',subst theta tyEnv'))->       (bindLabels m tcEnv' (bindConstrs m tcEnv' tyEnv))->   where (tds,vds) = partition isTypeDecl ds->         tcEnv' = bindTypes m tds tcEnv--\end{verbatim}--The type checker makes use of nested state monads in order to-maintain the type environment, the current substitution, and a counter-which is used for generating fresh type variables.-\begin{verbatim}--> type TcState a = S.StateT ValueEnv (S.StateT TypeSubst (S.State Int)) a--> run :: TcState a -> ValueEnv -> a-> run m tyEnv = S.evalState (S.evalStateT (S.evalStateT m tyEnv) idSubst) 0--\end{verbatim}-\paragraph{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 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 \texttt{bindTC} is passed the \emph{final} type constructor-environment in order to handle the expansion of type synonyms. This-does not lead to a termination problem because \texttt{sortTypeDecls}-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 \texttt{anonId} before passing them to \texttt{expandMonoType}-and \texttt{expandMonoTypes}, respectively.-\begin{verbatim}--> bindTypes :: ModuleIdent -> [Decl] -> TCEnv -> TCEnv-> bindTypes m ds tcEnv = tcEnv'->   where tcEnv' = foldr (bindTC m tcEnv') tcEnv (sortTypeDecls m ds)--> bindTC :: ModuleIdent -> TCEnv -> Decl -> TCEnv -> TCEnv-> bindTC m tcEnv (DataDecl _ tc tvs cs) =->   bindTypeInfo DataType m tc tvs (map (Just . mkData) cs)->   where mkData (ConstrDecl _ evs c tys) = Data c (length evs) tys'->           where tys' = expandMonoTypes m tcEnv (cleanTVars tvs evs) tys->         mkData (ConOpDecl _ evs ty1 op ty2) = Data op (length evs) tys'->           where tys' = expandMonoTypes m tcEnv (cleanTVars tvs evs) [ty1,ty2]-> bindTC m tcEnv (NewtypeDecl _ tc tvs (NewConstrDecl _ evs c ty)) =->   bindTypeInfo RenamingType m tc tvs (Data c (length evs) 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]--> sortTypeDecls :: ModuleIdent -> [Decl] -> [Decl]-> sortTypeDecls m = map (typeDecl m) . scc bound free->   where bound (DataDecl _ tc _ _) = [tc]->         bound (NewtypeDecl _ tc _ _) = [tc]->         bound (TypeDecl _ tc _ _) = [tc]->         free (DataDecl _ _ _ _) = []->         free (NewtypeDecl _ _ _ _) = []->         free (TypeDecl _ _ _ ty) = ft m ty []--> typeDecl :: ModuleIdent -> [Decl] -> Decl-> typeDecl _ [] = internalError "typeDecl"-> typeDecl _ [d@(DataDecl _ _ _ _)] = d-> typeDecl _ [d@(NewtypeDecl _ _ _ _)] = d-> typeDecl m [d@(TypeDecl p tc _ ty)]->   | tc `elem` ft m ty [] = errorAt' (recursiveTypes [tc])->   | otherwise = d-> typeDecl _ (TypeDecl p tc _ _ : ds) =->   errorAt' (recursiveTypes (tc : [tc' | TypeDecl _ tc' _ _ <- ds]))--> 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 (RecordType fs rty) tcs = ->   foldr (ft m) (maybe tcs (\ty -> ft m ty tcs) rty) (map snd fs)--\end{verbatim}-\paragraph{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.-\begin{verbatim}--> 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 (catMaybes cs)->         bindData (RenamingType tc n (Data c n' ty)) tyEnv =->           bindGlobalInfo NewtypeConstructor m c->                          (ForAllExist n n' (TypeArrow ty (constrType tc n)))->                          tyEnv->         bindData (AliasType _ _ _) tyEnv = tyEnv->         bindConstr m n ty (Data c n' tys) =->           bindGlobalInfo DataConstructor m c->                          (ForAllExist n n' (foldr TypeArrow ty tys))->         constrType tc n = TypeConstructor tc (map TypeVariable [0..n-1])--\end{verbatim}-\paragraph{Defining Field Labels}-Records can only be declared as type aliases. So currently there is-nothing more to do than entering all typed record fields (labels) -which occur in record types on the right-hand-side of type aliases -into 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.-\begin{verbatim}--> bindLabels :: ModuleIdent -> TCEnv -> ValueEnv -> ValueEnv-> bindLabels m tcEnv tyEnv =->   foldr (bindFieldLabels . snd) tyEnv (localBindings tcEnv)->   where bindFieldLabels (AliasType r _ (TypeRecord fs _)) tyEnv =->           foldr (bindField r) tyEnv fs->	  bindFieldLabels _ tyEnv = tyEnv->	  ->         bindField r (l,ty) tyEnv =->           case (lookupValue l tyEnv) of->             [] -> bindLabel l r (polyType ty) tyEnv ->             _  -> tyEnv--\end{verbatim}-\paragraph{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.-\begin{verbatim}--> type SigEnv = Map.Map Ident TypeExpr--> 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) nameSupply))--> nameTypes :: [TypeExpr] -> [Ident] -> ([TypeExpr],[Ident])-> nameTypes (ty:tys) tvs = (ty':tys',tvs'')->   where (ty',tvs') = nameType ty tvs->         (tys',tvs'') = nameTypes tys tvs'-> nameTypes [] tvs = ([],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)->   | tv == anonId = (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 (RecordType fs rty) tvs = ->   (RecordType (zip ls tys') (listToMaybe rty'), tvs)->   where (ls, tys) = unzip fs->         (tys', _) = nameTypes tys tvs->         (rty', _) = nameTypes (maybeToList rty) tvs-        -\end{verbatim}-\paragraph{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-\texttt{ccall} calling convention are restricted to the basic types-\texttt{Bool}, \texttt{Char}, \texttt{Int}, and \texttt{Float}. In-addition, \texttt{IO}~$t$ is a legitimate result type when $t$ is-either one of the basic types or \texttt{()}.--\ToDo{Extend the set of legitimate types to match the types admitted-  by the Haskell Foreign Function Interface-  Addendum.~\cite{Chakravarty03:FFI}}-\begin{verbatim}--> tcDecls :: ModuleIdent -> TCEnv -> SigEnv -> [Decl] -> TcState ()-> tcDecls m tcEnv sigs ds =->   mapM_ (tcDeclGroup m tcEnv (foldr bindTypeSigs sigs ods))->         (scc bv (qfv m) vds)->   where (vds,ods) = partition isValueDecl ds--> tcDeclGroup :: ModuleIdent -> TCEnv -> SigEnv -> [Decl] -> TcState ()-> --tcDeclGroup m tcEnv _ [ForeignDecl p cc _ f ty] =-> --  tcForeignFunct m tcEnv p cc f ty-> tcDeclGroup m tcEnv _ [ExternalDecl _ _ _ f ty] =->   tcExternalFunct m tcEnv f ty-> tcDeclGroup m tcEnv sigs [FlatExternalDecl _ fs] =->   mapM_ (tcFlatExternalFunct m tcEnv sigs) fs-> tcDeclGroup m tcEnv sigs [ExtraVariables _ vs] =->   mapM_ (tcExtraVar m tcEnv sigs ) vs-> tcDeclGroup m tcEnv sigs ds =->   do->     tyEnv0 <- S.get->     tysLhs <- mapM (tcDeclLhs m tcEnv sigs) ds->     tysRhs <- mapM (tcDeclRhs m tcEnv tyEnv0 sigs) ds->     sequence_ (zipWith3 (unifyDecl m) ds tysLhs tysRhs)->     theta <- S.lift S.get->     mapM_ (genDecl m tcEnv sigs (fvEnv (subst theta tyEnv0)) theta) ds--> --tcForeignFunct :: ModuleIdent -> TCEnv -> Position -> CallConv -> Ident-> --               -> TypeExpr -> TcState ()-> --tcForeignFunct 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]--> tcExternalFunct :: ModuleIdent -> TCEnv -> Ident -> TypeExpr -> TcState ()-> tcExternalFunct m tcEnv  f ty =->   S.modify (bindFun m f (expandPolyType m tcEnv ty))--> tcFlatExternalFunct :: ModuleIdent -> TCEnv -> SigEnv -> Ident -> TcState ()-> tcFlatExternalFunct m tcEnv sigs f =->   typeOf f tcEnv sigs >>= S.modify . bindFun m f->   where typeOf f tcEnv sigs =->           case lookupTypeSig f sigs of->             Just ty -> return (expandPolyType m tcEnv ty)->             Nothing -> internalError "tcFlatExternalFunct"--> tcExtraVar :: ModuleIdent -> TCEnv -> SigEnv -> Ident->            -> TcState ()-> tcExtraVar m tcEnv sigs v =->   typeOf v tcEnv sigs >>= S.modify . bindFun m v . monoType->   where typeOf v tcEnv sigs =->           case lookupTypeSig v sigs of->             Just ty->               | n == 0 -> return ty'->               | otherwise -> errorAt' (polymorphicFreeVar v)->               where ForAll n ty' = expandPolyType m tcEnv ty->             Nothing -> freshTypeVar--> tcDeclLhs :: ModuleIdent -> TCEnv -> SigEnv -> Decl -> TcState Type-> tcDeclLhs m tcEnv sigs (FunctionDecl p f _) =->   tcConstrTerm m tcEnv sigs p (VariablePattern f)-> tcDeclLhs m tcEnv sigs (PatternDecl p t _) = tcConstrTerm m tcEnv sigs p t--> tcDeclRhs :: ModuleIdent -> TCEnv -> ValueEnv -> SigEnv -> Decl->           -> TcState Type-> tcDeclRhs m tcEnv tyEnv0 sigs (FunctionDecl _ f (eq:eqs)) =->   tcEquation m tcEnv tyEnv0 sigs eq >>= flip tcEqns eqs->   where tcEqns ty [] = return ty->         tcEqns ty (eq@(Equation p _ _):eqs) =->           tcEquation m tcEnv tyEnv0 sigs eq >>=->           unify p "equation" (ppDecl (FunctionDecl p f [eq])) m ty >>->           tcEqns ty eqs-> tcDeclRhs m tcEnv tyEnv0 sigs (PatternDecl _ _ rhs) =->   tcRhs m tcEnv tyEnv0 sigs rhs--> unifyDecl :: ModuleIdent -> Decl -> Type -> Type -> TcState ()-> unifyDecl m (FunctionDecl p f _) =->   unify p "function binding" (text "Function:" <+> ppIdent f) m-> unifyDecl m (PatternDecl p t _) =->   unify p "pattern binding" (ppConstrTerm 0 t) m--\end{verbatim}-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-\begin{verbatim}-bug = x =:= 1 & x =:= 'a'-  where x :: a-        x = fresh-fresh :: a-fresh = x where x free-\end{verbatim}-could be written. Note that \texttt{fresh} has the polymorphic type-$\forall\alpha.\alpha$. This is correct because \texttt{fresh} is a-function and therefore returns a different variable at each-invocation.--The code in \texttt{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.-\begin{verbatim}--> genDecl :: ModuleIdent -> TCEnv -> SigEnv -> Set.Set Int -> TypeSubst -> Decl->         -> TcState ()-> genDecl m tcEnv sigs lvs theta (FunctionDecl _ f _) =->   S.modify (genVar True m tcEnv sigs lvs theta f)-> genDecl m tcEnv sigs lvs theta (PatternDecl p t _) =->   mapM_ (S.modify . genVar False m tcEnv sigs lvs theta ) (bv t)--> genVar :: Bool -> ModuleIdent -> TCEnv -> SigEnv -> Set.Set Int -> TypeSubst->        -> Ident -> ValueEnv -> ValueEnv-> genVar poly m tcEnv sigs lvs theta v tyEnv =->   case lookupTypeSig v sigs of->     Just sigTy->       | cmpTypes sigma (expandPolyType m tcEnv sigTy) -> tyEnv'->       | otherwise -> errorAt (positionOfIdent v) ->                              (typeSigTooGeneral m what sigTy sigma)->     Nothing -> tyEnv'->   where what = text (if poly then "Function:" else "Variable:") <+> ppIdent v->         tyEnv' = rebindFun m v sigma tyEnv->         sigma = genType poly (subst theta (varType v tyEnv))->         genType poly (ForAll n ty)->           | n > 0 = internalError ("genVar: " ++ showLine (positionOfIdent v) ++ ->                                    show v ++ " :: " ++ show ty)->           | poly = gen lvs ty->           | otherwise = monoType ty->         cmpTypes (ForAll _ t1) (ForAll _ t2) = equTypes t1 t2--> tcEquation :: ModuleIdent -> TCEnv -> ValueEnv -> SigEnv -> Equation->            -> TcState Type-> tcEquation m tcEnv tyEnv0 sigs (Equation p lhs rhs) =->   do->     tys <- mapM (tcConstrTerm m tcEnv sigs p) ts->     ty <- tcRhs m tcEnv tyEnv0 sigs rhs->     checkSkolems p m (text "Function: " <+> ppIdent f) tyEnv0->                  (foldr TypeArrow ty tys)->   where (f,ts) = flatLhs lhs--> tcLiteral :: ModuleIdent -> Literal -> TcState Type-> tcLiteral _ (Char _ _) = return charType-> tcLiteral m (Int v _)  = --return intType->   do->     ty <- freshConstrained [intType,floatType]->     S.modify (bindFun m v (monoType ty))->     return ty-> tcLiteral _ (Float _ _) = return floatType-> tcLiteral _ (String _ _) = return stringType--> tcConstrTerm :: ModuleIdent -> TCEnv -> SigEnv -> Position -> ConstrTerm->              -> TcState Type-> tcConstrTerm m tcEnv sigs _ (LiteralPattern l) = tcLiteral m l-> tcConstrTerm m tcEnv sigs _ (NegativePattern _ l) = tcLiteral m l-> tcConstrTerm m tcEnv sigs _ (VariablePattern v) =->   do ->     ty <- case lookupTypeSig v sigs of->             Just t -> inst (expandPolyType m tcEnv t)->             Nothing -> freshTypeVar->     S.modify (bindFun m v (monoType ty))->     return ty->   -> tcConstrTerm m tcEnv sigs p t@(ConstructorPattern c ts) =->   do->     tyEnv <- S.get->     ty <- skol (constrType m c tyEnv)->     unifyArgs (ppConstrTerm 0 t) ts ty->   where unifyArgs _ [] ty = return ty->         unifyArgs doc (t:ts) (TypeArrow ty1 ty2) =->           tcConstrTerm m tcEnv sigs p t >>=->           unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t)->                 m ty1 >>->           unifyArgs doc ts ty2->         unifyArgs _ _ _ = internalError "tcConstrTerm"-> tcConstrTerm m tcEnv sigs p t@(InfixPattern t1 op t2) =->   do->     tyEnv <- S.get->     ty <- skol (constrType m op tyEnv)->     unifyArgs (ppConstrTerm 0 t) [t1,t2] ty->   where unifyArgs _ [] ty = return ty->         unifyArgs doc (t:ts) (TypeArrow ty1 ty2) =->           tcConstrTerm m tcEnv sigs p t >>=->           unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t)->                 m ty1 >>->           unifyArgs doc ts ty2->         unifyArgs _ _ _ = internalError "tcConstrTerm"-> tcConstrTerm m tcEnv sigs p (ParenPattern t) = tcConstrTerm m tcEnv sigs p t-> tcConstrTerm m tcEnv sigs p (TuplePattern _ ts)->  | null ts = return unitType->  | otherwise = liftM tupleType $ mapM (tcConstrTerm m tcEnv sigs p) ts-> tcConstrTerm m tcEnv sigs p t@(ListPattern _ ts) =->   freshTypeVar >>= flip (tcElems (ppConstrTerm 0 t)) ts->   where tcElems _ ty [] = return (listType ty)->         tcElems doc ty (t:ts) =->           tcConstrTerm m tcEnv sigs p t >>=->           unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t)->                 m ty >>->           tcElems doc ty ts-> tcConstrTerm m tcEnv sigs p t@(AsPattern v t') =->   do->     ty1 <- tcConstrTerm m tcEnv sigs p (VariablePattern v)->     ty2 <- tcConstrTerm m tcEnv sigs p t'->     unify p "pattern" (ppConstrTerm 0 t) m ty1 ty2->     return ty1-> tcConstrTerm m tcEnv sigs p (LazyPattern _ t) = tcConstrTerm m tcEnv sigs p t-> tcConstrTerm m tcEnv sigs p t@(FunctionPattern f ts) =->   do->     tyEnv <- S.get->     ty <- inst (funType m f tyEnv) --skol (constrType m c tyEnv)->     unifyArgs (ppConstrTerm 0 t) ts ty->   where unifyArgs _ [] ty = return ty->         unifyArgs doc (t:ts) ty@(TypeVariable _) =->           do (alpha,beta) <- tcArrow p "function pattern" doc m ty->	       ty' <- tcConstrTermFP m tcEnv sigs p t->	       unify p "function pattern"->	             (doc $-$ text "Term:" <+> ppConstrTerm 0 t)->	             m ty' alpha->	       unifyArgs doc ts beta->         unifyArgs doc (t:ts) (TypeArrow ty1 ty2) =->           tcConstrTermFP m tcEnv sigs p t >>=->           unify p "function pattern" ->	          (doc $-$ text "Term:" <+> ppConstrTerm 0 t)->                 m ty1 >>->           unifyArgs doc ts ty2->         unifyArgs _ _ ty = internalError ("tcConstrTerm: " ++ show ty)-> tcConstrTerm m tcEnv sigs p t@(InfixFuncPattern t1 op t2) =->   tcConstrTerm m tcEnv sigs p (FunctionPattern op [t1,t2])-> tcConstrTerm m tcEnv sigs p r@(RecordPattern fs rt)->   | isJust rt =->     do->       ty <- tcConstrTerm m tcEnv sigs p (fromJust rt)->       fts <- mapM (tcFieldPatt (tcConstrTerm m tcEnv sigs) m) fs->       alpha <- freshVar id->	let rty = TypeRecord fts (Just alpha)->	unify p "record pattern" (ppConstrTerm 0 r) m ty rty->       return rty->   | otherwise =->     do->       fts <- mapM (tcFieldPatt (tcConstrTerm m tcEnv sigs) m) fs->       return (TypeRecord fts Nothing)--\end{verbatim}-In contrast to usual patterns, the type checking routine for arguments of -function patterns \texttt{tcConstrTermFP} differs from \texttt{tcConstrTerm}-because of possibly multiple occurrences of variables.-\begin{verbatim}--> tcConstrTermFP :: ModuleIdent -> TCEnv -> SigEnv -> Position -> ConstrTerm->                   -> TcState Type-> tcConstrTermFP m tcEnv sigs p (LiteralPattern l) = tcLiteral m l-> tcConstrTermFP m tcEnv sigs p (NegativePattern _ l) = tcLiteral m l-> tcConstrTermFP m tcEnv sigs p (VariablePattern v) =->   do->     ty <- maybe freshTypeVar ->                 (inst . expandPolyType m tcEnv) ->                 (lookupTypeSig v sigs)->     tyEnv <- S.get->     ty' <- maybe (S.modify (bindFun m v (monoType ty)) >> return ty)->                  (\ (ForAll _ t) -> return t)->	           (sureVarType v tyEnv)->     return ty' -> tcConstrTermFP m tcEnv sigs p t@(ConstructorPattern c ts) =->   do->     tyEnv <- S.get->     ty <- skol (constrType m c tyEnv)->     unifyArgs (ppConstrTerm 0 t) ts ty->   where unifyArgs _ [] ty = return ty->         unifyArgs doc (t:ts) (TypeArrow ty1 ty2) =->           tcConstrTermFP m tcEnv sigs p t >>=->           unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t)->                 m ty1 >>->           unifyArgs doc ts ty2->         unifyArgs _ _ _ = internalError "tcConstrTermFP"-> tcConstrTermFP m tcEnv sigs p t@(InfixPattern t1 op t2) =->   do->     tyEnv <- S.get->     ty <- skol (constrType m op tyEnv)->     unifyArgs (ppConstrTerm 0 t) [t1,t2] ty->   where unifyArgs _ [] ty = return ty->         unifyArgs doc (t:ts) (TypeArrow ty1 ty2) =->           tcConstrTermFP m tcEnv sigs p t >>=->           unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t)->                 m ty1 >>->           unifyArgs doc ts ty2->         unifyArgs _ _ _ = internalError "tcConstrTermFP"-> tcConstrTermFP m tcEnv sigs p (ParenPattern t) = tcConstrTermFP m tcEnv sigs p t-> tcConstrTermFP m tcEnv sigs p (TuplePattern _ ts)->  | null ts = return unitType->  | otherwise = liftM tupleType $ mapM (tcConstrTermFP m tcEnv sigs p) ts-> tcConstrTermFP m tcEnv sigs p t@(ListPattern _ ts) =->   freshTypeVar >>= flip (tcElems (ppConstrTerm 0 t)) ts->   where tcElems _ ty [] = return (listType ty)->         tcElems doc ty (t:ts) =->           tcConstrTermFP m tcEnv sigs p t >>=->           unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t)->                 m ty >>->           tcElems doc ty ts-> tcConstrTermFP m tcEnv sigs p t@(AsPattern v t') =->   do->     ty1 <- tcConstrTermFP m tcEnv sigs p (VariablePattern v)->     ty2 <- tcConstrTermFP m tcEnv sigs p t'->     unify p "pattern" (ppConstrTerm 0 t) m ty1 ty2->     return ty1-> tcConstrTermFP m tcEnv sigs p (LazyPattern _ t) = tcConstrTermFP m tcEnv sigs p t-> tcConstrTermFP m tcEnv sigs p t@(FunctionPattern f ts) =->   do->     tyEnv <- S.get->     ty <- inst (funType m f tyEnv) --skol (constrType m c tyEnv)->     unifyArgs (ppConstrTerm 0 t) ts ty->   where unifyArgs _ [] ty = return ty->         unifyArgs doc (t:ts) ty@(TypeVariable _) =->           do (alpha,beta) <- tcArrow p "function pattern" doc m ty->	       ty' <- tcConstrTermFP m tcEnv sigs p t->	       unify p "function pattern"->	             (doc $-$ text "Term:" <+> ppConstrTerm 0 t)->	             m ty' alpha->	       unifyArgs doc ts beta->         unifyArgs doc (t:ts) (TypeArrow ty1 ty2) =->           tcConstrTermFP m tcEnv sigs p t >>=->           unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t)->                 m ty1 >>->           unifyArgs doc ts ty2->         unifyArgs _ _ _ = internalError "tcConstrTermFP"-> tcConstrTermFP m tcEnv sigs p t@(InfixFuncPattern t1 op t2) =->   tcConstrTermFP m tcEnv sigs p (FunctionPattern op [t1,t2])-> tcConstrTermFP m tcEnv sigs p r@(RecordPattern fs rt)->   | isJust rt =->     do->       ty <- tcConstrTermFP m tcEnv sigs p (fromJust rt)->       fts <- mapM (tcFieldPatt (tcConstrTermFP m tcEnv sigs) m) fs->       alpha <- freshVar id->	let rty = TypeRecord fts (Just alpha)->	unify p "record pattern" (ppConstrTerm 0 r) m ty rty->       return rty->   | otherwise =->     do->       fts <- mapM (tcFieldPatt (tcConstrTermFP m tcEnv sigs) m) fs->       return (TypeRecord fts Nothing)--> tcFieldPatt :: (Position -> ConstrTerm -> TcState Type) -> ModuleIdent->             -> Field ConstrTerm -> TcState (Ident,Type)-> tcFieldPatt tcPatt m f@(Field _ l t) =->   do->     tyEnv <- S.get->     let p = positionOfIdent l->     lty <- maybe (freshTypeVar->	             >>= (\lty' ->->		           S.modify->		             (bindLabel l (qualifyWith m (mkIdent "#Rec"))->		                        (polyType lty'))->		           >> return lty'))->	           (\ (ForAll _ lty') -> return lty')->	           (sureLabelType l tyEnv)->     ty <- tcPatt p t->     unify p "record" (text "Field:" <+> ppFieldPatt f) m lty ty->     return (l,ty)--> tcRhs :: ModuleIdent -> TCEnv -> ValueEnv -> SigEnv -> Rhs -> TcState Type-> tcRhs m tcEnv tyEnv0 sigs (SimpleRhs p e ds) =->   do->     tcDecls m tcEnv sigs ds->     ty <- tcExpr m tcEnv sigs p e->     checkSkolems p m (text "Expression:" <+> ppExpr 0 e) tyEnv0 ty-> tcRhs m tcEnv tyEnv0 sigs (GuardedRhs es ds) =->   do->     tcDecls m tcEnv sigs ds->     tcCondExprs m tcEnv tyEnv0 sigs es--> tcCondExprs :: ModuleIdent -> TCEnv -> ValueEnv -> SigEnv -> [CondExpr]->             -> TcState Type-> tcCondExprs m tcEnv tyEnv0 sigs es =->   do->     gty <- if length es > 1 then return boolType->                             else freshConstrained [successType,boolType]->     ty <- freshTypeVar->     tcCondExprs' gty ty es->   where tcCondExprs' gty ty [] = return ty->         tcCondExprs' gty ty (e:es) =->           tcCondExpr gty ty e >> tcCondExprs' gty ty es->         tcCondExpr gty ty (CondExpr p g e) =->           tcExpr m tcEnv sigs p g >>=->           unify p "guard" (ppExpr 0 g) m gty >>->           tcExpr m tcEnv sigs p e >>=->           checkSkolems p m (text "Expression:" <+> ppExpr 0 e) tyEnv0 >>=->           unify p "guarded expression" (ppExpr 0 e) m ty--> tcExpr :: ModuleIdent -> TCEnv -> SigEnv -> Position -> Expression->        -> TcState Type-> tcExpr m _ _ _ (Literal l) = tcLiteral m l-> tcExpr m tcEnv sigs p (Variable v) =->   case qualLookupTypeSig m v sigs of->     Just ty -> inst (expandPolyType m tcEnv ty)->     Nothing -> S.get >>= inst . funType m v-> tcExpr m tcEnv sigs p (Constructor c) = S.get >>= instExist . constrType m c-> tcExpr m tcEnv sigs p (Typed e sig) =->   do->     tyEnv0 <- S.get->     ty <- tcExpr m tcEnv sigs p e->     inst sigma' >>=->       flip (unify p "explicitly typed expression" (ppExpr 0 e) m) ty->     theta <- S.lift S.get->     let sigma = gen (fvEnv (subst theta tyEnv0)) (subst theta ty)->     unless (sigma == sigma')->       (errorAt p (typeSigTooGeneral m (text "Expression:" <+> ppExpr 0 e)->                  sig' sigma))->     return ty->   where sig' = nameSigType sig->         sigma' = expandPolyType m tcEnv sig'-> tcExpr m tcEnv sigs p (Paren e) = tcExpr m tcEnv sigs p e-> tcExpr m tcEnv sigs p (Tuple _ es)->   | null es = return unitType->   | otherwise = liftM tupleType $ mapM (tcExpr m tcEnv sigs p) es-> tcExpr m tcEnv sigs p e@(List _ es) = freshTypeVar >>= tcElems (ppExpr 0 e) es->   where tcElems _ [] ty = return (listType ty)->         tcElems doc (e:es) ty =->           tcExpr m tcEnv sigs p e >>=->           unify p "expression" (doc $-$ text "Term:" <+> ppExpr 0 e)->                 m ty >>->           tcElems doc es ty-> tcExpr m tcEnv sigs p (ListCompr _ e qs) =->   do->     tyEnv0 <- S.get->     mapM_ (tcQual m tcEnv sigs p) qs->     ty <- tcExpr m tcEnv sigs p e->     checkSkolems p m (text "Expression:" <+> ppExpr 0 e) tyEnv0 (listType ty)-> tcExpr m tcEnv sigs p e@(EnumFrom e1) =->   do->     ty1 <- tcExpr m tcEnv sigs p e1->     unify p "arithmetic sequence"->           (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) m intType ty1->     return (listType intType)-> tcExpr m tcEnv sigs p e@(EnumFromThen e1 e2) =->   do->     ty1 <- tcExpr m tcEnv sigs p e1->     ty2 <- tcExpr m tcEnv sigs p e2->     unify p "arithmetic sequence"->           (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) m intType ty1->     unify p "arithmetic sequence"->           (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2) m intType ty2->     return (listType intType)-> tcExpr m tcEnv sigs p e@(EnumFromTo e1 e2) =->   do->     ty1 <- tcExpr m tcEnv sigs p e1->     ty2 <- tcExpr m tcEnv sigs p e2->     unify p "arithmetic sequence"->           (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) m intType ty1->     unify p "arithmetic sequence"->           (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2) m intType ty2->     return (listType intType)-> tcExpr m tcEnv sigs p e@(EnumFromThenTo e1 e2 e3) =->   do->     ty1 <- tcExpr m tcEnv sigs p e1->     ty2 <- tcExpr m tcEnv sigs p e2->     ty3 <- tcExpr m tcEnv sigs p e3->     unify p "arithmetic sequence"->           (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) m intType ty1->     unify p "arithmetic sequence"->           (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2) m intType ty2->     unify p "arithmetic sequence"->           (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e3) m intType ty3->     return (listType intType)-> tcExpr m tcEnv sigs p e@(UnaryMinus op e1) =->   do->     opTy <- opType op->     ty1 <- tcExpr m tcEnv sigs p e1->     unify p "unary negation" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1)->           m opTy ty1->     return ty1->   where opType op->           | op == minusId = freshConstrained [intType,floatType]->           | op == fminusId = return floatType->           | otherwise = internalError ("tcExpr unary " ++ name op)-> tcExpr m tcEnv sigs p e@(Apply e1 e2) =->   do->     ty1 <- tcExpr m tcEnv sigs p e1->     ty2 <- tcExpr m tcEnv sigs p e2->     (alpha,beta) <-->       tcArrow p "application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1)->               m ty1->     unify p "application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2)->           m alpha ty2->     return beta-> tcExpr m tcEnv sigs p e@(InfixApply e1 op e2) =->   do->     opTy <- tcExpr m tcEnv sigs p (infixOp op)->     ty1 <- tcExpr m tcEnv sigs p e1->     ty2 <- tcExpr m tcEnv sigs p e2->     (alpha,beta,gamma) <-->       tcBinary p "infix application"->                (ppExpr 0 e $-$ text "Operator:" <+> ppOp op) m opTy->     unify p "infix application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1)->           m alpha ty1->     unify p "infix application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2)->           m beta ty2->     return gamma-> tcExpr m tcEnv sigs p e@(LeftSection e1 op) =->   do->     opTy <- tcExpr m tcEnv sigs p (infixOp op)->     ty1 <- tcExpr m tcEnv sigs p e1->     (alpha,beta) <-->       tcArrow p "left section" (ppExpr 0 e $-$ text "Operator:" <+> ppOp op)->               m opTy->     unify p "left section" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1)->           m alpha ty1->     return beta-> tcExpr m tcEnv sigs p e@(RightSection op e1) =->   do->     opTy <- tcExpr m tcEnv sigs p (infixOp op)->     ty1 <- tcExpr m tcEnv sigs p e1->     (alpha,beta,gamma) <-->       tcBinary p "right section"->                (ppExpr 0 e $-$ text "Operator:" <+> ppOp op) m opTy->     unify p "right section" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1)->           m beta ty1->     return (TypeArrow alpha gamma)-> tcExpr m tcEnv sigs p exp@(Lambda r ts e) =->   do->     tyEnv0 <- S.get->     tys <- mapM (tcConstrTerm m tcEnv sigs p) ts->     ty <- tcExpr m tcEnv sigs p e->     checkSkolems p m (text "Expression:" <+> ppExpr 0 exp) tyEnv0->                  (foldr TypeArrow ty tys)-> tcExpr m tcEnv sigs p (Let ds e) =->   do->     tyEnv0 <- S.get->     theta <- S.lift S.get->     tcDecls m tcEnv sigs ds->     ty <- tcExpr m tcEnv sigs p e->     checkSkolems p m (text "Expression:" <+> ppExpr 0 e) tyEnv0 ty-> tcExpr m tcEnv sigs p (Do sts e) =->   do->     tyEnv0 <- S.get->     mapM_ (tcStmt m tcEnv sigs p) sts->     alpha <- freshTypeVar->     ty <- tcExpr m tcEnv sigs p e->     unify p "statement" (ppExpr 0 e) m (ioType alpha) ty->     checkSkolems p m (text "Expression:" <+> ppExpr 0 e) tyEnv0 ty-> tcExpr m tcEnv sigs p e@(IfThenElse _ e1 e2 e3) =->   do->     ty1 <- tcExpr m tcEnv sigs p e1->     unify p "expression" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1)->           m boolType ty1->     ty2 <- tcExpr m tcEnv sigs p e2->     ty3 <- tcExpr m tcEnv sigs p e3->     unify p "expression" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e3)->           m ty2 ty3->     return ty3-> tcExpr m tcEnv sigs p (Case _ e alts) =->   do->     tyEnv0 <- S.get->     ty <- tcExpr m tcEnv sigs p e->     alpha <- freshTypeVar->     tcAlts tyEnv0 ty alpha alts->   where tcAlts tyEnv0 _ ty [] = return ty->         tcAlts tyEnv0 ty1 ty2 (alt:alts) =->           tcAlt (ppAlt alt) tyEnv0 ty1 ty2 alt >> tcAlts tyEnv0 ty1 ty2 alts->         tcAlt doc tyEnv0 ty1 ty2 (Alt p t rhs) =->           tcConstrTerm m tcEnv sigs p t >>=->           unify p "case pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t)->                 m ty1 >>->           tcRhs m tcEnv tyEnv0 sigs rhs >>=->           unify p "case branch" doc m ty2-> tcExpr m tcEnv sigs p (RecordConstr fs) =->   do ->     fts <- mapM (tcFieldExpr m tcEnv sigs equals) fs->     --when (1 == length fs)->     --     (error (show fs ++ "\n" ++ show fts))->     return (TypeRecord fts Nothing)-> tcExpr m tcEnv sigs p r@(RecordSelection e l) =->   do->     ty <- tcExpr m tcEnv sigs p e->     tyEnv <- S.get->     lty <- maybe (freshTypeVar ->	             >>= (\lty' -> ->		           S.modify ->		             (bindLabel l (qualifyWith m (mkIdent "#Rec"))->		                        (monoType lty'))->	                   >> return lty'))->                  (\ (ForAll _ lty') -> return lty')->	           (sureLabelType l tyEnv)->     alpha <- freshVar id->     let rty = TypeRecord [(l,lty)] (Just alpha)->     unify p "record selection" (ppExpr 0 r) m ty rty->     return lty-> tcExpr m tcEnv sigs p r@(RecordUpdate fs e) =->   do->     ty <- tcExpr m tcEnv sigs p e->     fts <- mapM (tcFieldExpr m tcEnv sigs (text ":=")) fs->     alpha <- freshVar id->     let rty = TypeRecord fts (Just alpha)->     unify p "record update" (ppExpr 0 r) m ty rty->     return ty--> tcQual :: ModuleIdent -> TCEnv -> SigEnv -> Position -> Statement->        -> TcState ()-> tcQual m tcEnv sigs p (StmtExpr _ e) =->   do->     ty <- tcExpr m tcEnv sigs p e->     unify p "guard" (ppExpr 0 e) m boolType ty-> tcQual m tcEnv sigs p q@(StmtBind _ t e) =->   do->     ty1 <- tcConstrTerm m tcEnv sigs p t->     ty2 <- tcExpr m tcEnv sigs p e->     unify p "generator" (ppStmt q $-$ text "Term:" <+> ppExpr 0 e)->           m (listType ty1) ty2-> tcQual m tcEnv sigs p (StmtDecl ds) = tcDecls m tcEnv sigs ds--> tcStmt :: ModuleIdent -> TCEnv -> SigEnv -> Position -> Statement->        -> TcState ()-> tcStmt m tcEnv sigs p (StmtExpr _ e) =->   do->     alpha <- freshTypeVar->     ty <- tcExpr m tcEnv sigs p e->     unify p "statement" (ppExpr 0 e) m (ioType alpha) ty-> tcStmt m tcEnv sigs p st@(StmtBind _ t e) =->   do->     ty1 <- tcConstrTerm m tcEnv sigs p t->     ty2 <- tcExpr m tcEnv sigs p e->     unify p "statement" (ppStmt st $-$ text "Term:" <+> ppExpr 0 e)->           m (ioType ty1) ty2-> tcStmt m tcEnv sigs p (StmtDecl ds) = tcDecls m tcEnv sigs ds--> tcFieldExpr :: ModuleIdent -> TCEnv -> SigEnv -> Doc -> Field Expression->	      -> TcState (Ident,Type)-> tcFieldExpr m tcEnv sigs comb f@(Field _ l e) =->   do->     tyEnv <- S.get->     let p = positionOfIdent l->     lty <- maybe (freshTypeVar ->	             >>= (\lty' -> ->		           S.modify ->		             (bindLabel l (qualifyWith m (mkIdent "#Rec"))->		                          (monoType lty'))->	                   >> return lty'))->                  inst->	           (sureLabelType l tyEnv)->     ty <- tcExpr m tcEnv sigs p e->     unify p "record" (text "Field:" <+> ppFieldExpr comb f) m lty ty->     return (l,ty)--\end{verbatim}-The function \texttt{tcArrow} checks that its argument can be used as-an arrow type $\alpha\rightarrow\beta$ and returns the pair-$(\alpha,\beta)$. Similarly, the function \texttt{tcBinary} checks-that its argument can be used as an arrow type-$\alpha\rightarrow\beta\rightarrow\gamma$ and returns the triple-$(\alpha,\beta,\gamma)$.-\begin{verbatim}--> tcArrow :: Position -> String -> Doc -> ModuleIdent -> Type->         -> TcState (Type,Type)-> tcArrow p what doc m ty =->   do->     theta <- S.lift S.get->     unaryArrow (subst theta ty)->   where unaryArrow (TypeArrow ty1 ty2) = return (ty1,ty2)->         unaryArrow (TypeVariable tv) =->           do->             alpha <- freshTypeVar->             beta <- freshTypeVar->             S.lift (S.modify (bindVar tv (TypeArrow alpha beta)))->             return (alpha,beta)->         unaryArrow ty = errorAt p (nonFunctionType what doc m ty)--> tcBinary :: Position -> String -> Doc -> ModuleIdent -> Type->          -> TcState (Type,Type,Type)-> tcBinary p what doc m ty = tcArrow p what doc m ty >>= uncurry binaryArrow->   where binaryArrow ty1 (TypeArrow ty2 ty3) = return (ty1,ty2,ty3)->         binaryArrow ty1 (TypeVariable tv) =->           do->             beta <- freshTypeVar->             gamma <- freshTypeVar->             S.lift (S.modify (bindVar tv (TypeArrow beta gamma)))->             return (ty1,beta,gamma)->         binaryArrow ty1 ty2 =->           errorAt p (nonBinaryOp what doc m (TypeArrow ty1 ty2))--\end{verbatim}-\paragraph{Unification}-The unification uses Robinson's algorithm (cf., e.g., Chap.~9-of~\cite{PeytonJones87:Book}).-\begin{verbatim}--> unify :: Position -> String -> Doc -> ModuleIdent -> Type -> Type->       -> TcState ()-> unify p what doc m ty1 ty2 =->   S.lift $->   do->     theta <- S.get->     let ty1' = subst theta ty1->     let ty2' = subst theta ty2->     either (errorAt p . typeMismatch what doc m ty1' ty2')->            (S.modify . compose)->            (unifyTypes m ty1' ty2')--> unifyTypes :: ModuleIdent -> Type -> Type -> Either Doc TypeSubst-> unifyTypes _ (TypeVariable tv1) (TypeVariable tv2)->   | tv1 == tv2 = Right idSubst->   | otherwise = Right (bindSubst tv1 (TypeVariable tv2) idSubst)-> unifyTypes m (TypeVariable tv) ty->   | tv `elem` typeVars ty = Left (recursiveType m tv ty)->   | otherwise = Right (bindSubst tv ty idSubst)-> unifyTypes m ty (TypeVariable tv)->   | tv `elem` typeVars ty = Left (recursiveType m tv ty)->   | otherwise = Right (bindSubst tv ty idSubst)-> unifyTypes _ (TypeConstrained tys1 tv1) (TypeConstrained tys2 tv2)->   | tv1 == tv2 = Right idSubst->   | tys1 == tys2 = Right (bindSubst tv1 (TypeConstrained tys2 tv2) idSubst)-> unifyTypes m (TypeConstrained tys tv) ty =->   foldr (choose . unifyTypes m ty) (Left (incompatibleTypes 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 (incompatibleTypes 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 (TypeRecord fs1 Nothing) tr2@(TypeRecord fs2 Nothing)->   | length fs1 == length fs2 = unifyTypedLabels m fs1 tr2-> unifyTypes m tr1@(TypeRecord fs1 Nothing) tr2@(TypeRecord fs2 (Just a2)) =->   either Left->          (\res -> either Left ->	                   (Right . compose res) ->                          (unifyTypes m (TypeVariable a2) tr1))->          (unifyTypedLabels m fs2 tr1)-> unifyTypes m tr1@(TypeRecord _ (Just _)) tr2@(TypeRecord _ Nothing) =->   unifyTypes m tr2 tr1-> unifyTypes m (TypeRecord fs1 (Just a1)) tr2@(TypeRecord fs2 (Just a2)) =->   let (fs1', rs1, rs2) = splitFields fs1 fs2->   in  either ->         Left->         (\res -> ->           either ->             Left ->	      (\res' -> Right (compose res res'))->	      (unifyTypeLists m [TypeVariable a1,->			         TypeRecord (fs1 ++ rs2) Nothing]->	                        [TypeVariable a2,->			         TypeRecord (fs2 ++ rs1) Nothing]))->         (unifyTypedLabels m fs1' tr2)->   where->   splitFields fs1 fs2 = split' [] [] fs2 fs1->   split' fs1' rs1 rs2 [] = (fs1',rs1,rs2)->   split' fs1' rs1 rs2 ((l,ty):fs1) =->     maybe (split' fs1' ((l,ty):rs1) rs2 fs1)->           (const (split' ((l,ty):fs1') rs1 (remove l rs2) fs1))->           (lookup l rs2)-> unifyTypes m ty1 ty2 = Left (incompatibleTypes 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 m ty1 ty2) (unifyTypeLists m tys1 tys2)->   where unifyTypesTheta m ty1 ty2 theta =->           either Left (Right . flip compose theta)->                  (unifyTypes m (subst theta ty1) (subst theta ty2))--> unifyTypedLabels :: ModuleIdent -> [(Ident,Type)] -> Type ->	           -> Either Doc TypeSubst-> unifyTypedLabels m [] (TypeRecord _ _) = Right idSubst-> unifyTypedLabels m ((l,ty):fs1) tr@(TypeRecord fs2 _) =->   either Left->          (\r -> ->            maybe (Left (missingLabel m l tr))->                  (\ty' -> ->		     either (const (Left (incompatibleLabelTypes m l ty ty')))->	                    (Right . flip compose r)->	                    (unifyTypes m ty ty'))->                  (lookup l fs2))->          (unifyTypedLabels m fs1 tr)-> unifyTypedLabels _ _ _ = internalError "unifyTypedLabels"--\end{verbatim}-For each declaration group, the type checker has to ensure that no-skolem type escapes its scope.-\begin{verbatim}--> checkSkolems :: Position -> ModuleIdent -> Doc -> ValueEnv -> Type->              -> TcState Type-> checkSkolems p m what tyEnv ty =->   do->     theta <- S.lift S.get->     let ty' = subst theta ty->         fs = fsEnv (subst theta tyEnv)->     unless (all (`Set.member` fs) (typeSkolems ty'))->            (errorAt p (skolemEscapingScope m what ty'))->     --error (show ty ++ " ## " ++ show (subst theta ty))->     return ty'--\end{verbatim}-\paragraph{Instantiation and Generalization}-We use negative offsets for fresh type variables.-\begin{verbatim}--> fresh :: (Int -> a) -> TcState a-> fresh f = liftM f (S.lift (S.lift (S.modify succ >> S.get)))--> freshVar :: (Int -> a) -> TcState a-> freshVar f = fresh (\n -> f (- n - 1))--> freshTypeVar :: TcState Type-> freshTypeVar = freshVar TypeVariable--> freshConstrained :: [Type] -> TcState Type-> freshConstrained tys = freshVar (TypeConstrained tys)--> freshSkolem :: TcState Type-> freshSkolem = fresh TypeSkolem--> inst :: TypeScheme -> TcState Type-> inst (ForAll n ty) =->   do->     tys <- replicateM n freshTypeVar->     return (expandAliasType tys ty)--> instExist :: ExistTypeScheme -> TcState Type-> instExist (ForAllExist n n' ty) =->   do->     tys <- replicateM (n + n') freshTypeVar->     return (expandAliasType tys ty)--> skol :: ExistTypeScheme -> TcState 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..]--\end{verbatim}-\paragraph{Auxiliary Functions}-The functions \texttt{constrType}, \texttt{varType}, and-\texttt{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 \texttt{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.-\begin{verbatim}--> 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 ("constrType " ++ show c)--> varType :: Ident -> ValueEnv -> TypeScheme-> varType v tyEnv =->   case lookupValue v tyEnv of->     Value _ sigma : _ -> sigma->     _ -> internalError ("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->     vs -> case (qualLookupValue (qualQualify m f) tyEnv) of->             [Value _ sigma] -> sigma->             _ -> internalError ("funType " ++ show f)--> sureLabelType :: Ident -> ValueEnv -> Maybe TypeScheme-> sureLabelType l tyEnv =->   case lookupValue l tyEnv of->     Label _ _ sigma : _ -> Just sigma->     _ -> Nothing---\end{verbatim}-The function \texttt{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.-\begin{verbatim}--> 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)--> expandPolyType :: ModuleIdent -> TCEnv -> TypeExpr -> TypeScheme-> expandPolyType m tcEnv ty = ->     polyType $ normalize $ expandMonoType m tcEnv [] ty--> 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 ("expandType " ++ show tc)->   where tys' = map (expandType m tcEnv) tys-> expandType _ _ (TypeVariable tv) = TypeVariable tv-> expandType _ _ (TypeConstrained tys tv) = TypeConstrained tys tv-> expandType m tcEnv (TypeArrow ty1 ty2) =->   TypeArrow (expandType m tcEnv ty1) (expandType m tcEnv ty2)-> expandType _ tcEnv (TypeSkolem k) = TypeSkolem k-> expandType m tcEnv (TypeRecord fs rv) =->   TypeRecord (map (\ (l,ty) -> (l, expandType m tcEnv ty)) fs) rv--\end{verbatim}-The functions \texttt{fvEnv} and \texttt{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.-\begin{verbatim}--> fvEnv :: ValueEnv -> Set.Set Int-> fvEnv tyEnv =->   Set.fromList [tv | ty <- localTypes tyEnv, tv <- typeVars ty, tv < 0]--> fsEnv :: ValueEnv -> Set.Set Int-> fsEnv tyEnv = Set.unions (map (Set.fromList . typeSkolems) (localTypes tyEnv))--> localTypes :: ValueEnv -> [Type]-> localTypes tyEnv = [ty | (_,Value _ (ForAll _ ty)) <- localBindings tyEnv]--\end{verbatim}-Miscellaneous functions.-\begin{verbatim}--> remove :: Eq a => a -> [(a,b)] -> [(a,b)]-> remove _ [] = []-> remove k ((k',e):kes) | k == k'   = kes->		        | otherwise = (k',e):(remove k kes) --\end{verbatim}-Error functions.-\begin{verbatim}--> recursiveTypes :: [Ident] -> (Position,String)-> recursiveTypes [tc] = ->     (positionOfIdent tc,->      "Recursive synonym type " ++ name tc)-> recursiveTypes (tc:tcs) =->  (positionOfIdent tc,->   "Recursive synonym types " ++ name tc ++ types "" tcs)->   where types comma [tc] = comma ++ " and " ++ name tc ++->                            showLine (positionOfIdent tc) ->         types _ (tc:tcs) = ", " ++ name tc ++ ->                            showLine (positionOfIdent tc) ++ ->                            types "," tcs--> polymorphicFreeVar :: Ident -> (Position,String)-> polymorphicFreeVar v =->  (positionOfIdent v,->   "Free variable " ++ name v ++ " has a polymorphic type")--> typeSigTooGeneral :: ModuleIdent -> Doc -> TypeExpr -> TypeScheme -> String-> typeSigTooGeneral m what ty sigma = show $->   vcat [text "Type signature too general", what,->         text "Inferred type:" <+> ppTypeScheme m sigma,->         text "Type signature:" <+> ppTypeExpr 0 ty]--> nonFunctionType :: String -> Doc -> ModuleIdent -> Type -> String-> nonFunctionType what doc m ty = show $->   vcat [text "Type error in" <+> text what, doc,->         text "Type:" <+> ppType m ty,->         text "Cannot be applied"]--> nonBinaryOp :: String -> Doc -> ModuleIdent -> Type -> String-> nonBinaryOp what doc m ty = show $->   vcat [text "Type error in" <+> text what, doc,->         text "Type:" <+> ppType m ty,->         text "Cannot be used as binary operator"]--> typeMismatch :: String -> Doc -> ModuleIdent -> Type -> Type -> Doc -> String-> typeMismatch what doc m ty1 ty2 reason = show $->   vcat [text "Type error in" <+> text what, doc,->         text "Inferred type:" <+> ppType m ty2,->         text "Expected type:" <+> ppType m ty1,->         reason]--> skolemEscapingScope :: ModuleIdent -> Doc -> Type -> String-> skolemEscapingScope m what ty = show $->   vcat [text "Existential type escapes out of its scope", what,->         text "Type:" <+> ppType m ty]--> recursiveType :: ModuleIdent -> Int -> Type -> Doc-> recursiveType m tv ty = incompatibleTypes m (TypeVariable tv) ty--> missingLabel :: ModuleIdent -> Ident -> Type -> Doc-> missingLabel m l rty =->   sep [text "Missing field for label" <+> ppIdent l,->        text "in the record type" <+> ppType m rty]--> incompatibleTypes :: ModuleIdent -> Type -> Type -> Doc-> incompatibleTypes m ty1 ty2 =->   sep [text "Types" <+> ppType m ty1,->        nest 2 (text "and" <+> ppType m ty2),->        text "are incompatible"]--> incompatibleLabelTypes :: ModuleIdent -> Ident -> Type -> Type -> Doc-> incompatibleLabelTypes m l ty1 ty2 =->   sep [text "Labeled types" <+> ppIdent l <> text "::" <> ppType m ty1,->        nest 10 (text "and" <+> ppIdent l <> text "::" <> ppType m ty2),->        text "are incompatible"]--\end{verbatim}---\end{verbatim}-The following functions implement pretty-printing for types.-\begin{verbatim}--> ppType :: ModuleIdent -> Type -> Doc-> ppType m = ppTypeExpr 0 . fromQualType m--> ppTypeScheme :: ModuleIdent -> TypeScheme -> Doc-> ppTypeScheme m (ForAll _ ty) = ppType m ty
− src/TypeSubst.lhs 
@@ -1,104 +0,0 @@--% $Id: TypeSubst.lhs,v 1.2 2004/02/08 22:14:01 wlux Exp $-%-% Copyright (c) 2003, Wolfgang Lux-% See LICENSE for the full license.-%-\nwfilename{TypeSubst.lhs}-\section{Type Substitutions}-This module implements substitutions on types.-\begin{verbatim}--> module TypeSubst(module TypeSubst, idSubst,bindSubst,compose) where---> import Data.Maybe-> import Data.List--> import Types--> import Subst-> import Base-> import TopEnv--> 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 sigma (TypeSkolem k) = TypeSkolem k->   subst sigma (TypeRecord fs rv)->     | isJust rv =->       case substVar sigma (fromJust rv) of->         TypeVariable tv -> TypeRecord fs' (Just tv)->         ty -> ty->     | otherwise = TypeRecord fs' Nothing->    where fs' = map (\ (l,ty) -> (l, subst sigma ty)) fs--> 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 theta (DataConstructor c ty) = DataConstructor c ty->   subst theta (NewtypeConstructor c ty) = NewtypeConstructor c ty->   subst theta (Value v ty) = Value v (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--\end{verbatim}-The function \texttt{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 \verb|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-\texttt{normalize}.-\begin{verbatim}--> 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 _ (TypeSkolem k) = TypeSkolem k-> expandAliasType tys (TypeRecord fs rv)->   | isJust rv =->     let (TypeVariable tv) = expandAliasType tys (TypeVariable (fromJust rv))->     in  TypeRecord fs' (Just tv)->   | otherwise =->     TypeRecord fs' Nothing->  where fs' = map (\ (l,ty) -> (l, expandAliasType tys ty)) fs--> normalize :: Type -> Type-> normalize ty = expandAliasType [TypeVariable (occur tv) | tv <- [0..]] ty->   where tvs = zip (nub (filter (>= 0) (typeVars ty))) [0..]->         occur tv = fromJust (lookup tv tvs)--\end{verbatim}
− src/Types.lhs 
@@ -1,251 +0,0 @@-% $Id: Types.lhs,v 1.11 2004/02/08 22:14:02 wlux Exp $-%-% Copyright (c) 2002, Wolfgang Lux-% See LICENSE for the full license.-%-% Modified by Martin Engelke (men@informatik.uni-kiel.de)-%-\nwfilename{Types.lhs}-\section{Types}-This module modules provides the definitions for the internal -representation of types in the compiler.-\begin{verbatim}--> module Types where--> import Data.List-> import Data.Maybe--> import Curry.Base.Ident--\end{verbatim}-A type is either a type variable, an application of a type constructor-to a list of arguments, or an arrow type. The \texttt{TypeConstrained}-case is used for representing type variables that are restricted to a-particular set of types. At present, this is used for typing guard-expressions, which are restricted to be either of type \texttt{Bool}-or of type \texttt{Success}, and integer literals, which are-restricted to types \texttt{Int} and \texttt{Float}. If the type is-not restricted it defaults to the first type from the constraint list.-The case \texttt{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 \texttt{TypeConstrained} variables use indices-as well, these variables must never be quantified.-\begin{verbatim}--> data Type =->     TypeConstructor QualIdent [Type]->   | TypeVariable Int->   | TypeConstrained [Type] Int->   | TypeArrow Type Type->   | TypeSkolem Int->   | TypeRecord [(Ident,Type)] (Maybe Int)->   deriving (Show, Eq)--\end{verbatim}-The function \texttt{isArrowType} checks whether a type is a function-type $t_1 \rightarrow t_2 \rightarrow \dots \rightarrow t_n$ . The-function \texttt{arrowArity} computes the arity $n$ of a function type-and \texttt{arrowBase} returns the type $t_n$.-\begin{verbatim}--> 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 ty = []--> arrowBase :: Type -> Type-> arrowBase (TypeArrow _ ty) = arrowBase ty-> arrowBase ty = ty--\end{verbatim}-The functions \texttt{typeVars}, \texttt{typeConstrs},-\texttt{typeSkolems} return a list of all type variables, type-constructors, or skolems occurring in a type $t$, respectively. Note-that \texttt{TypeConstrained} variables are not included in the set of-type variables because they cannot be generalized.-\begin{verbatim}--> 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->         vars (TypeRecord fs rtv) tvs =->             foldr vars (maybe tvs (: tvs) rtv) (map snd fs)--> typeConstrs :: Type -> [QualIdent]-> typeConstrs ty = types ty []->   where types (TypeConstructor tc tys) tcs = tc : foldr types tcs tys->         types (TypeVariable _) tcs = tcs->         types (TypeConstrained _ _) tcs = tcs->         types (TypeArrow ty1 ty2) tcs = types ty1 (types ty2 tcs)->         types (TypeSkolem _) tcs = tcs->         types (TypeRecord fs _) tcs =->             foldr types tcs (map snd fs)--> 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->         skolems (TypeRecord fs _) sks =->             foldr skolems sks (map snd fs)--> equTypes :: Type -> Type -> Bool-> equTypes t1 t2 = fst (equ [] t1 t2)->  where ->  equ is (TypeConstructor qid1 ts1) (TypeConstructor qid2 ts2)->     | qid1 == qid2 = equs is ts1 ts2->     | otherwise    = (False, is)->  equ is (TypeVariable i1) (TypeVariable i2)->     = maybe (True, (i1,i2):is) ->             (\ i2' -> (i2 == i2', is))->             (lookup i1 is)->  equ is (TypeConstrained ts1 i1) (TypeConstrained ts2 i2)->     = let (res, is') = equs is ts1 ts2->       in  maybe (res, (i1,i2):is')->                 (\ i2' -> (res && i2 == i2', is'))->                 (lookup i1 is')->  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)->     = maybe (True, (i1,i2):is)->             (\ i2' -> (i2 == i2', is))->             (lookup i1 is)->  equ is (TypeRecord fs1 r1) (TypeRecord fs2 r2)->     | isJust r1 && isJust r2->       = let (res1, is1) = equ is (TypeVariable (fromJust r1))->		                   (TypeVariable (fromJust r2))->             (res2, is2) = equRecords is1 fs1 fs2->         in  (res1 && res2, is2)->     | isNothing r1 && isNothing r2 = equRecords is fs1 fs2->     | otherwise = (False, is)->  equ is _ _ = (False, is)->	->  equRecords is fs1 fs2 | length fs1 == length fs2 = equrec is fs1 fs2->		         | otherwise = (False, is)->    where->    equrec is [] fs2 = (True, is)->    equrec is ((l,t):fs1) fs2->       = let (res1, is1) = maybe (False,is) (equ is t) (lookup l fs2)->             (res2, is2) = equrec is1 fs1 fs2->         in  (res1 && res2, is2)->->  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)--\end{verbatim}-We support two kinds of quantifications of types here, universally-quantified type schemes $\forall\overline{\alpha} .-\tau(\overline{\alpha})$ and universally and existentially quantified-type schemes $\forall\overline{\alpha} \exists\overline{\eta} .-\tau(\overline{\alpha},\overline{\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 \texttt{ForAll} and \texttt{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.-\begin{verbatim}--> data TypeScheme = ForAll Int Type deriving (Show, Eq)-> data ExistTypeScheme = ForAllExist Int Int Type deriving (Show, Eq)--\end{verbatim}-The functions \texttt{monoType} and \texttt{polyType} translate a type-$\tau$ into a monomorphic type scheme $\forall.\tau$ and a polymorphic-type scheme $\forall\overline{\alpha}.\tau$ where $\overline{\alpha} =-\textrm{fv}(\tau)$, respectively. \texttt{polyType} assumes that all-universally quantified variables in the type are assigned indices-starting with 0 and does not renumber the variables.-\begin{verbatim}--> monoType, polyType :: Type -> TypeScheme-> monoType ty = ForAll 0 ty-> polyType ty = ForAll (maximum (-1 : typeVars ty) + 1) ty--\end{verbatim}-There are a few predefined types:-\begin{verbatim}--> unitType,boolType,charType,intType,floatType,stringType,successType :: Type-> unitType = primType unitId []-> boolType = primType boolId []-> charType = primType charId []-> intType = primType intId []-> floatType = primType floatId []-> stringType = listType charType-> successType = primType successId []--> listType,ioType :: Type -> Type-> listType ty = primType listId [ty]-> ioType ty = primType ioId [ty]--> tupleType :: [Type] -> Type-> tupleType tys = primType (tupleId (length tys)) tys--> primType :: Ident -> [Type] -> Type-> primType = TypeConstructor . qualifyWith preludeMIdent--> typeVar :: Int -> Type-> typeVar = TypeVariable--\end{verbatim}----> 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 _ (TypeVariable tv) = TypeVariable tv-> qualifyType m (TypeConstrained tys tv) =->   TypeConstrained (map (qualifyType m) tys) tv-> qualifyType m (TypeArrow ty1 ty2) =->   TypeArrow (qualifyType m ty1) (qualifyType m ty2)-> qualifyType _ (TypeSkolem k) = TypeSkolem k-> qualifyType m (TypeRecord fs rty) =->   TypeRecord (map (\ (l,ty) -> (l, qualifyType m ty)) fs) rty---> unqualifyType :: ModuleIdent -> Type -> Type-> unqualifyType m (TypeConstructor tc tys) =->   TypeConstructor (qualUnqualify m tc) (map (unqualifyType m) tys)-> unqualifyType _ (TypeVariable tv) = TypeVariable tv-> unqualifyType m (TypeConstrained tys tv) =->   TypeConstrained (map (unqualifyType m) tys) tv-> unqualifyType m (TypeArrow ty1 ty2) =->   TypeArrow (unqualifyType m ty1) (unqualifyType m ty2)-> unqualifyType m (TypeSkolem k) = TypeSkolem k-> unqualifyType m (TypeRecord fs rty) =->   TypeRecord (map (\ (l,ty) -> (l, unqualifyType m ty)) fs) rty-
− src/Typing.lhs 
@@ -1,406 +0,0 @@--% $Id: Typing.lhs,v 1.7 2004/02/12 19:13:12 wlux Exp $-%-% Copyright (c) 2003-2006, Wolfgang Lux-% See LICENSE for the full license.-%-\nwfilename{Typing.lhs}-\section{Computing the Type of Curry Expressions}-\begin{verbatim}--> module Typing(Typeable(..)) where--> import Data.Maybe-> import Control.Monad-> import Control.Monad.State as S--> import Curry.Base.Ident-> import Curry.Syntax-> import Curry.Syntax.Utils--> import Types-> import Base-> import TypeSubst-> import TopEnv-> import Utils---\end{verbatim}-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 \texttt{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 introduce 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.\footnote{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 \texttt{computeType} always uses indices-starting at 0 for the fresh type variables. In order to avoid these-problems, \texttt{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 \texttt{typeOf}) and only-twice while compiling the standard \texttt{IO} module (for 21-applications of \texttt{typeOf}).\footnote{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.}-\begin{verbatim}--> type TyState a = S.StateT TypeSubst (S.State Int) a--> run :: TyState a -> ValueEnv -> a-> run m tyEnv = S.evalState (S.evalStateT m idSubst) 0--> class Typeable a where->   typeOf :: ValueEnv -> a -> Type--> instance Typeable Ident where->   typeOf = computeType identType--> instance Typeable ConstrTerm where->   typeOf = computeType argType--> instance Typeable Expression where->   typeOf = computeType exprType--> instance Typeable Rhs where->   typeOf = computeType rhsType--> computeType f tyEnv x = normalize (run doComputeType tyEnv)->   where doComputeType =->           do->             ty <- f tyEnv x->             theta <- S.get->             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 = [ty | (_,Value _ (ForAll _ ty)) <- localBindings tyEnv]--> identType :: ValueEnv -> Ident -> TyState Type-> identType tyEnv x = instUniv (varType x tyEnv)--> litType :: ValueEnv -> Literal -> TyState Type-> litType _ (Char _ _)    = return charType-> litType tyEnv (Int v _) = identType tyEnv v-> litType _ (Float _ _)   = return floatType-> litType _ (String _ _)  = return stringType--> argType :: ValueEnv -> ConstrTerm -> TyState Type-> argType tyEnv (LiteralPattern l) = litType tyEnv l-> argType tyEnv (NegativePattern _ l) = litType tyEnv l-> argType tyEnv (VariablePattern v) = identType tyEnv v-> argType tyEnv (ConstructorPattern c ts) =->   do->     ty <- instUnivExist (constrType c tyEnv)->     tys <- mapM (argType tyEnv) ts->     unifyList (init (flatten ty)) tys->     return (last (flatten ty))->   where flatten (TypeArrow ty1 ty2) = ty1 : flatten ty2->         flatten ty = [ty]-> argType tyEnv (InfixPattern t1 op t2) =->   argType tyEnv (ConstructorPattern op [t1,t2])-> argType tyEnv (ParenPattern t) = argType tyEnv t-> argType tyEnv (TuplePattern _ ts)->   | null ts = return unitType->   | otherwise = liftM tupleType $ mapM (argType tyEnv) ts-> argType tyEnv (ListPattern _ ts) = freshTypeVar >>= flip elemType ts->   where elemType ty [] = return (listType ty)->         elemType ty (t:ts) =->           argType tyEnv t >>= unify ty >> elemType ty ts-> argType tyEnv (AsPattern v _) = argType tyEnv (VariablePattern v)-> argType tyEnv (LazyPattern _ t) = argType tyEnv t-> argType tyEnv (FunctionPattern f ts) =->   do ->     ty <- instUniv (funType f tyEnv)->     tys <- mapM (argType tyEnv) ts->     unifyList (init (flatten ty)) tys->     return (last (flatten ty))->   where flatten (TypeArrow ty1 ty2) = ty1 : flatten ty2->         flatten ty = [ty]-> argType tyEnv (InfixFuncPattern t1 op t2) =->   argType tyEnv (FunctionPattern op [t1,t2])-> argType tyEnv (RecordPattern fs r)->   | isJust r =->     do->       tys <- mapM (fieldPattType tyEnv) fs->       rty <- argType tyEnv (fromJust r)->       (TypeVariable i) <- freshTypeVar->       unify rty (TypeRecord tys (Just i))->       return rty->   | otherwise =->     do->       tys <- mapM (fieldPattType tyEnv) fs->       return (TypeRecord tys Nothing)--> fieldPattType :: ValueEnv -> Field ConstrTerm -> TyState (Ident,Type)-> fieldPattType tyEnv (Field _ l t) =->   do->     lty <- instUniv (labelType l tyEnv)->     ty <- argType tyEnv t->     unify lty ty->     return (l,lty)--> exprType :: ValueEnv -> Expression -> TyState Type-> exprType tyEnv (Literal l) = litType tyEnv l-> exprType tyEnv (Variable v) = instUniv (funType v tyEnv)-> exprType tyEnv (Constructor c) = instUnivExist (constrType c tyEnv)-> exprType tyEnv (Typed e _) = exprType tyEnv e-> exprType tyEnv (Paren e) = exprType tyEnv e-> exprType tyEnv (Tuple _ es)->   | null es = return unitType->   | otherwise = liftM tupleType $ mapM (exprType tyEnv) es-> exprType tyEnv (List _ es) = freshTypeVar >>= flip elemType es->   where elemType ty [] = return (listType ty)->         elemType ty (e:es) =->           exprType tyEnv e >>= unify ty >> elemType ty es-> exprType tyEnv (ListCompr _ e _) = liftM listType $ exprType tyEnv e-> exprType tyEnv (EnumFrom _) = return (listType intType)-> exprType tyEnv (EnumFromThen _ _) = return (listType intType)-> exprType tyEnv (EnumFromTo _ _) = return (listType intType)-> exprType tyEnv (EnumFromThenTo _ _ _) = return (listType intType)-> exprType tyEnv (UnaryMinus _ e) = exprType tyEnv e-> exprType tyEnv (Apply e1 e2) =->   do->     (ty1,ty2) <- exprType tyEnv e1 >>= unifyArrow->     exprType tyEnv e2 >>= unify ty1->     return ty2-> exprType tyEnv (InfixApply e1 op e2) =->   do->     (ty1,ty2,ty3) <- exprType tyEnv (infixOp op) >>= unifyArrow2->     exprType tyEnv e1 >>= unify ty1->     exprType tyEnv e2 >>= unify ty2->     return ty3-> exprType tyEnv (LeftSection e op) =->   do->     (ty1,ty2,ty3) <- exprType tyEnv (infixOp op) >>= unifyArrow2->     exprType tyEnv e >>= unify ty1->     return (TypeArrow ty2 ty3)-> exprType tyEnv (RightSection op e) =->   do->     (ty1,ty2,ty3) <- exprType tyEnv (infixOp op) >>= unifyArrow2->     exprType tyEnv e >>= unify ty2->     return (TypeArrow ty1 ty3)-> exprType tyEnv (Lambda _ args e) =->   do->     tys <- mapM (argType tyEnv) args->     ty <- exprType tyEnv e->     return (foldr TypeArrow ty tys)-> exprType tyEnv (Let _ e) = exprType tyEnv e-> exprType tyEnv (Do _ e) = exprType tyEnv e-> exprType tyEnv (IfThenElse _ e1 e2 e3) =->   do->     exprType tyEnv e1 >>= unify boolType->     ty2 <- exprType tyEnv e2->     ty3 <- exprType tyEnv e3->     unify ty2 ty3->     return ty3-> exprType tyEnv (Case _ _ alts) = freshTypeVar >>= flip altType alts->   where altType ty [] = return ty->         altType ty (Alt _ _ rhs:alts) =->           rhsType tyEnv rhs >>= unify ty >> altType ty alts-> exprType tyEnv (RecordConstr fs) =->   do ->     tys <- mapM (fieldExprType tyEnv) fs->     return (TypeRecord tys Nothing)-> exprType tyEnv (RecordSelection r l) =->   do ->     lty <- instUniv (labelType l tyEnv)->     rty <- exprType tyEnv r->     (TypeVariable i) <- freshTypeVar->     unify rty (TypeRecord [(l,lty)] (Just i))->     return lty-> exprType tyEnv (RecordUpdate fs r) =->   do->     tys <- mapM (fieldExprType tyEnv) fs->     rty <- exprType tyEnv r->     (TypeVariable i) <- freshTypeVar->     unify rty (TypeRecord tys (Just i))->     return rty--> rhsType :: ValueEnv -> Rhs -> TyState Type-> rhsType tyEnv (SimpleRhs _ e _) = exprType tyEnv e-> rhsType tyEnv (GuardedRhs es _) = freshTypeVar >>= flip condExprType es->   where condExprType ty [] = return ty->         condExprType ty (CondExpr _ _ e:es) =->           exprType tyEnv e >>= unify ty >> condExprType ty es--> fieldExprType :: ValueEnv -> Field Expression -> TyState (Ident,Type)-> fieldExprType tyEnv (Field _ l e) =->   do->     lty <- instUniv (labelType l tyEnv)->     ty <- exprType tyEnv e->     unify lty ty->     return (l,lty)--\end{verbatim}-In order to avoid name conflicts with non-generalized type variables-in a type we instantiate quantified type variables using non-negative-offsets here.-\begin{verbatim}--> freshTypeVar :: TyState Type-> freshTypeVar = liftM TypeVariable $ S.lift (S.modify succ >> S.get)--> instType :: Int -> Type -> TyState Type-> instType n ty =->   do->     tys <- sequence (replicate n freshTypeVar)->     return (expandAliasType tys ty)--> instUniv :: TypeScheme -> TyState Type-> instUniv (ForAll n ty) = instType n ty--> instUnivExist :: ExistTypeScheme -> TyState Type-> instUnivExist (ForAllExist n n' ty) = instType (n + n') ty--\end{verbatim}-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.-\begin{verbatim}--> unify :: Type -> Type -> TyState ()-> unify ty1 ty2 =->   S.modify (\theta -> unifyTypes (subst theta ty1) (subst theta ty2) theta)--> unifyList :: [Type] -> [Type] -> TyState ()-> unifyList tys1 tys2 = sequence_ (zipWith unify tys1 tys2)--> unifyArrow :: Type -> TyState (Type,Type)-> unifyArrow ty =->   do->     theta <- S.get->     case subst theta ty of->       TypeVariable tv->         | tv >= 0 ->->             do->               ty1 <- freshTypeVar->               ty2 <- freshTypeVar->               S.modify (bindVar tv (TypeArrow ty1 ty2))->               return (ty1,ty2)->       TypeArrow ty1 ty2 -> return (ty1,ty2)->       ty' -> internalError ("unifyArrow (" ++ show ty' ++ ")")--> unifyArrow2 :: Type -> TyState (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 tys1 tv1) (TypeConstrained tys2 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 (TypeRecord fs1 Nothing) (TypeRecord fs2 Nothing) theta->   | length fs1 == length fs2 = foldr (unifyTypedLabels fs1) theta fs2-> unifyTypes tr1@(TypeRecord fs1 Nothing) (TypeRecord fs2 (Just a2)) theta =->   unifyTypes (TypeVariable a2)->              tr1->              (foldr (unifyTypedLabels fs1) theta fs2)-> unifyTypes tr1@(TypeRecord _ (Just _)) tr2@(TypeRecord _ Nothing) theta =->   unifyTypes tr2 tr1 theta-> unifyTypes (TypeRecord fs1 (Just a1)) (TypeRecord fs2 (Just a2)) theta =->   unifyTypes (TypeVariable a1)->              (TypeVariable a2)->              (foldr (unifyTypedLabels fs1) theta fs2)-> unifyTypes ty1 ty2 _ =->   internalError ("unify: (" ++ show ty1 ++ ") (" ++ show ty2 ++ ")")--> unifyTypedLabels :: [(Ident,Type)] -> (Ident,Type) -> TypeSubst -> TypeSubst-> unifyTypedLabels fs1 (l,ty) theta =->   maybe theta (\ty1 -> unifyTypes ty1 ty theta) (lookup l fs1)--\end{verbatim}-The functions \texttt{constrType}, \texttt{varType}, and-\texttt{funType} are used for computing the type of constructors,-pattern variables, and variables.--\ToDo{These functions should be shared with the type checker.}-\begin{verbatim}--> constrType :: QualIdent -> ValueEnv -> ExistTypeScheme-> constrType c tyEnv =->   case qualLookupValue c tyEnv of->     [DataConstructor _ sigma] -> sigma->     [NewtypeConstructor _ sigma] -> sigma->     _ -> internalError ("constrType " ++ show c)--> varType :: Ident -> ValueEnv -> TypeScheme-> varType v tyEnv =->   case lookupValue v tyEnv of->     [Value _ sigma] -> sigma->     _ -> internalError ("varType " ++ show v)--> funType :: QualIdent -> ValueEnv -> TypeScheme-> funType f tyEnv =->   case qualLookupValue f tyEnv of->     [Value _ sigma] -> sigma->     _ -> internalError ("funType " ++ show f)--> labelType :: Ident -> ValueEnv -> TypeScheme-> labelType l tyEnv =->   case lookupValue l tyEnv of->     [Label _ _ sigma] -> sigma->     _ -> internalError ("labelType " ++ show l)--\end{verbatim}
− src/Utils.lhs 
@@ -1,92 +0,0 @@-% $Id: Utils.lhs,v 1.4 2003/10/04 17:04:38 wlux Exp $-%-% Copyright (c) 2001-2003, Wolfgang Lux-% See LICENSE for the full license.-%-\nwfilename{Utils.lhs}-\section{Utility Functions}-The module \texttt{Utils} provides a few simple functions that are-commonly used in the compiler, but not implemented in the Haskell-\texttt{Prelude} or standard library.-\begin{verbatim}--> module Utils where--> infixr 5 ++!--\end{verbatim}-\paragraph{Triples}-The \texttt{Prelude} does not contain standard functions for-triples. We provide projection, (un-)currying, and mapping for triples-here.-\begin{verbatim}--> fst3 (x,_,_) = x-> snd3 (_,y,_) = y-> thd3 (_,_,z) = z--> apFst3 f (x,y,z) = (f x,y,z)-> apSnd3 f (x,y,z) = (x,f y,z)-> apThd3 f (x,y,z) = (x,y,f z)--> curry3 f x y z = f (x,y,z)-> uncurry3 f (x,y,z) = f x y z--\end{verbatim}-\paragraph{Lists}-The function \texttt{(++!)} is variant of the list concatenation-operator \texttt{(++)} 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 \texttt{!} in the name.-\begin{verbatim}--> (++!) :: [a] -> [a] -> [a]-> xs ++! ys = if null xs then ys else xs--\end{verbatim}-\paragraph{Strict fold}-The function \texttt{foldl\_strict} is a strict version of-\texttt{foldl}, i.e., it evaluates the binary applications before-the recursion. This has the advantage that \texttt{foldl\_strict} does-not construct a large application which is then evaluated in the base-case of the recursion.-\begin{verbatim}--foldl_strict :: (a -> b -> a) -> a -> [b] -> a-foldl_strict = foldl'---\end{verbatim}-\paragraph{Folding with two lists}-Fold operations with two arguments lists can be defined using-\texttt{zip} and \texttt{foldl} or \texttt{foldr}, resp. Our-definitions are unfolded for efficiency reasons.-\begin{verbatim}--> foldl2 :: (a -> b -> c -> a) -> a -> [b] -> [c] -> a-> foldl2 f z []     _      = z-> foldl2 f 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 f z []     _      = z-> foldr2 f z _      []     = z-> foldr2 f z (x:xs) (y:ys) = f x y (foldr2 f z xs ys)--\end{verbatim}-\paragraph{Monadic fold with an accumulator}-The function \texttt{mapAccumM} is a generalization of-\texttt{mapAccumL} to monads like \texttt{foldM} is for-\texttt{foldl}.-\begin{verbatim}--> 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)--\end{verbatim}
− src/WarnCheck.hs 
@@ -1,872 +0,0 @@-------------------------------------------------------------------------------------- WarnCheck - Searches for potentially irregular code and generates---             warning messages---                --- February 2006,--- Martin Engelke (men@informatik.uni-kiel.de)----module WarnCheck (warnCheck) where--import Control.Monad.State-import qualified Data.Map as Map-import Data.List--import Curry.Base.Ident-import Curry.Base.Position-import Curry.Base.MessageMonad-import Curry.Syntax--import Base (ValueEnv, ValueInfo(..), qualLookupValue)-import TopEnv-import qualified ScopeEnv-import ScopeEnv (ScopeEnv)-------------------------------------------------------------------------------------- Data type for representing the current state of generating warnings.--- The monadic representation of the state allows the usage of monadic --- syntax (do expression) for dealing easier and safer with its--- contents.--type CheckState = State CState--data CState = CState {messages  :: [WarnMsg],-		      scope     :: ScopeEnv QualIdent IdInfo,-		      values    :: ValueEnv,-		      moduleId  :: ModuleIdent }---- Runs a 'CheckState' action and returns the list of messages-run ::  CheckState a -> [WarnMsg]-run f-   = reverse (messages (execState f emptyState))--emptyState :: CState-emptyState = CState {messages  = [],-		     scope     = ScopeEnv.new,-		     values    = emptyTopEnv,-		     moduleId  = mkMIdent []-		    }------------------------------------------------------------------------------------- Find potentially incorrect code in a Curry program and generate--- the following warnings for:---    - unreferenced variables---    - shadowing variables---    - idle case alternatives---    - overlapping case alternatives---    - function rules which are not together-warnCheck :: ModuleIdent -> ValueEnv -> [Decl] -> [Decl] -> [WarnMsg]-warnCheck mid vals imports decls-   = run (do addImportedValues vals-	     addModuleId mid-	     checkImports imports-	     foldM' insertDecl decls-	     foldM' (checkDecl mid) decls-             checkDeclOccurrences decls-	 )-----------------------------------------------------------------------------------------------------------------------------------------------------------------------checkDecl :: ModuleIdent -> Decl -> CheckState ()-checkDecl mid (DataDecl pos ident params cdecls)-   = do beginScope-	foldM' insertTypeVar params-	foldM' (checkConstrDecl mid) cdecls-	params' <- filterM isUnrefTypeVar params-	when (not (null params')) -	     (foldM' genWarning' (map unrefTypeVar params'))-	endScope-checkDecl mid (TypeDecl _ ident params texpr)-   = do beginScope-	foldM' insertTypeVar params-	checkTypeExpr mid texpr-	params' <- filterM isUnrefTypeVar params-	when (not (null params'))-	     (foldM' genWarning'  (map unrefTypeVar params'))-	endScope-checkDecl mid (FunctionDecl pos ident equs)-   = do beginScope-	foldM' (checkEquation mid) equs-	c <- isConsId ident-	idents' <- returnUnrefVars-	when (not (c || null idents')) -             (foldM' genWarning' (map unrefVar idents'))-	endScope-checkDecl mid (PatternDecl _ cterm rhs)-   = do checkConstrTerm mid cterm-	checkRhs mid rhs-checkDecl _ _ = return ()---- Checks locally declared identifiers (i.e. functions and logic variables)--- for shadowing-checkLocalDecl :: Decl -> CheckState ()-checkLocalDecl (FunctionDecl pos ident _)-   = do s <- isShadowingVar ident-	when s (genWarning' (shadowingVar ident))-checkLocalDecl (ExtraVariables pos idents)-   = do idents' <- filterM isShadowingVar idents-	when (not (null idents'))-	     (foldM' genWarning' (map shadowingVar idents'))-checkLocalDecl (PatternDecl _ constrTerm _)-   = checkConstrTerm (mkMIdent []) constrTerm-checkLocalDecl _ = return ()-----checkConstrDecl :: ModuleIdent -> ConstrDecl -> CheckState ()-checkConstrDecl mid (ConstrDecl _ _ ident texprs)-   = do visitId ident-	foldM' (checkTypeExpr mid) texprs-checkConstrDecl mid (ConOpDecl _ _ texpr1 ident texpr2)-   = do visitId ident-	checkTypeExpr mid texpr1-	checkTypeExpr mid texpr2---checkTypeExpr :: ModuleIdent -> TypeExpr -> CheckState ()-checkTypeExpr mid (ConstructorType qid texprs)-   = do maybe (return ()) visitTypeId (localIdent mid qid)-	foldM' (checkTypeExpr mid ) texprs-checkTypeExpr mid  (VariableType ident)-   = visitTypeId ident-checkTypeExpr mid  (TupleType texprs)-   = foldM' (checkTypeExpr mid ) texprs-checkTypeExpr mid  (ListType texpr)-   = checkTypeExpr mid  texpr-checkTypeExpr mid  (ArrowType texpr1 texpr2)-   = do checkTypeExpr mid  texpr1-	checkTypeExpr mid  texpr2-checkTypeExpr mid  (RecordType fields restr)-   = do foldM' (checkTypeExpr mid ) (map snd fields)-	maybe (return ()) (checkTypeExpr mid ) restr-----checkEquation :: ModuleIdent -> Equation -> CheckState ()-checkEquation mid (Equation _ lhs rhs)-   = do checkLhs mid lhs-	checkRhs mid rhs-----checkLhs :: ModuleIdent -> Lhs -> CheckState ()-checkLhs mid (FunLhs ident cterms)-   = do visitId ident-	foldM' (checkConstrTerm mid) cterms-	foldM' (insertConstrTerm False) cterms-checkLhs mid (OpLhs cterm1 ident cterm2)-   = checkLhs mid (FunLhs ident [cterm1, cterm2])-checkLhs mid (ApLhs lhs cterms)-   = do checkLhs mid lhs-	foldM' (checkConstrTerm mid ) cterms-	foldM' (insertConstrTerm False) cterms-----checkRhs :: ModuleIdent -> Rhs -> CheckState ()-checkRhs mid (SimpleRhs _ expr decls)-   = do beginScope  -- function arguments can be overwritten by local decls-	foldM' checkLocalDecl decls-	foldM' insertDecl decls-	foldM' (checkDecl mid) decls-	checkDeclOccurrences decls-	checkExpression mid expr-	idents' <- returnUnrefVars-	when (not (null idents'))-	     (foldM' genWarning' (map unrefVar idents'))-	endScope-checkRhs mid (GuardedRhs cexprs decls)-   = do beginScope-	foldM' checkLocalDecl decls-	foldM' insertDecl decls-	foldM' (checkDecl mid) decls-	checkDeclOccurrences decls-	foldM' (checkCondExpr mid) cexprs-	idents' <- returnUnrefVars-	when (not (null idents'))-	     (foldM' genWarning' (map unrefVar idents'))-	endScope------checkCondExpr :: ModuleIdent -> CondExpr -> CheckState ()-checkCondExpr mid (CondExpr _ cond expr)-   = do checkExpression mid cond-	checkExpression mid expr---- -checkConstrTerm :: ModuleIdent -> ConstrTerm -> CheckState ()-checkConstrTerm mid (VariablePattern ident)-   = do s <- isShadowingVar ident-	when s (genWarning' (shadowingVar ident))-checkConstrTerm mid (ConstructorPattern _ cterms)-   = foldM' (checkConstrTerm mid ) cterms-checkConstrTerm mid (InfixPattern cterm1 qident cterm2)-   = checkConstrTerm mid (ConstructorPattern qident [cterm1, cterm2])-checkConstrTerm mid (ParenPattern cterm)-   = checkConstrTerm mid cterm-checkConstrTerm mid (TuplePattern _ cterms)-   = foldM' (checkConstrTerm mid ) cterms-checkConstrTerm mid (ListPattern _ cterms)-   = foldM' (checkConstrTerm mid ) cterms-checkConstrTerm mid (AsPattern ident cterm)-   = do s <- isShadowingVar ident-	when s (genWarning' (shadowingVar ident))-	checkConstrTerm mid cterm-checkConstrTerm mid (LazyPattern _ cterm)-   = checkConstrTerm mid cterm-checkConstrTerm mid (FunctionPattern _ cterms)-   = foldM' (checkConstrTerm mid ) cterms-checkConstrTerm mid  (InfixFuncPattern cterm1 qident cterm2)-   = checkConstrTerm mid  (FunctionPattern qident [cterm1, cterm2])-checkConstrTerm mid  (RecordPattern fields restr)-   = do foldM' (checkFieldPattern mid) fields-	maybe (return ()) (checkConstrTerm mid ) restr-checkConstrTerm _ _ = return ()-----checkExpression :: ModuleIdent -> Expression -> CheckState ()-checkExpression mid (Variable qident)-   = maybe (return ()) visitId (localIdent mid qident)-checkExpression mid (Paren expr)-   = checkExpression mid expr-checkExpression mid (Typed expr _)-   = checkExpression mid expr-checkExpression mid (Tuple _ exprs)-   = foldM' (checkExpression mid ) exprs-checkExpression mid (List _ exprs)-   = foldM' (checkExpression mid ) exprs-checkExpression mid (ListCompr _ expr stmts)-   = do beginScope-	foldM' (checkStatement mid ) stmts-	checkExpression mid expr-	idents' <- returnUnrefVars-	when (not (null idents'))-	     (foldM' genWarning' (map unrefVar idents'))-	endScope-checkExpression mid  (EnumFrom expr)-   = checkExpression mid  expr-checkExpression mid  (EnumFromThen expr1 expr2)-   = foldM' (checkExpression mid ) [expr1, expr2]-checkExpression mid  (EnumFromTo expr1 expr2)-   = foldM' (checkExpression mid ) [expr1, expr2]-checkExpression mid  (EnumFromThenTo expr1 expr2 expr3)-   = foldM' (checkExpression mid ) [expr1, expr2, expr3]-checkExpression mid  (UnaryMinus _ expr)-   = checkExpression mid  expr-checkExpression mid  (Apply expr1 expr2)-   = foldM' (checkExpression mid ) [expr1, expr2]-checkExpression mid  (InfixApply expr1 op expr2)-   = do maybe (return ()) (visitId) (localIdent mid (opName op))-	foldM' (checkExpression mid ) [expr1, expr2]-checkExpression mid  (LeftSection expr _)-   = checkExpression mid  expr-checkExpression mid  (RightSection _ expr)-   = checkExpression mid  expr-checkExpression mid  (Lambda _ cterms expr)-   = do beginScope-	foldM' (checkConstrTerm mid ) cterms-	foldM' (insertConstrTerm False) cterms-	checkExpression mid expr-	idents' <- returnUnrefVars-	when (not (null idents'))-	     (foldM' genWarning' (map unrefVar idents'))-	endScope-checkExpression mid  (Let decls expr)-   = do beginScope-	foldM' checkLocalDecl decls-	foldM' insertDecl decls-	foldM' (checkDecl mid) decls-	checkDeclOccurrences decls-	checkExpression mid  expr-	idents' <- returnUnrefVars-	when (not (null idents'))-	     (foldM' genWarning' (map unrefVar idents'))-	endScope-checkExpression mid  (Do stmts expr)-   = do beginScope-	foldM' (checkStatement mid ) stmts-	checkExpression mid  expr-	idents' <- returnUnrefVars-	when (not (null idents'))-	     (foldM' genWarning' (map unrefVar idents'))-	endScope-checkExpression mid  (IfThenElse _ expr1 expr2 expr3)-   = foldM' (checkExpression mid ) [expr1, expr2, expr3]-checkExpression mid  (Case _ expr alts)-   = do checkExpression mid  expr-	foldM' (checkAlt mid) alts-	checkCaseAlternatives mid alts-checkExpression mid (RecordConstr fields)-   = foldM' (checkFieldExpression mid) fields-checkExpression mid (RecordSelection expr ident)-   = checkExpression mid expr -- Hier auch "visitId ident" ?-checkExpression mid (RecordUpdate fields expr)-   = do foldM' (checkFieldExpression mid) fields-	checkExpression mid expr-checkExpression _ _  = return ()-----checkStatement :: ModuleIdent -> Statement -> CheckState ()-checkStatement mid (StmtExpr _ expr)-   = checkExpression mid expr-checkStatement mid (StmtDecl decls)-   = do foldM' checkLocalDecl decls-	foldM' insertDecl decls-	foldM' (checkDecl mid) decls-	checkDeclOccurrences decls-checkStatement mid (StmtBind _ cterm expr)-   = do checkConstrTerm mid cterm-	insertConstrTerm False cterm-	checkExpression mid expr-----checkAlt :: ModuleIdent -> Alt -> CheckState ()-checkAlt mid (Alt pos cterm rhs)-   = do beginScope -	checkConstrTerm mid  cterm-	insertConstrTerm False cterm-	checkRhs mid rhs-	idents' <-  returnUnrefVars-	when (not (null idents'))-	     (foldM' genWarning' (map unrefVar idents'))-	endScope-----checkFieldExpression :: ModuleIdent -> Field Expression -> CheckState ()-checkFieldExpression mid (Field _ ident expr)-   = checkExpression mid expr -- Hier auch "visitId ident" ?-----checkFieldPattern :: ModuleIdent -> Field ConstrTerm -> CheckState ()-checkFieldPattern mid (Field _ ident cterm)-   = checkConstrTerm mid  cterm---- Check for idle and overlapping case alternatives-checkCaseAlternatives :: ModuleIdent -> [Alt] -> CheckState ()-checkCaseAlternatives mid alts-   = do checkIdleAlts mid alts-	checkOverlappingAlts mid alts------- FIXME this looks buggy: is alts' required to be non-null or not? (hsi)-checkIdleAlts :: ModuleIdent -> [Alt] -> CheckState ()-checkIdleAlts mid alts-   = do alts' <- dropUnless' isVarAlt alts-	let idles = tail_ [] alts'-	    (Alt pos _ _) = head idles-	unless (null idles) (genWarning pos idleCaseAlts)- where- isVarAlt (Alt _ (VariablePattern id) _) -    = isVarId id- isVarAlt (Alt _ (ParenPattern (VariablePattern id)) _) -    = isVarId id- isVarAlt (Alt _ (AsPattern _ (VariablePattern id)) _)-    = isVarId id- isVarAlt _ = return False-----checkOverlappingAlts :: ModuleIdent -> [Alt] -> CheckState ()-checkOverlappingAlts mid [] = return ()-checkOverlappingAlts mid (alt:alts)-   = do (altsr, alts') <- partition' (equalAlts alt) alts-        mapM_ (\ (Alt pos _ _) -> genWarning pos overlappingCaseAlt) altsr-	checkOverlappingAlts mid alts'- where- equalAlts (Alt _ cterm1 _) (Alt _ cterm2 _) = equalConstrTerms cterm1 cterm2-- equalConstrTerms (LiteralPattern l1) (LiteralPattern l2)-    = return (l1 == l2)- equalConstrTerms (NegativePattern id1 l1) (NegativePattern id2 l2) -    = return (id1 == id2 && l1 == l2)- equalConstrTerms (VariablePattern id1) (VariablePattern id2)-    = do p <- isConsId id1 -	 return (p && id1 == id2)- equalConstrTerms (ConstructorPattern qid1 cs1)-		  (ConstructorPattern qid2 cs2)-    = if qid1 == qid2-      then all' (\ (c1,c2) -> equalConstrTerms c1 c2) (zip cs1 cs2)-      else return False- equalConstrTerms (InfixPattern lcs1 qid1 rcs1)-		  (InfixPattern lcs2 qid2 rcs2)-    = equalConstrTerms (ConstructorPattern qid1 [lcs1, rcs1])-                       (ConstructorPattern qid2 [lcs2, rcs2])- equalConstrTerms (ParenPattern cterm1) (ParenPattern cterm2)-    = equalConstrTerms cterm1 cterm2- equalConstrTerms (TuplePattern _ cs1) (TuplePattern _ cs2)-    = equalConstrTerms (ConstructorPattern (qTupleId 2) cs1)-                       (ConstructorPattern (qTupleId 2) cs2)- equalConstrTerms (ListPattern _ cs1) (ListPattern _ cs2)-    = cmpListM equalConstrTerms cs1 cs2- equalConstrTerms (AsPattern id1 cterm1) (AsPattern id2 cterm2)-    = equalConstrTerms cterm1 cterm2- equalConstrTerms (LazyPattern _ cterm1) (LazyPattern _ cterm2)-    = equalConstrTerms cterm1 cterm2- equalConstrTerms _ _ = return False----- Find function rules which are not together-checkDeclOccurrences :: [Decl] -> CheckState ()-checkDeclOccurrences decls = checkDO (mkIdent "") Map.empty decls- where- checkDO prevId env [] = return ()- checkDO prevId env ((FunctionDecl pos ident _):decls)-    = do c <- isConsId ident-	 if not (c || prevId == ident)-          then (maybe (checkDO ident (Map.insert ident pos env) decls)-	              (\pos' -> genWarning' (rulesNotTogether ident pos')-		                >> checkDO ident env decls)-	              (Map.lookup ident env))-	  else checkDO ident env decls- checkDO _ env (_:decls) -    = checkDO (mkIdent "") env decls----- check import declarations for multiply imported modules-checkImports :: [Decl] -> CheckState ()-checkImports imps = checkImps Map.empty imps- where- checkImps env [] = return ()- checkImps env ((ImportDecl pos mid _ _ spec):imps)-    | mid /= preludeMIdent-      = maybe (checkImps (Map.insert mid (fromImpSpec spec) env) imps)-              (\ishs -> checkImpSpec env pos mid ishs spec-	                >>= (\env' -> checkImps env' imps))-	      (Map.lookup mid env)-    | otherwise-      = checkImps env imps- checkImps env (_:imps) = checkImps env imps-- checkImpSpec env pos mid (is,hs) Nothing-    = genWarning' (multiplyImportedModule mid) >> return env- checkImpSpec env pos mid (is,hs) (Just (Importing _ is'))-    | null is && any (\i' -> notElem i' hs) is'-      = do genWarning' (multiplyImportedModule mid)-	   return (Map.insert mid (is',hs) env)-    | null iis-      = return (Map.insert mid (is' ++ is,hs) env)-    | otherwise-      = do foldM' genWarning'-		  (map ((multiplyImportedSymbol mid) . impName) iis)-	   return (Map.insert mid (unionBy cmpImport is' is,hs) env)-  where iis = intersectBy cmpImport is' is- checkImpSpec env pos mid (is,hs) (Just (Hiding _ hs'))-    | null ihs-      = return (Map.insert mid (is,hs' ++ hs) env)-    | otherwise-      = do foldM' genWarning' -		  (map ((multiplyHiddenSymbol mid) . impName) ihs)-	   return (Map.insert mid (is,unionBy cmpImport hs' hs) env)-  where ihs = intersectBy cmpImport hs' hs-- cmpImport (ImportTypeWith id1 cs1) (ImportTypeWith id2 cs2)-    = id1 == id2 && null (intersect cs1 cs2)- cmpImport i1 i2 = (impName i1) == (impName i2)-- impName (Import id)           = id- impName (ImportTypeAll id)    = id- impName (ImportTypeWith id _) = id-- fromImpSpec Nothing                 = ([],[])- fromImpSpec (Just (Importing _ is)) = (is,[])- fromImpSpec (Just (Hiding _ hs))    = ([],hs)------------------------------------------------------------------------------------- For detecting unreferenced variables, the following functions updates the --- current check state by adding identifiers occuring in declaration left hand --- sides.-----insertDecl :: Decl -> CheckState ()-insertDecl (DataDecl _ ident _ cdecls)-   = do insertTypeConsId ident-	foldM' insertConstrDecl cdecls-insertDecl (TypeDecl _ ident _ texpr)-   = do insertTypeConsId ident-	insertTypeExpr texpr-insertDecl (FunctionDecl _ ident _)-   = do c <- isConsId ident-	unless c (insertVar ident)-insertDecl (ExternalDecl _ _ _ ident _)-   = insertVar ident-insertDecl (FlatExternalDecl _ idents)-   = foldM' insertVar idents-insertDecl (PatternDecl _ cterm _)-   = insertConstrTerm False cterm-insertDecl (ExtraVariables _ idents)-   = foldM' insertVar idents-insertDecl _ = return ()-----insertTypeExpr :: TypeExpr -> CheckState ()-insertTypeExpr (VariableType _) = return ()-insertTypeExpr (ConstructorType _ texprs)-   = foldM' insertTypeExpr texprs-insertTypeExpr (TupleType texprs)-   = foldM' insertTypeExpr texprs-insertTypeExpr (ListType texpr)-   = insertTypeExpr texpr-insertTypeExpr (ArrowType texpr1 texpr2)-   = foldM' insertTypeExpr [texpr1,texpr2]-insertTypeExpr (RecordType fields restr)-   = do --foldM' insertVar (concatMap fst fields)-	maybe (return ()) insertTypeExpr restr-----insertConstrDecl :: ConstrDecl -> CheckState ()-insertConstrDecl (ConstrDecl _ _ ident _)-   = insertConsId ident-insertConstrDecl (ConOpDecl _ _ _ ident _)-   = insertConsId ident---- Notes: ---    - 'fp' indicates whether 'checkConstrTerm' 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. -insertConstrTerm :: Bool -> ConstrTerm -> CheckState ()-insertConstrTerm fp (VariablePattern ident)-   | fp        = do c <- isConsId ident-		    v <- isVarId ident-		    unless c (if (name ident) /= "_" && v-			         then visitId ident-			         else insertVar ident)-   | otherwise = do c <- isConsId ident-	            unless c (insertVar ident)-insertConstrTerm fp (ConstructorPattern qident cterms)-   = do c <- isQualConsId qident-	if c then foldM' (insertConstrTerm fp) cterms-	     else foldM' (insertConstrTerm True) cterms-insertConstrTerm fp (InfixPattern cterm1 qident cterm2)-   = insertConstrTerm fp (ConstructorPattern qident [cterm1, cterm2])-insertConstrTerm fp (ParenPattern cterm)-   = insertConstrTerm fp cterm-insertConstrTerm fp (TuplePattern _ cterms)-   = foldM' (insertConstrTerm fp) cterms-insertConstrTerm fp (ListPattern _ cterms)-   = foldM' (insertConstrTerm fp) cterms-insertConstrTerm fp (AsPattern ident cterm)-   = do insertVar ident-	insertConstrTerm fp cterm-insertConstrTerm fp (LazyPattern _ cterm)-   = insertConstrTerm fp cterm-insertConstrTerm _ (FunctionPattern _ cterms)-   = foldM' (insertConstrTerm True) cterms-insertConstrTerm _ (InfixFuncPattern cterm1 qident cterm2)-   = insertConstrTerm True (FunctionPattern qident [cterm1, cterm2])-insertConstrTerm fp (RecordPattern fields restr)-   = do foldM' (insertFieldPattern fp) fields-	maybe (return ()) (insertConstrTerm fp) restr-insertConstrTerm _ _ = return ()-----insertFieldPattern :: Bool -> Field ConstrTerm -> CheckState ()-insertFieldPattern fp (Field _ _ cterm)-   = insertConstrTerm fp cterm--------------------------------------------------------------------------------------------------------------------------------------------------------------------- Data type for distinguishing identifiers as either (type) constructors or--- (type) variables (including functions).--- The Boolean flag in 'VarInfo' is used to mark variables when they are used --- within expressions.-data IdInfo = ConsInfo | VarInfo Bool deriving Show-----isVariable :: IdInfo -> Bool-isVariable (VarInfo _) = True-isVariable _           = False-----isConstructor :: IdInfo -> Bool-isConstructor ConsInfo = True-isConstructor _        = False-----variableVisited :: IdInfo -> Bool-variableVisited (VarInfo v) = v-variableVisited _           = True-----visitVariable :: IdInfo -> IdInfo-visitVariable info = case info of-		       VarInfo _ -> VarInfo True-		       _         -> info------modifyScope :: (ScopeEnv QualIdent IdInfo -> ScopeEnv QualIdent IdInfo)-	       -> CState -> CState-modifyScope f state = state{ scope = f (scope state) }------genWarning :: Position -> String -> CheckState ()-genWarning pos msg-   = modify (\state -> state{ messages = warnMsg:(messages state) })- where warnMsg = WarnMsg (Just pos) msg- -genWarning' :: (Position, String) -> CheckState ()-genWarning' (pos, msg)-   = modify (\state -> state{ messages = warnMsg:(messages state) })-    where warnMsg = WarnMsg (Just pos) msg -----insertVar :: Ident -> CheckState ()-insertVar id -   | isAnnonId id = return ()-   | otherwise-     = modify -         (\state -> modifyScope -	              (ScopeEnv.insert (commonId id) (VarInfo False)) state)-----insertTypeVar :: Ident -> CheckState ()-insertTypeVar id-   | isAnnonId id = return ()-   | otherwise    -     = modify -         (\state -> modifyScope -	              (ScopeEnv.insert (typeId id) (VarInfo False)) state)-----insertConsId :: Ident -> CheckState ()-insertConsId id-   = modify -       (\state -> modifyScope (ScopeEnv.insert (commonId id) ConsInfo) state)-----insertTypeConsId :: Ident -> CheckState ()-insertTypeConsId id-   = modify -       (\state -> modifyScope (ScopeEnv.insert (typeId id) ConsInfo) state)-----isVarId :: Ident -> CheckState Bool-isVarId id-   = gets (\state -> isVar state (commonId id))-----isConsId :: Ident -> CheckState Bool-isConsId id -   = gets (\state -> isCons state (qualify id))-----isQualConsId :: QualIdent -> CheckState Bool-isQualConsId qid-   = gets (\state -> isCons state qid)-----isShadowingVar :: Ident -> CheckState Bool-isShadowingVar id -   = gets (\state -> isShadowing state (commonId id))-----visitId :: Ident -> CheckState ()-visitId id -   = modify -       (\state -> modifyScope -	            (ScopeEnv.modify visitVariable (commonId id)) state)-----visitTypeId :: Ident -> CheckState ()-visitTypeId id -   = modify -       (\state -> modifyScope -	            (ScopeEnv.modify visitVariable (typeId id)) state)-----isUnrefTypeVar :: Ident -> CheckState Bool-isUnrefTypeVar id-   = gets (\state -> isUnref state (typeId id))-----returnUnrefVars :: CheckState [Ident]-returnUnrefVars -   = gets (\state -> -	   	    let ids    = map fst (ScopeEnv.toLevelList (scope state))-                        unrefs = filter (isUnref state) ids-	            in  map unqualify unrefs )-----addModuleId :: ModuleIdent -> CheckState ()-addModuleId mid = modify (\state -> state{ moduleId = mid })------withScope :: CheckState a -> CheckState ()-withScope m = beginScope >> m >> endScope-----beginScope :: CheckState ()-beginScope = modify (\state -> modifyScope ScopeEnv.beginScope state)-----endScope :: CheckState ()-endScope = modify (\state -> modifyScope ScopeEnv.endScopeUp state)----- Adds the content of a value environment to the state-addImportedValues :: ValueEnv -> CheckState ()-addImportedValues vals = modify (\state -> state{ values = vals })-----foldM' :: (a -> CheckState ()) -> [a] -> CheckState ()-foldM' f [] = return ()-foldM' f (x:xs) = f x >> foldM' f xs-----dropUnless' :: (a -> CheckState Bool) -> [a] -> CheckState [a]-dropUnless' mpred [] = return []-dropUnless' mpred (x:xs)-   = do p <- mpred x-	if p then return (x:xs) else dropUnless' mpred xs-----partition' :: (a -> CheckState Bool) -> [a] -> CheckState ([a],[a])-partition' mpred xs = part mpred [] [] xs- where- part mpred ts fs [] = return (reverse ts, reverse fs)- part mpred ts fs (x:xs)-   = do p <- mpred x-	if p then part mpred (x:ts) fs xs-	     else part mpred ts (x:fs) xs-----all' :: (a -> CheckState Bool) -> [a] -> CheckState Bool-all' mpred [] = return True-all' mpred (x:xs)-   = do p <- mpred x-	if p then all' mpred xs else return False----------------------------------------------------------------------------------------isShadowing :: CState -> QualIdent -> Bool-isShadowing state qid-   = let sc = scope state-     in  maybe False isVariable (ScopeEnv.lookup qid sc)-	 && ScopeEnv.level qid sc < ScopeEnv.currentLevel sc-----isUnref :: CState -> QualIdent -> Bool-isUnref state qid -   = let sc = scope state-     in  maybe False (not . variableVisited) (ScopeEnv.lookup qid sc)-         && ScopeEnv.level qid sc == ScopeEnv.currentLevel sc-----isVar :: CState -> QualIdent -> Bool-isVar state qid = maybe (isAnnonId (unqualify qid)) -	           isVariable -		   (ScopeEnv.lookup qid (scope state))-----isCons :: CState -> QualIdent -> Bool-isCons state qid = maybe (isImportedCons state qid)-		         isConstructor-			 (ScopeEnv.lookup qid (scope state))- where- isImportedCons state qid-    = case (qualLookupValue qid (values state)) of-        (DataConstructor _ _):_    -> True-        (NewtypeConstructor _ _):_ -> True-        _                          -> False------isAnnonId :: Ident -> Bool-isAnnonId id = (name id) == "_"----- 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 id = qualify (unRenameIdent id)-----typeId :: Ident -> QualIdent-typeId id = qualify (renameIdent id 1)------------------------------------------------------------------------------------- Warnings...--unrefTypeVar :: Ident -> (Position, String)-unrefTypeVar id = -  (positionOfIdent id,-   "unreferenced type variable \"" ++ show id ++ "\"")--unrefVar :: Ident -> (Position, String)-unrefVar id = -  (positionOfIdent id,-   "unused declaration of variable \"" ++ show id ++ "\"")--shadowingVar :: Ident -> (Position, String)-shadowingVar id = -  (positionOfIdent id,-   "shadowing symbol \"" ++ show id ++ "\"")--idleCaseAlts :: String-idleCaseAlts = "idle case alternative(s)"--overlappingCaseAlt :: String-overlappingCaseAlt = "redundant overlapping case alternative"--rulesNotTogether :: Ident -> Position -> (Position, String)-rulesNotTogether id pos-  = (positionOfIdent id,-     "rules for function \"" ++ show id ++ "\" "    -     ++ "are not together "-     ++ "(first occurrence at " -     ++ show (line pos) ++ "." ++ show (column pos) ++ ")")--multiplyImportedModule :: ModuleIdent -> (Position, String)-multiplyImportedModule mid -  = (positionOfModuleIdent mid,-     "module \"" ++ show mid ++ "\" was imported more than once")--multiplyImportedSymbol :: ModuleIdent -> Ident -> (Position, String)-multiplyImportedSymbol mid ident-  = (positionOfIdent ident,-     "symbol \"" ++ show ident ++ "\" was imported from module \""-     ++ show mid ++ "\" more than once")--multiplyHiddenSymbol :: ModuleIdent -> Ident -> (Position, String)-multiplyHiddenSymbol mid ident-  = (positionOfIdent ident,-     "symbol \"" ++ show ident ++ "\" from module \"" ++ show mid-     ++ "\" was hidden more than once")------------------------------------------------------------------------------------- Miscellaneous---- safer versions of 'tail' and 'head'-tail_ :: [a] -> [a] -> [a]-tail_ alt []     = alt-tail_ _   (_:xs) = xs------cmpListM :: Monad m => (a -> a -> m Bool) -> [a] -> [a] -> m Bool-cmpListM cmpM []     []     = return True-cmpListM cmpM (x:xs) (y:ys) = do c <- cmpM x y-				 if c then cmpListM cmpM xs ys -				      else return False-cmpListM cmpM _      _      = return False------------------------------------------------------------------------------------------------------------------------------------------------------------------
− src/currydoc.css 
@@ -1,34 +0,0 @@-/* Use monospace fonts for typewriter styles */-pre, tt, code { font-family: monospace }--/* Use always white background */-body { background: white; color: black }--/* Show hyperlinks without underscore */-a:visited, a:link, a:active { text-decoration: none }--.keyword { color:blue }-.constructorname_constrpattern { color : #FF00FF }-.constructorname_constrcall { color : #FF00FF }-.constructorname_constrdecla { color : #FF00FF }-.constructorname_otherconstrkind { color : #FF00FF }-.typeconstructor_typedecla  { color : #ff7f50 }-.typeconstructor_typeuse  { color : #ff7f50 }-.typeconstructor_typeexport  { color : #ff7f50 }-.function_infixfunction  { color : #800080 }-.function_typsig  { color : #800080 }-.function_fundecl  { color : #800080 }-.function_functioncall  { color : #800080 }-.function_otherfunctionkind  { color : #800080 }-.moduleName  { color : #800000 }-.commentary  { color : green }-.numberCode  { color : #008080 }-.stringCode  { color : #800000 }-.charCode  { color : #800000 }-.symbol  { color : #C0C0C0 }-.identifier_iddecl   { color : black }-.identifier_idoccur   { color : black }-.identifier_unknownid   { color : black }-.codeWarning  {font-weight: bold;font-style:italic; color : red }-.codeError  { font-style:italic; color : #a52a2a }-.notParsed  { font-style:italic; color : #C0C0C0 }
− src/cymake.hs 
@@ -1,97 +0,0 @@--- -------------------------------------------------------------------------------- |--- cymake - The Curry builder------          Command line tool for generating Curry representations (e.g.---          FlatCurry, AbstractCurry) for a Curry source file including---          all imported modules.------ September 2005, Martin Engelke (men@informatik.uni-kiel.de)------ -------------------------------------------------------------------------------module Main(main) where--import Data.List-import Data.Maybe-import System.Console.GetOpt-import System.Environment(getArgs, getProgName)-import System.Exit(ExitCode(..), exitWith)-import System.IO-import Control.Monad (unless)--import CurryBuilder(buildCurry)-import CurryCompilerOpts-import CurryHtml-import Curry.Files.CymakePath (cymakeVersion)----- | The command line tool cymake-main :: IO ()-main = do-  prog <- getProgName-  args <- getArgs-  cymake prog args---- | Checks the command line arguments and invokes the curry builder-cymake :: String -> [String] -> IO ()-cymake prog args-  | elem Help opts = printUsage prog-  | null files     = badUsage prog ["no files"]-  | null errs'-    && not (elem Html opts) = do-      unless (noVerb options')-        (putStrLn $ "This is cymake, version " ++ cymakeVersion)-      mapM_ (buildCurry options') files-  | null errs'     = do-                     let importFiles = nub $ importPaths opts'-                         outputFile  = maybe "" id (output opts')-                     mapM_ (source2html importFiles outputFile) files-  | otherwise      = badUsage prog errs'-  where-  (opts, files, errs) = getOpt Permute options args-  opts'               = foldr selectOption defaultOpts opts-  options'            = if flat opts' || flatXml opts' || abstract opts'-                        || untypedAbstract opts' || parseOnly opts'-                          then  opts'-                          else  opts'{ flat = True }-  errs'               = errs ++ check options' files---- | Prints usage information of the command line tool.-printUsage :: String -> IO ()-printUsage prog = do-  putStrLn (usageInfo header options)-  exitWith ExitSuccess-  where header = "usage: " ++ prog ++ " [OPTION] ... MODULE ..."---- | Prints errors-badUsage :: String -> [String] -> IO ()-badUsage prog errs = do-  putErrsLn $ map (\err -> prog ++ ": " ++ err) errs-  abortWith ["Try '" ++ prog ++ " -" ++ "-help' for more information"]---- | Checks options and files and return a list of error messages-check :: Options -> [String] -> [String]-check opts files-   | null files-     = ["no files"]-   | isJust (output opts) && length files > 1-     = ["cannot specify -o with multiple targets"]-   | otherwise-     = []---- | Prints an error message on 'stderr'-putErrLn :: String -> IO ()-putErrLn = hPutStrLn stderr---- | Prints a list of error messages on 'stderr'-putErrsLn :: [String] -> IO ()-putErrsLn = mapM_ putErrLn---- | Prints a list of error messages on 'stderr' and aborts the program with---   exit code 1-abortWith :: [String] -> IO a-abortWith errs = putErrsLn errs >> exitWith (ExitFailure 1)---- -------------------------------------------------------------------------------- -----------------------------------------------------------------------------
+ test/TestFrontend.hs view
@@ -0,0 +1,359 @@+--------------------------------------------------------------------------------+-- Test Suite for the Curry Frontend+--------------------------------------------------------------------------------+--+-- This Test Suite supports three kinds of tests:+--+-- 1) tests which should pass+-- 2) tests which should pass with a specific warning+-- 3) tests which should fail yielding a specific error message+--+-- In order to add a test to this suite, proceed as follows:+--+-- 1) Store your test code in a file (please use descriptive names) and put it+--    in the corresponding subfolder (i.e. test/pass for passing tests,+--    test/fail for failing tests and test/warning for passing tests producing+--    warnings)+-- 2) Extend the corresponding test information list (there is one for each test+--    group at the end of this file) with the required information (i.e. name of+--    the Curry module to be tested and expected warning/failure message(s))+-- 3) Run 'cabal test'++{-# LANGUAGE CPP #-}+module TestFrontend (tests) where++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative    ((<$>))+#endif+import qualified Control.Exception as E (SomeException, catch)++import           Data.List              (isInfixOf, sort)+import qualified Data.Map as Map        (insert)+import           Distribution.TestSuite ( Test (..), TestInstance (..)+                                        , Progress (..), Result (..)+                                        , OptionDescr)+import           System.FilePath        (FilePath, (</>), (<.>))++import           Curry.Base.Message     (Message, message, ppMessages, ppError)+import           Curry.Base.Monad       (CYIO, runCYIO)+import           Curry.Base.Pretty      (text)+import qualified CompilerOpts as CO     ( Options (..), WarnOpts (..)+                                        , WarnFlag (..), Verbosity (VerbQuiet)+                                        , CppOpts (..)+                                        , defaultOptions)+import CurryBuilder                     (buildCurry)++tests :: IO [Test]+tests = return [failingTests, passingTests, warningTests]++runSecure :: CYIO a -> IO (Either [Message] (a, [Message]))+runSecure act = runCYIO act `E.catch` handler+  where handler e = return (Left [message $ text $ show (e :: E.SomeException)])++-- Execute a test by calling cymake+runTest :: CO.Options -> String -> [String] -> IO Progress+runTest opts test errorMsgs =+  if null errorMsgs+    then passOrFail <$> runSecure (buildCurry opts' test)+    else catchE     <$> runSecure (buildCurry opts' test)+  where+    cppOpts       = CO.optCppOpts opts+    cppDefs       = Map.insert "__PAKCS__" 3 (CO.cppDefinitions cppOpts)+    wOpts         = CO.optWarnOpts opts+    wFlags        =   CO.WarnUnusedBindings+                    : CO.WarnUnusedGlobalBindings+                    : CO.wnWarnFlags wOpts+    opts'         = opts { CO.optForce    = True+                         , CO.optWarnOpts = wOpts+                            { CO.wnWarnFlags    = wFlags  }+                         , CO.optCppOpts  = cppOpts+                            { CO.cppDefinitions = cppDefs }+                         }+    passOrFail    = Finished . either fail (const Pass)+    catchE        = Finished . either pass (pass . snd)+    fail msgs+      | null msgs = Pass+      | otherwise = Fail $ "An unexpected failure occurred: " +++                           showMessages msgs+    pass msgs+      | null otherMsgs = Pass+      | otherwise      = Fail $ "Expected warnings/failures did not occur: " +++                                unwords otherMsgs+      where+        errorStr  = showMessages msgs+        otherMsgs = filter (not . flip isInfixOf errorStr) errorMsgs++showMessages :: [Message] -> String+showMessages = show . ppMessages ppError . sort++-- group of test which should fail yielding a specific error message+failingTests :: Test+failingTests = Group { groupName    = "Failing Tests"+, concurrently = False+, groupTests   = map (mkTest "test/fail/") failInfos+}++-- group of tests which should pass+passingTests :: Test+passingTests = Group { groupName    = "Passing Tests"+                     , concurrently = False+                     , groupTests   = map (mkTest "test/pass/") passInfos+                     }++-- group of tests which should pass producing a specific warning message+warningTests :: Test+warningTests = Group { groupName    = "Warning Tests"+                     , concurrently = False+                     , groupTests   = map (mkTest "test/warning/") warnInfos+                     }++-- create a new test+mkTest :: FilePath -> TestInfo -> Test+mkTest path (testName, testTags, testOpts, mSetOpts, errorMsgs) =+  let file = path </> testName <.> "curry"+      opts = CO.defaultOptions { CO.optVerbosity   = CO.VerbQuiet+                               , CO.optImportPaths = [path]+                               }+      test = TestInstance+        { run       = runTest opts file errorMsgs+        , name      = testName+        , tags      = testTags+        , options   = testOpts+        , setOption = maybe (\_ _ -> Right test) id mSetOpts+        }+  in Test test++-- Information for a test instance:+-- * name of test+-- * tags to classify a test+-- * options+-- * function to set options+-- * optional warning/error message which should be thrown on execution of test+type TestInfo = (String, [String], [OptionDescr], Maybe SetOption, [String])++type SetOption = String -> String -> Either String TestInstance++--------------------------------------------------------------------------------+-- Definition of failing tests+--------------------------------------------------------------------------------++-- generate a simple failing test+mkFailTest :: String -> [String] -> TestInfo+mkFailTest name errorMsgs = (name, [], [], Nothing, errorMsgs)++-- To add a failing test to the test suite simply add the module name of the+-- test code and the expected error message(s) to the following list+failInfos :: [TestInfo]+failInfos = map (uncurry mkFailTest)+  [ ("DataFail",+      [ "Missing instance for Prelude.Data Test1"+      , "Missing instance for Prelude.Data (Test2"+      , "Missing instance for Prelude.Data (Test2"+      , "Missing instance for Prelude.Data Test1"+      ]+    )+  , ("ErrorMultipleSignature", ["More than one type signature for `f'"])+  , ("ErrorMultipleSignature", ["More than one type signature for `f'"])+  , ("ExportCheck/AmbiguousName", ["Ambiguous name `not'"])+  , ("ExportCheck/AmbiguousType", ["Ambiguous type `Bool'"])+  , ("ExportCheck/ModuleNotImported", ["Module `Foo' not imported"])+  , ("ExportCheck/MultipleName", ["Multiple exports of name `not'"])+  , ("ExportCheck/MultipleType", ["Multiple exports of type `Bool'"])+  , ("ExportCheck/NoDataType", ["`Foo' is not a data type"])+  , ("ExportCheck/OutsideTypeConstructor", ["Data constructor `False' outside type export in export list"])+  , ("ExportCheck/OutsideTypeLabel", ["Label `value' outside type export in export list"])+  , ("ExportCheck/UndefinedElement", ["`foo' is not a constructor or label of type `Bool'"])+  , ("ExportCheck/UndefinedName", ["Undefined name `foo' in export list"])+  , ("ExportCheck/UndefinedType", ["Undefined type or class `Foo' in export list"])+  , ("FP_Cyclic", ["Function `g' used in functional pattern depends on `f'  causing a cyclic dependency"])+  , ("FP_Restrictions",+      [ "Functional patterns are not supported inside a case expression"+      , "Functional patterns are not supported inside a case expression"+      , "Functional patterns are not supported inside a list comprehension"+      , "Functional patterns are not supported inside a do sequence"+      ]+    )+  , ("HaskellRecordsFail", ["Unexpected token `,'"])+  , ("FP_NonGlobal", ["Function `f1' in functional pattern is not global"])+  , ("ImportError",+      [ "Module Prelude does not export foo"+      , "Module Prelude does not export bar"+      ]+    )+  , ("KindCheck",+      [ "Type variable a occurs more than once in left hand side of type declaration"+      , "Type variable b occurs more than once in left hand side of type declaration"+      ]+    )+  , ("MissingLabelInUpdate",+      ["Undefined record label `l1'"] )+  , ("MultipleArities", ["Equations for `test' have different arities"])+  , ("MultipleDefinitions",+      ["Multiple definitions for data/record constructor `Rec'"]+    )+  , ("MultiplePrecedence",+      ["More than one fixity declaration for `f'"]+    )+  , ("PatternRestrictions",+      [ "Lazy patterns are not supported inside a functional pattern"]+    )+  , ("PragmaError", ["Unknown language extension"])+  , ("PrecedenceRange", ["Precedence out of range"])+  , ("RecordLabelIDs", ["Multiple declarations of `RecordLabelIDs.id'"])+  , ("RecursiveTypeSyn", ["Mutually recursive synonym and/or renaming types A and B (line 12.6)"])+  , ("SyntaxError", ["Type error in application"])+  , ("TypedFreeVariables",+      ["Variable x has a polymorphic type", "Type error in equation"]+    )+  , ("TypeError1", ["Type error in explicitly typed expression"])+  , ("TypeError2", ["Missing instance for Prelude.Num Prelude.Bool"])+  , ("TypeSigTooGeneral",+      [ "Type signature too general"+      , "Function: h"+      , "Type signature too general"+      , "Function: g'"+      , "Type signature too general"+      , "Function: n"+      ]+    )+  , ("UnboundTypeVariable",+      [ "Unbound type variable b"+      , "Unbound type variable c"+      ]+    )+  ]++--------------------------------------------------------------------------------+-- Definition of passing tests+--------------------------------------------------------------------------------++-- generate a simple passing test+mkPassTest :: String -> TestInfo+mkPassTest = flip mkFailTest []++-- To add a passing test to the test suite simply add the module name of the+-- test code to the following list+passInfos :: [TestInfo]+passInfos = map mkPassTest+  [ "AbstractCurryBug"+  , "ACVisibility"+  , "AnonymVar"+  , "CaseComplete"+  , "DataPass"+  , "DefaultPrecedence"+  , "Dequeue"+  , "EmptyWhere"+  , "ExplicitLayout"+  , "FCase"+  , "FP_Lifting"+  , "FP_NonCyclic"+  , "FP_NonLinearity"+  , "FunctionalPatterns"+  , "HaskellRecords"+  , "HaskellRecordsPass"+  , "Hierarchical"+  , "ImportRestricted"+  , "ImportRestricted2"+  , "Infix"+  , "Inline"+  , "Lambda"+  , "Maybe"+  , "NegLit"+  , "Newtype1"+  , "Newtype2"+  , "NonLinearLHS"+  , "OperatorDefinition"+  , "PatDecl"+  , "Prelude"+  , "Pretty"+  , "RecordsPolymorphism"+  , "RecordTest1"+  , "RecordTest2"+  , "RecordTest3"+  , "ReexportTest"+  , "SelfExport"+  , "SpaceLeak"+  , "TyConsTest"+  , "TypedExpr"+  , "UntypedAcy"+  , "Unzip"+  , "WhereAfterDo"+  ]++--------------------------------------------------------------------------------+-- Definition of warning tests+--------------------------------------------------------------------------------++-- To add a warning test to the test suite simply add the module name of the+-- test code and the expected warning message(s) to the following list+warnInfos :: [TestInfo]+warnInfos = map (uncurry mkFailTest)+  [+    ("AliasClash",+      [ "The module alias `AliasClash' overlaps with the current module name"+      , "Overlapping module aliases"+      , "Module List is imported more than once"+      ]+    )+  , ("Case1", ["Pattern matches are non-exhaustive", "In an equation for `h'"])+  , ("Case2",+      [ "An fcase expression is potentially non-deterministic due to overlapping rules"+      , "Pattern matches are non-exhaustive", "In an fcase alternative"+      , "In a case alternative", "In an equation for `fp'"+      , "Pattern matches are potentially unreachable"+      , "Function `fp' is potentially non-deterministic due to overlapping rules"+      , "Pattern matches are non-exhaustive"+      ]+    )+  , ("CaseModeH",+      [ "Wrong case mode in symbol `B' due to selected case mode `haskell`, try renaming to b instead"+      , "Wrong case mode in symbol `B' due to selected case mode `haskell`, try renaming to b instead"+      , "Wrong case mode in symbol `Xs' due to selected case mode `haskell`, try renaming to xs instead"+      , "Wrong case mode in symbol `c' due to selected case mode `haskell`, try renaming to C instead"+      , "Wrong case mode in symbol `f' due to selected case mode `haskell`, try renaming to F instead"+      ]+    )+  , ("CaseModeP",+      [ "Wrong case mode in symbol `a' due to selected case mode `prolog`, try renaming to A instead"+      , "Wrong case mode in symbol `a' due to selected case mode `prolog`, try renaming to A instead"+      , "Wrong case mode in symbol `mf' due to selected case mode `prolog`, try renaming to Mf instead"+      , "Wrong case mode in symbol `E' due to selected case mode `prolog`, try renaming to e instead"+      ]+    )+  , ("CheckSignature",+      [ "Top-level binding with no type signature: hw"+      , "Top-level binding with no type signature: f"+      , "Unused declaration of variable `answer'"+      ]+    )+  , ("NonExhaustivePattern",+      [ "Pattern matches are non-exhaustive", "In a case alternative"+      , "In an equation for `test2'", "In an equation for `and'"+      , "In an equation for `plus'", "In an equation for `len2'"+      , "In an equation for `tuple'", "In an equation for `tuple2'"+      , "In an equation for `g'", "In an equation for `rec'"]+    )+  , ("NoRedundant", [])+  , ("OverlappingPatterns",+      [ "Pattern matches are potentially unreachable", "In a case alternative"+      , "An fcase expression is potentially non-deterministic due to overlapping rules"+      , "Function `i' is potentially non-deterministic due to overlapping rules"+      , "Function `j' is potentially non-deterministic due to overlapping rules"+      , "Function `k' is potentially non-deterministic due to overlapping rules"+      ]+    )+  , ("QualRedundant",+      [ "Redundant context in type signature for function `f': 'P.Eq a'"]+    )+  , ("Redundant",+      [ "Redundant context in type signature for function `f': 'Eq a'"]+    )+  , ("ShadowingSymbols",+      [ "Unused declaration of variable `x'", "Shadowing symbol `x'"])+  , ("TabCharacter",+      [ "Tab character"])+  , ("UnexportedFunction",+      [ "Unused declaration of variable `q'"+      , "Unused declaration of variable `g'" ]+    )+  ]