curry-frontend 0.2.12 → 1.0.1

raw patch · 131 files changed

+23279/−19823 lines, 131 filesdep +Cabaldep +curry-frontenddep +directorydep −old-timedep −sybdep ~basedep ~curry-basenew-component:exe:curry-frontendnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: Cabal, curry-frontend, directory, extra, network, network-uri, process, set-extra, transformers

Dependencies removed: old-time, syb

Dependency ranges changed: base, curry-base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +296/−0
• LICENSE +1/−0
• curry-frontend.cabal +147/−53
• data/currysource.css +41/−0
• src/Arity.hs +0/−133
• src/Base.lhs +0/−557
• src/Base/AnnotExpr.hs +123/−0
• src/Base/CurryKinds.hs +45/−0
• src/Base/CurryTypes.hs +215/−0
• src/Base/Expr.hs +211/−0
• src/Base/KindSubst.hs +48/−0
• src/Base/Kinds.hs +55/−0
• src/Base/Messages.hs +78/−0
• src/Base/NestEnv.hs +120/−0
• src/Base/PrettyKinds.hs +22/−0
• src/Base/PrettyTypes.hs +54/−0
• src/Base/SCC.hs +62/−0
• src/Base/Subst.hs +127/−0
• src/Base/TopEnv.hs +181/−0
• src/Base/TypeExpansion.hs +113/−0
• src/Base/TypeSubst.hs +143/−0
• src/Base/Types.hs +511/−0
• src/Base/Typing.hs +192/−0
• src/Base/Utils.hs +94/−0
• src/CaseCompletion.hs +0/−662
• src/Checks.hs +162/−0
• src/Checks/DeriveCheck.hs +108/−0
• src/Checks/ExportCheck.hs +482/−0
• src/Checks/ExtensionCheck.hs +72/−0
• src/Checks/ImportSyntaxCheck.hs +278/−0
• src/Checks/InstanceCheck.hs +356/−0
• src/Checks/InterfaceCheck.hs +315/−0
• src/Checks/InterfaceSyntaxCheck.hs +356/−0
• src/Checks/KindCheck.hs +765/−0
• src/Checks/PrecCheck.hs +497/−0
• src/Checks/SyntaxCheck.hs +1391/−0
• src/Checks/TypeCheck.hs +1811/−0
• src/Checks/TypeSyntaxCheck.hs +686/−0
• src/Checks/WarnCheck.hs +1483/−0
• src/CompilerEnv.hs +117/−0
• src/CompilerOpts.hs +588/−0
• src/CondCompile.hs +26/−0
• src/Curry/Files/CymakePath.hs +0/−15
• src/Curry/Syntax.hs +0/−43
• src/Curry/Syntax/Frontend.hs +0/−202
• src/Curry/Syntax/LLParseComb.lhs +0/−288
• src/Curry/Syntax/LexComb.lhs +0/−104
• src/Curry/Syntax/Lexer.lhs +0/−630
• src/Curry/Syntax/Parser.lhs +0/−806
• src/Curry/Syntax/Pretty.lhs +0/−368
• src/Curry/Syntax/ShowModule.hs +0/−499
• src/Curry/Syntax/Type.lhs +0/−315
• src/Curry/Syntax/Unlit.hs +0/−61
• src/Curry/Syntax/Utils.hs +0/−257
• src/CurryBuilder.hs +205/−172
• src/CurryCompilerOpts.hs +0/−166
• src/CurryDeps.hs +187/−0
• src/CurryDeps.lhs +0/−144
• src/CurryEnv.hs +0/−181
• src/CurryHtml.hs +0/−190
• src/Desugar.lhs +0/−843
• src/Env/Class.hs +76/−0
• src/Env/Instance.hs +50/−0
• src/Env/Interface.hs +31/−0
• src/Env/ModuleAlias.hs +41/−0
• src/Env/OpPrec.hs +111/−0
• src/Env/Type.hs +70/−0
• src/Env/TypeConstructor.hs +217/−0
• src/Env/Value.hs +203/−0
• src/Eval.lhs +0/−96
• src/Exports.hs +425/−0
• src/Exports.lhs +0/−463
• src/Files/CymakePath.hs +32/−0
• src/GenAbstractCurry.hs +0/−1041
• src/GenFlatCurry.hs +0/−1153
• src/Generators.hs +51/−0
• src/Generators/GenAbstractCurry.hs +532/−0
• src/Generators/GenFlatCurry.hs +56/−0
• src/Generators/GenTypedFlatCurry.hs +515/−0
• src/Html/CurryHtml.hs +185/−0
• src/Html/SyntaxColoring.hs +582/−0
• src/IL.hs +19/−0
• src/IL/CurryToIL.lhs +0/−598
• src/IL/Pretty.hs +179/−0
• src/IL/Pretty.lhs +0/−167
• src/IL/Scope.hs +0/−124
• src/IL/ShowModule.hs +248/−0
• src/IL/Type.hs +140/−0
• src/IL/Type.lhs +0/−112
• src/IL/Typing.hs +44/−0
• src/IL/XML.lhs +0/−518
• src/Imports.hs +397/−0
• src/Imports.lhs +0/−379
• src/InterfaceCheck.hs +0/−142
• src/Interfaces.hs +144/−0
• src/KindCheck.lhs +0/−320
• src/Lift.lhs +0/−307
• src/Modules.hs +409/−0
• src/Modules.lhs +0/−700
• src/NestEnv.lhs +0/−77
• src/OldScopeEnv.hs +0/−165
• src/PatchPrelude.hs +0/−40
• src/PrecCheck.lhs +0/−461
• src/Qual.lhs +0/−165
• src/SCC.lhs +0/−60
• src/ScopeEnv.hs +0/−175
• src/Simplify.lhs +0/−475
• src/Subst.lhs +0/−124
• src/SyntaxCheck.lhs +0/−1149
• src/SyntaxColoring.hs +0/−800
• src/TokenStream.hs +142/−0
• src/TopEnv.lhs +0/−148
• src/Transformations.hs +86/−0
• src/Transformations/CaseCompletion.hs +453/−0
• src/Transformations/CurryToIL.hs +548/−0
• src/Transformations/Derive.hs +637/−0
• src/Transformations/Desugar.hs +1070/−0
• src/Transformations/Dictionary.hs +1324/−0
• src/Transformations/Lift.hs +443/−0
• src/Transformations/Newtypes.hs +111/−0
• src/Transformations/Qual.hs +238/−0
• src/Transformations/Simplify.hs +344/−0
• src/TypeCheck.lhs +0/−1331
• src/TypeSubst.lhs +0/−104
• src/Types.lhs +0/−251
• src/Typing.lhs +0/−406
• src/Utils.lhs +0/−92
• src/WarnCheck.hs +0/−872
• src/currydoc.css +0/−34
• src/cymake.hs +45/−85
• test/TestFrontend.hs +317/−0

@@ -0,0 +1,296 @@+Change log for curry-frontend+=============================++Under development (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).+

@@ -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

@@ -1,71 +1,165 @@ Name:          curry-frontend-Version:       0.2.12-Cabal-Version: >= 1.6+Version:       1.0.1+Cabal-Version: >= 1.10 Synopsis:      Compile the functional logic language Curry to several                intermediate formats-Description:   The Curry Frontend consists of the executable program "cymake".+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/>)+               (<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:       OtherLicense+License:       BSD3 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+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: LIESMICH 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 +Flag network-uri+   description: Get Network.URI from the network-uri package+   default: True+ Library-  hs-source-dirs:  src-  Build-Depends:   filepath+  hs-source-dirs:   src+  default-language:  Haskell2010+  Build-Depends:+      base == 4.*+    , containers+    , curry-base == 1.0.0+    , directory+    , extra >= 1.4.6+    , filepath+    , mtl+    , pretty+    , process+    , set-extra+    , transformers+  if flag(network-uri)+    build-depends: network-uri >= 2.6+  else+    build-depends: network < 2.6   Exposed-Modules:-    Curry.Files.CymakePath+      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+    , 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+    , 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   Other-Modules:     Paths_curry_frontend+  ghc-options:       -Wall -fno-warn-orphans++Executable curry-frontend+  hs-source-dirs: src+  Main-is:        cymake.hs+  default-language:  Haskell2010+  Build-Depends:+      base == 4.*+    , containers+    , curry-base == 1.0.0+    , curry-frontend+    , directory+    , extra >= 1.4.6+    , filepath+    , mtl+    , pretty+    , process+    , set-extra+    , transformers+  if flag(network-uri)+    build-depends: network-uri >= 2.6+  else+    build-depends: network < 2.6+  ghc-options: -Wall -fno-warn-orphans++Test-Suite test-frontend+  type:           detailed-0.9+  hs-source-dirs: test+  default-language:  Haskell2010+  test-module:    TestFrontend+  build-depends:  base == 4.*, Cabal >= 1.20, curry-base == 1.0.0+    , curry-frontend, filepath

@@ -0,0 +1,41 @@+/* Use always white background */+body {+  background : white;+  color      : black;+  font-family: monospace;+}++/* Show hyperlinks without text decoration, but in light yellow */+a:visited, a:link, a:active {+  text-decoration: none;+  background     : lightyellow;+}++/* Line numbers */+.linenumbers {+  width        : 40px;+  text-align   : right;+  color        : grey;+  padding-right: 10px;+  border-right : 1px solid grey;+}++/* Source code */+.sourcecode  {+  padding-left: 10px;+}++/* Code highlighting */+.pragma  { color : green     }+.comment { color : green     }+.keyword { color : blue      }+.symbol  { color : red       }+.type    { color : orange    }+.cons    { color : magenta   }+.label   { color : darkgreen }+.func    { color : purple    }+.ident   { color : black     }+.module  { color : brown     }+.number  { color : teal      }+.string  { color : maroon    }+.char    { color : maroon    }

@@ -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------------------------------------------------------------------------------------------------------------------------------------------------------------------

@@ -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}---

@@ -0,0 +1,123 @@+{- |+    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.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 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)

@@ -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 (ppKindExpr)+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 = ppKindExpr 0 . fromKind

@@ -0,0 +1,215 @@+{- |+    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 qualified Curry.Syntax as CS+import Curry.Syntax.Pretty (ppConstraint, ppTypeExpr, ppQualTypeExpr)++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.Context -> [CS.TypeExpr] -> PredType+toConstrType tc tvs cx tys = toPredType tvs $ CS.QualTypeExpr cx' ty'+  where tvs' = nub (fv tys)+        cx'  = restrictContext tvs' cx+        ty'  = foldr CS.ArrowType ty0 tys+        ty0  = foldl CS.ApplyType+                     (CS.ConstructorType tc)+                     (map CS.VariableType tvs)++restrictContext :: [Ident] -> CS.Context -> CS.Context+restrictContext tvs cx =+  [CS.Constraint cls ty | CS.Constraint cls ty <- cx, classVar ty `elem` tvs]+  where classVar (CS.VariableType tv) = tv+        classVar (CS.ApplyType  ty _) = classVar ty+        classVar _ = internalError "Base.CurryTypes.restrictContext.classVar"++-- 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 cx ty) =+  toPredType [clsvar] (CS.QualTypeExpr cx' ty)+  where cx' = CS.Constraint qcls (CS.VariableType 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 tys+  | tc == qListId && length tys == 1              = CS.ListType (head tys)+  | otherwise+  = foldl CS.ApplyType (CS.ConstructorType tc) tys+fromType' tvs (TypeApply     ty1 ty2) tys =+  fromType' tvs ty1 (fromType tvs ty2 : tys)+fromType' tvs (TypeVariable       tv) tys =+  foldl CS.ApplyType (CS.VariableType (fromVar tvs tv)) tys+fromType' tvs (TypeArrow     ty1 ty2) tys =+  foldl CS.ApplyType (CS.ArrowType (fromType tvs ty1) (fromType tvs ty2)) tys+fromType' tvs (TypeConstrained tys _) tys' = fromType' tvs (head tys) tys'+fromType' _   (TypeSkolem          k) tys =+  foldl CS.ApplyType (CS.VariableType $ mkIdent $ "_?" ++ show k) tys+fromType' tvs (TypeForall    tvs' ty) tys+  | null tvs' = fromType' tvs ty tys+  | otherwise = foldl CS.ApplyType+                      (CS.ForallType (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 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 (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 = ppTypeExpr 0 . fromQualType m identSupply++ppPred :: ModuleIdent -> Pred -> Doc+ppPred m = ppConstraint . fromQualPred m identSupply++ppPredType :: ModuleIdent -> PredType -> Doc+ppPredType m = ppQualTypeExpr . fromQualPredType m identSupply++ppTypeScheme :: ModuleIdent -> TypeScheme -> Doc+ppTypeScheme m (ForAll _ pty) = ppPredType m pty

@@ -0,0 +1,211 @@+{- |+    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.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 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))

@@ -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

@@ -0,0 +1,55 @@+{- |+    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)

@@ -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+  ) where++import Control.Monad              (unless, when)+import Control.Monad.IO.Class     (MonadIO(..))+import Data.List                  (sort)+import System.IO                  (hFlush, hPutStrLn, stderr, stdout)+import System.Exit                (exitFailure)++import Curry.Base.Message         ( Message, message, posMessage, ppWarning+                                  , ppMessages, ppError)+import Curry.Base.Pretty          (Doc, text)+import CompilerOpts               (Options (..), WarnOpts (..), Verbosity (..))++-- |Print a status message, depending on the current verbosity+status :: MonadIO m => Options -> String -> m ()+status opts msg = unless (optVerbosity opts < VerbStatus) (putMsg msg)++-- |Print a message on 'stdout'+putMsg :: MonadIO m => String -> m ()+putMsg msg = liftIO (putStrLn msg >> hFlush stdout)++-- |Print an error message on 'stderr'+putErrLn :: MonadIO m => String -> m ()+putErrLn msg = liftIO (hPutStrLn stderr msg >> hFlush stderr)++-- |Print a list of error messages on 'stderr'+putErrsLn :: MonadIO m => [String] -> m ()+putErrsLn = mapM_ putErrLn++-- |Print a list of 'String's as error messages on 'stderr'+-- and abort the program+abortWith :: [String] -> IO a+abortWith errs = putErrsLn errs >> exitFailure++-- |Print a single error message on 'stderr' and abort the program+abortWithMessage :: Message -> IO a+abortWithMessage msg = abortWithMessages [msg]++-- |Print a list of error messages on 'stderr' and abort the program+abortWithMessages :: [Message] -> IO a+abortWithMessages msgs = printMessages ppError msgs >> exitFailure++-- |Print a list of warning messages on 'stderr' and abort the program+-- |if the -Werror option is set+warnOrAbort :: WarnOpts -> [Message] -> IO ()+warnOrAbort opts msgs = when (wnWarn opts && not (null msgs)) $ do+  if wnWarnAsError opts+    then abortWithMessages (msgs ++ [message $ text "Failed due to -Werror"])+    else printMessages ppWarning msgs++-- |Print a list of messages on 'stderr'+printMessages :: (Message -> Doc) -> [Message] -> IO ()+printMessages msgType msgs+  = unless (null msgs) $ putErrLn (show $ ppMessages msgType $ sort msgs)++-- |Raise an internal error+internalError :: String -> a+internalError msg = error $ "Internal error: " ++ msg

@@ -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

@@ -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+-}++module Base.PrettyKinds where++import Curry.Base.Pretty++import Base.CurryKinds+import Base.Kinds++instance Pretty Kind where+  pPrint = ppKind

@@ -0,0 +1,54 @@+{- |+    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 Base.PrettyTypes where++import Data.Maybe (fromMaybe)+import qualified Data.Set as Set (Set, toAscList)++import Curry.Base.Ident (identSupply)+import Curry.Base.Pretty+import Curry.Syntax.Pretty++import Base.CurryTypes+import Base.Types++instance Pretty Type where+  pPrint = ppTypeExpr 0 . fromType identSupply++instance Pretty Pred where+  pPrint = ppConstraint . fromPred identSupply++instance Pretty a => Pretty (Set.Set a) where+  pPrint = parens . list . map pPrint . Set.toAscList++instance Pretty PredType where+  pPrint = ppQualTypeExpr . 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++instance Pretty ExistTypeScheme where+  pPrint (ForAllExist _ _ ty) = pPrint ty

@@ -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

@@ -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))

@@ -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]

@@ -0,0 +1,113 @@+{- |+    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' _ _     ts@(TypeSkolem        _) tys = applyType ts 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]+                 -> Context -> [TypeExpr] -> PredType+expandConstrType m tcEnv clsEnv tc tvs cx tys =+  normalize n $ expandPredType m tcEnv clsEnv pty+  where n = length tvs+        pty = toConstrType tc tvs cx 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

@@ -0,0 +1,143 @@+{- |+    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' _     ts@(TypeSkolem        _) = foldl TypeApply ts+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 ExistTypeScheme where+  subst sigma (ForAllExist n n' ty) =+    ForAllExist n n' (subst (foldr unbindSubst sigma [0 .. n + n' - 1]) ty)++instance SubstType ValueInfo where+  subst _     dc@(DataConstructor  _ _ _ _) = dc+  subst _     nc@(NewtypeConstructor _ _ _) = nc+  subst theta (Value             v 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' _   ts@(TypeSkolem        _) = applyType ts+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

@@ -0,0 +1,511 @@+{- |+    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 (..), ExistTypeScheme (..), 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.++-- The case 'TypeSkolem' is used for handling skolem types, which+-- result from the use of existentially quantified data constructors.++-- Type variables are represented with deBruijn style indices. Universally+-- quantified type variables are assigned indices in the order of their+-- occurrence in the type from left to right. This leads to a canonical+-- representation of types where alpha-equivalence of two types+-- coincides with equality of the representation.++-- Note that even though 'TypeConstrained' variables use indices+-- as well, these variables must never be quantified.++-- 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+  | TypeSkolem 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 (TypeSkolem           k) tys  = (TypeSkolem k, 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 (TypeSkolem        _) tcs = tcs+  constrs (TypeForall    _ ty') tcs = constrs ty' tcs++-- The methods 'typeVars' and 'typeSkolems' return a list of all type+-- variables and skolems occurring in a type t, respectively. Note that+-- 'TypeConstrained' variables are not included in the set of type+-- variables because they cannot be generalized.++class IsType t where+  typeVars :: t -> [Int]+  typeSkolems :: t -> [Int]++instance IsType Type where+  typeVars = typeVars'+  typeSkolems = typeSkolems'++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 (TypeSkolem        _) tvs = tvs+  vars (TypeForall tvs' ty') tvs = filter (`notElem` tvs') (typeVars' ty') ++ tvs++typeSkolems' :: Type -> [Int]+typeSkolems' ty = skolems ty [] where+  skolems (TypeConstructor   _) sks = sks+  skolems (TypeApply   ty1 ty2) sks = skolems ty1 (skolems ty2 sks)+  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 (TypeForall    _ ty') sks = skolems ty' sks++-- 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 _ ts@(TypeSkolem        _) = ts+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 _ ts@(TypeSkolem        _) = ts+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 (see predicate+-- sets below for more information).++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+  typeSkolems (Pred _ ty) = typeSkolems 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+  typeSkolems = concat . Set.toList . Set.map typeSkolems++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+  typeSkolems (PredType ps ty) = typeSkolems ty ++ typeSkolems 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. The 'Int' denotes the number+-- of existentially quantified type variables in the types.++data DataConstr = DataConstr   Ident Int PredSet [Type]+                | RecordConstr Ident Int PredSet [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) 0 emptyPredSet (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 two kinds of quantifications of types here, universally+-- quantified type schemes (forall alpha . tau(alpha)) and universally+-- and existentially quantified type schemes+-- (forall alpha exists eta . tau(alpha,eta)). In both, quantified type+-- variables are assigned ascending indices starting from 0. Therefore it+-- is sufficient to record the numbers of quantified type variables in+-- the 'ForAll' and 'ForAllExist' constructors. In case of+-- the latter, the first of the two numbers is the number of universally+-- quantified variables and the second the number of existentially+-- quantified variables.++data TypeScheme = ForAll Int PredType deriving (Eq, Show)+data ExistTypeScheme = ForAllExist Int Int PredType deriving (Eq, Show)++instance IsType TypeScheme where+  typeVars (ForAll _ pty) = [tv | tv <- typeVars pty, tv < 0]+  typeSkolems (ForAll _ pty) = typeSkolems pty++instance IsType ExistTypeScheme where+  typeVars (ForAllExist _ _ pty) = [tv | tv <- typeVars pty, tv < 0]+  typeSkolems (ForAllExist _ _ pty) = typeSkolems pty++-- 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 0 emptyPredSet [] ])+  , (listType a   , [ DataConstr nilId  0 emptyPredSet []+                    , DataConstr consId 0 emptyPredSet [a, listType a]+                    ])+  ]+  where a = TypeVariable 0+        b = TypeVariable 1

@@ -0,0 +1,192 @@+{- |+    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' (TypeSkolem k1) (TypeSkolem k2)+  | k1 == k2 = 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

@@ -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

@@ -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)------------------------------------------------------------------------------------------------------------------------------------------------------------------

@@ -0,0 +1,162 @@+{- |+    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 { extensions = exts }, mdl')+  | otherwise = failMessages msgs+  where ((mdl', exts), msgs) = TSC.typeSyntaxCheck (extensions env)+                                                   (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 ps m es is ds)+  | null msgs = ok (env { opPrecEnv = pEnv' }, Module ps m es is ds')+  | otherwise = failMessages msgs+  where (ds', pEnv', msgs) = PC.precCheck (moduleIdent env) (opPrecEnv env) ds++-- |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 ps m es is ds)+  | null msgs = ok (env { instEnv = inEnv' }, Module 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 ps m es is ds)+  | null msgs = ok (env { valueEnv = vEnv' }, Module 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 ps m es is ds)+  = return (env, Module ps m (Just es') is ds)+  where es' = EC.expandExports (moduleIdent env) (aliasEnv env)+                               (tyConsEnv env) (valueEnv env) es++-- |Check for warnings.+warnCheck :: Options -> CompilerEnv -> Module a -> [Message]+warnCheck opts env mdl = WC.warnCheck (optWarnOpts opts) (optCaseMode opts)+  (aliasEnv env) (valueEnv env) (tyConsEnv env) (classEnv env) mdl

@@ -0,0 +1,108 @@+{- |+    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.Position+import Curry.Base.Pretty+import Curry.Syntax++import Base.Messages (Message, posMessage)++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]+  | any (not . null . existVars) cs = [errNoExistentialDerive 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 ocls]+  | otherwise                                = []+  where ocls = getOrigName m cls tcEnv++derivableClasses :: [QualIdent]+derivableClasses = [qEqId, qOrdId, qEnumId, qBoundedId, qReadId, qShowId]++-- Instances of 'Enum' can be derived only for enumeration types, i.e., types+-- where all data constructors are constants.++isEnum :: [ConstrDecl] -> Bool+isEnum cs = all ((0 ==) . constrArity) cs++-- 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++existVars :: ConstrDecl -> [Ident]+existVars (ConstrDecl _ evs _ _ _  ) = evs+existVars (ConOpDecl  _ evs _ _ _ _) = evs+existVars (RecordDecl _ evs _ _ _  ) = evs++-- ---------------------------------------------------------------------------+-- Error messages+-- ---------------------------------------------------------------------------++errNoAbstractDerive :: HasPosition a => a -> Message+errNoAbstractDerive p = posMessage p $+  text "Instances can only be derived for data types with" <+>+  text "at least one constructor"++errNoExistentialDerive :: HasPosition a => a -> Message+errNoExistentialDerive p = posMessage p $+  text "Instances cannot be derived for existential data types"++errNotDerivable :: QualIdent -> Message+errNotDerivable cls = posMessage cls $ hsep $ map text+  ["Instances of type class", escQualName cls, "cannot be derived"]++errNotEnum :: HasPosition a => a -> Message+errNotEnum p = posMessage p $+  text "Instances for Enum can be derived only for enumeration types"++errNotBounded :: HasPosition a => a -> Message+errNotBounded p = posMessage p $+  text "Instances of Bounded can be derived only for enumeration" <+>+  text "and single constructor types"

@@ -0,0 +1,482 @@+{- |+    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__ < 710+import           Control.Applicative        ((<$>))+#endif+import           Control.Monad              (unless)+import qualified Control.Monad.State as S   (State, runState, gets, modify)+import           Data.List                  (nub, union)+import qualified Data.Map            as Map ( Map, elems, empty, insert+                                            , insertWith, lookup, toList )+import           Data.Maybe                 (fromMaybe)+import qualified Data.Set            as Set ( Set, empty, fromList, insert+                                            , member, toList )++import Curry.Base.Ident+import Curry.Base.Position+import Curry.Base.Pretty+import Curry.Syntax++import Base.Messages       (Message, internalError, posMessage)+import Base.TopEnv         (allEntities, origName, localBindings, moduleImports)+import Base.Types          ( Type (..), unapplyType, arrowBase, PredType (..)+                           , DataConstr (..), constrIdent, recLabels+                           , ClassMethod, methodName+                           , TypeScheme (..), ExistTypeScheme (..) )+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 (exportPos spec) es+  where+  exportPos (Just (Exporting p _)) = p+  exportPos Nothing                = NoPos++  es = expand m aEnv tcEnv tyEnv spec++exportCheck :: ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv+            -> Maybe ExportSpec -> [Message]+exportCheck m aEnv tcEnv tyEnv spec = case check m aEnv tcEnv tyEnv spec of+  [] -> checkNonUniqueness $ expand m aEnv tcEnv tyEnv spec+  ms -> ms++-- -----------------------------------------------------------------------------+-- Export Check Monad+-- -----------------------------------------------------------------------------++data ECState = ECState+  { moduleIdent  :: ModuleIdent+  , importedMods :: Set.Set ModuleIdent+  , tyConsEnv    :: TCEnv+  , valueEnv     :: ValueEnv+  , errors       :: [Message]+  }++type ECM a = S.State ECState a++runECM :: ECM a -> ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv -> (a, [Message])+runECM ecm m aEnv tcEnv tyEnv+  = let (a, s') = S.runState ecm initState in (a, reverse $ errors s')+  where+  initState  = ECState m imported tcEnv tyEnv []+  imported   = Set.fromList (Map.elems aEnv)++getModuleIdent :: ECM ModuleIdent+getModuleIdent = S.gets moduleIdent++getImportedModules :: ECM (Set.Set ModuleIdent)+getImportedModules = S.gets importedMods++getTyConsEnv :: ECM TCEnv+getTyConsEnv = S.gets tyConsEnv++getValueEnv :: ECM ValueEnv+getValueEnv = S.gets valueEnv++report :: Message -> ECM ()+report err = S.modify (\ s -> s { errors = err : errors s })++ok :: ECM ()+ok = return ()++-- -----------------------------------------------------------------------------+-- Check+-- -----------------------------------------------------------------------------++check :: ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv -> Maybe ExportSpec+      -> [Message]+check m aEnv tcEnv tyEnv spec = snd $ runECM (checkSpec spec) m aEnv tcEnv tyEnv++-- |Check export specification.+checkSpec :: Maybe ExportSpec -> ECM ()+checkSpec (Just (Exporting _ es)) = mapM_ checkExport es+checkSpec Nothing                 = ok++-- |Check single export.+checkExport :: Export -> ECM ()+checkExport (Export         x    ) = checkThing x+checkExport (ExportTypeWith tc cs) = checkTypeWith tc cs+checkExport (ExportTypeAll  tc   ) = checkTypeAll tc+checkExport (ExportModule   em   ) = checkModule em++-- |Check export of type constructor / function+checkThing :: QualIdent -> ECM ()+checkThing tc = do+  m     <- getModuleIdent+  tcEnv <- getTyConsEnv+  case qualLookupTypeInfoUnique m tc tcEnv of+    []  -> checkThing' tc Nothing+    [t] -> checkThing' tc (Just [ExportTypeWith (origName t) []])+    ts  -> report (errAmbiguousType tc ts)++-- |Expand export of data cons / function+checkThing' :: QualIdent -> Maybe [Export] -> ECM ()+checkThing' f tcExport = do+  m     <- getModuleIdent+  tyEnv <- getValueEnv+  case qualLookupValueUnique m f tyEnv of+    []  -> justTcOr errUndefinedName+    [v] -> case v of+      Value _ _ _ _ -> ok+      Label   _ _ _ -> report $ errOutsideTypeLabel f (getTc v)+      _             -> justTcOr $ flip errOutsideTypeConstructor (getTc v)+    fs  -> report (errAmbiguousName f fs)+  where+  justTcOr errFun = maybe (report $ errFun f) (const ok) tcExport++  getTc (DataConstructor  _ _ _ (ForAllExist _ _ (PredType _ ty))) = getTc' ty+  getTc (NewtypeConstructor _ _ (ForAllExist _ _ (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 (origName t @> tc) []])+    err -> internalError $ currentModuleName ++ ".expandThing: " ++ show err++-- |Expand export of data cons / function+expandThing' :: QualIdent -> Maybe [Export] -> ECM [Export]+expandThing' f tcExport = do+  m     <- getModuleIdent+  tyEnv <- getValueEnv+  case qualLookupValueUnique m f tyEnv of+    [Value f' _ _ _] -> return $ Export (f' @> f) : fromMaybe [] tcExport+    _                -> return $ fromMaybe [] tcExport++-- |Expand type constructor with explicit data constructors and record labels+expandTypeWith :: QualIdent -> [Ident] -> ECM [Export]+expandTypeWith tc xs = do+  m     <- getModuleIdent+  tcEnv <- getTyConsEnv+  case qualLookupTypeInfoUnique m tc tcEnv of+    [t] -> return [ExportTypeWith (origName t @> tc) $ nub xs]+    err -> internalError $ currentModuleName ++ ".expandTypeWith: " ++ show err++-- |Expand type constructor with all data constructors and record labels+expandTypeAll :: QualIdent -> ECM [Export]+expandTypeAll tc = do+  m     <- getModuleIdent+  tcEnv <- getTyConsEnv+  case 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 ]+    ++ [ Export f' | (f, Value f' _ _ _) <- localBindings tyEnv, hasGlobalScope f ]+    ++ [ Export l' | (l, Label l' _ _) <- localBindings tyEnv, hasGlobalScope l ]++-- |Expand a module export+expandImportedModule :: ModuleIdent -> ECM [Export]+expandImportedModule m = do+  tcEnv <- getTyConsEnv+  tyEnv <- getValueEnv+  return $ [exportType t |       (_, t) <- moduleImports m tcEnv]+        ++ [Export f | (_, Value f _ _ _) <- moduleImports m tyEnv]+        ++ [Export l | (_, Label l _ _) <- moduleImports m tyEnv]++exportType :: TypeInfo -> Export+exportType t = ExportTypeWith tc xs+  where tc = origName t+        xs = elements t++-- -----------------------------------------------------------------------------+-- Canonicalization and joining of exports+-- -----------------------------------------------------------------------------++-- In contrast to Haskell, the export of field labels and record constructors+-- without their types is NOT allowed.+-- Thus, given the declaration @data T a = C { l :: a }@+-- the label @l@ and the constructor @C@ can only be exported together with the+-- type @T@, i.e., @(T(C,l))@.+-- Since record update operations are desugared to case expressions matching the+-- corresponding constructors of the record, the export of a label without its+-- type could result in a type error, when it is used for an update operation in+-- another module.++canonExports :: TCEnv -> [Export] -> [Export]+canonExports tcEnv es = map (canonExport (canonLabels tcEnv es)) es++canonExport :: Map.Map QualIdent Export -> Export -> Export+canonExport ls (Export x)             = fromMaybe (Export x) (Map.lookup x ls)+canonExport _  (ExportTypeWith tc xs) = ExportTypeWith tc xs+canonExport _  e                      = internalError $+  currentModuleName ++ ".canonExport: " ++ show e++canonLabels :: TCEnv -> [Export] -> Map.Map QualIdent Export+canonLabels tcEnv es = foldr bindLabels Map.empty (allEntities tcEnv)+  where+  tcs = [tc | ExportTypeWith tc _ <- es]+  bindLabels t ls+    | tc' `elem` tcs = foldr (bindLabel tc') ls (elements t)+    | otherwise     = ls+      where+        tc'            = origName t+        bindLabel tc x = Map.insert (qualifyLike tc x) (ExportTypeWith tc [x])++-- The expanded list of exported entities may contain duplicates. These+-- are removed by the function joinExports. In particular, this+-- function removes any field labels from the list of exported values+-- which are also exported along with their types.++joinExports :: [Export] -> [Export]+joinExports es =  [ExportTypeWith tc cs | (tc, cs) <- joinedTypes]+               ++ [Export f             | f        <- joinedFuncs]+  where joinedTypes = Map.toList $ foldr joinType Map.empty es+        joinedFuncs = Set.toList $ foldr joinFun  Set.empty es++joinType :: Export -> Map.Map QualIdent [Ident] -> Map.Map QualIdent [Ident]+joinType (Export             _) tcs = tcs+joinType (ExportTypeWith tc cs) tcs = Map.insertWith union tc cs tcs+joinType export                   _ = internalError $+  currentModuleName ++ ".joinType: " ++ show export++joinFun :: Export -> Set.Set QualIdent -> Set.Set QualIdent+joinFun (Export           f) fs = f `Set.insert` fs+joinFun (ExportTypeWith _ _) fs = fs+joinFun export                _ = internalError $+  currentModuleName ++ ".joinFun: " ++ show export++-- ---------------------------------------------------------------------------+-- Auxiliary definitions+-- ---------------------------------------------------------------------------++elements :: TypeInfo -> [Ident]+elements (DataType      _ _ cs) = visibleElems cs+elements (RenamingType   _ _ c) = visibleElems [c]+elements (AliasType    _ _ _ _) = []+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 = posMessage qn+  $   text "Ambiguous" <+> text what <+> text (escQualName qn)+  $+$ text "It could refer to:"+  $+$ nest 2 (vcat (map (text . escQualName) qns))++errModuleNotImported :: ModuleIdent -> Message+errModuleNotImported m = posMessage m $ hsep $ map text+  ["Module", escModuleName m, "not imported"]++errMultipleName :: [Ident] -> Message+errMultipleName = errMultiple "name"++errMultipleType :: [Ident] -> Message+errMultipleType = errMultiple "type"++errMultiple :: String -> [Ident] -> Message+errMultiple _    []     = internalError $+  currentModuleName ++ ".errMultiple: empty list"+errMultiple what (i:is) = posMessage i $+  text "Multiple exports of" <+> text what <+> text (escName i) <+> text "at:"+  $+$ nest 2 (vcat (map showPos (i:is)))+  where showPos = text . showLine . idPosition++errNonDataTypeOrTypeClass :: QualIdent -> Message+errNonDataTypeOrTypeClass tc = posMessage 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 = posMessage q+  $   text what <+> text (escQualName q)+         <+> text "outside type export in export list"+  $+$ text "Use `" <> text (qualName tc) <+> parens (text (qualName q))+  <>  text "' instead"++errUndefinedElement :: QualIdent -> Ident -> Message+errUndefinedElement tc c = posMessage c $ hsep $ map text+  [ escName c, "is not a constructor or label of type", escQualName tc ]++errUndefinedMethod :: QualIdent -> Ident -> Message+errUndefinedMethod cls f = posMessage 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 = posMessage tc $ hsep $ map text+  ["Undefined", what, escQualName tc, "in export list"]

@@ -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.Position+import Curry.Base.Pretty+import Curry.Syntax++import Base.Messages (Message, posMessage)++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 unkown.++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 :: Position -> String -> Message+errUnknownExtension p e = posMessage p $+  text "Unknown language extension:" <+> text e

@@ -0,0 +1,278 @@+{- |+    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.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             x) =               expandThing    x+expandImport (ImportTypeWith tc cs) = (:[]) `liftM` expandTypeWith tc cs+expandImport (ImportTypeAll     tc) = (:[]) `liftM` expandTypeAll  tc++expandHiding :: Import -> ExpandM [Import]+expandHiding (Import             x) = expandHide x+expandHiding (ImportTypeWith tc cs) = (:[]) `liftM` expandTypeWith tc cs+expandHiding (ImportTypeAll     tc) = (:[]) `liftM` expandTypeAll  tc++-- try to expand as type constructor+expandThing :: Ident -> ExpandM [Import]+expandThing tc = do+  tcEnv <- getTyConsEnv+  case Map.lookup tc tcEnv of+    Just _  -> expandThing' tc $ Just [ImportTypeWith tc []]+    Nothing -> expandThing' tc Nothing++-- try to expand as function / data constructor+expandThing' :: Ident -> Maybe [Import] -> ExpandM [Import]+expandThing' f tcImport = do+  m     <- getModuleIdent+  tyEnv <- getValueEnv+  expand m f (Map.lookup f tyEnv) tcImport+  where+  expand :: ModuleIdent -> Ident+         -> Maybe IValueInfo -> Maybe [Import] -> ExpandM [Import]+  expand m e Nothing  Nothing   = report (errUndefinedEntity m e) >> return []+  expand _ _ Nothing  (Just tc) = return tc+  expand m e (Just v) maybeTc+    | isConstr v = case maybeTc of+        Nothing -> report (errImportDataConstr m e) >> return []+        Just tc -> return tc+    | otherwise  = return [Import e]++  isConstr (Constr _) = True+  isConstr (Var  _ _) = False++-- try to hide as type constructor+expandHide :: Ident -> ExpandM [Import]+expandHide tc = do+  tcEnv <- getTyConsEnv+  case Map.lookup tc tcEnv of+    Just _  -> expandHide' tc $ Just [ImportTypeWith tc []]+    Nothing -> expandHide' tc Nothing++-- try to hide as function / data constructor+expandHide' :: Ident -> Maybe [Import] -> ExpandM [Import]+expandHide' f tcImport = do+  m     <- getModuleIdent+  tyEnv <- getValueEnv+  case Map.lookup f tyEnv of+    Just _  -> return $ Import f : fromMaybe [] tcImport+    Nothing -> case tcImport of+      Nothing -> report (errUndefinedEntity m f) >> return []+      Just tc -> return tc++expandTypeWith ::  Ident -> [Ident] -> ExpandM Import+expandTypeWith tc cs = do+  m     <- getModuleIdent+  tcEnv <- getTyConsEnv+  ImportTypeWith tc `liftM` case Map.lookup tc tcEnv of+    Just (Data  _ xs) -> mapM (checkElement 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 :: Ident -> ExpandM Import+expandTypeAll tc = do+  m     <- getModuleIdent+  tcEnv <- getTyConsEnv+  ImportTypeWith tc `liftM` case Map.lookup tc tcEnv of+    Just (Data _  xs) -> return xs+    Just (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 = posMessage c $ hsep $ map text+  [ idName c, "is not a constructor or label of type ", idName tc ]++errUndefinedMethod :: Ident -> Ident -> Message+errUndefinedMethod cls f = posMessage f $ hsep $ map text+  [ idName f, "is not a method of class", idName cls ]++errUndefinedEntity :: ModuleIdent -> Ident -> Message+errUndefinedEntity m x = posMessage x $ hsep $ map text+  [ "Module", moduleName m, "does not export", idName x ]++errNonDataTypeOrTypeClass :: Ident -> Message+errNonDataTypeOrTypeClass tc = posMessage tc $ hsep $ map text+  [ idName tc, "is not a data type or type class" ]++errImportDataConstr :: ModuleIdent -> Ident -> Message+errImportDataConstr _ c = posMessage c $ hsep $ map text+  [ "Explicit import for data constructor", idName c ]

@@ -0,0 +1,356 @@+{- |+    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)+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.Position+import Curry.Base.Pretty+import Curry.Syntax hiding (impls)+import Curry.Syntax.Pretty++import Base.CurryTypes+import Base.Messages (Message, posMessage, 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) $ map (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 (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++-- 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 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 Position 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 cxs) (concat tyss) clss+  where (cxs, tyss) = unzip (map constrDeclTypes cs)+        constrDeclTypes (ConstrDecl     _ _ cx _ tys) = (cx, tys)+        constrDeclTypes (ConOpDecl  _ _ cx ty1 _ ty2) = (cx, [ty1, ty2])+        constrDeclTypes (RecordDecl      _ _ cx _ fs) = (cx, 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"++mkDeriveInfo :: TCEnv -> ClassEnv -> Position -> Ident -> [Ident] -> Context+           -> [TypeExpr] -> [QualIdent] -> INCM DeriveInfo+mkDeriveInfo tcEnv clsEnv p tc tvs cx 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 cx tys+      (tys', ty') = arrowUnapply ty+  return $ DeriveInfo p otc (PredType ps ty') tys' $ sortClasses clsEnv oclss++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 ds = scc bound free ds+  where bound (DeriveInfo _ tc _ _ _) = [tc]+        free (DeriveInfo _ _ _ tys _) = concatMap typeConstrs tys++bindDerivedInstances :: ClassEnv -> [DeriveInfo] -> INCM ()+bindDerivedInstances clsEnv dis = do+  mapM_ (enterInitialPredSet clsEnv) dis+  whileM $ concatMapM (inferPredSets clsEnv) dis >>= updatePredSets++enterInitialPredSet :: ClassEnv -> DeriveInfo -> INCM ()+enterInitialPredSet clsEnv (DeriveInfo p tc pty _ clss) =+  mapM_ (bindDerivedInstance clsEnv p 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.++bindDerivedInstance :: ClassEnv -> Position -> QualIdent -> PredType -> [Type]+                    -> QualIdent -> INCM ()+bindDerivedInstance clsEnv p tc pty tys cls = do+  m <- getModuleIdent+  (i, ps) <- inferPredSet clsEnv p tc pty tys 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, 1), (minBoundId, 1)]+              | cls == qReadId    = [(readsPrecId, 2)]+              | cls == qShowId    = [(showsPrecId, 2)]+              | otherwise         =+                internalError "InstanceCheck.bindDerivedInstance.impls"++inferPredSets :: ClassEnv -> DeriveInfo -> INCM [(InstIdent, PredSet)]+inferPredSets clsEnv (DeriveInfo p tc pty tys clss) =+  mapM (inferPredSet clsEnv p tc pty tys) clss++inferPredSet :: ClassEnv -> Position -> QualIdent -> PredType -> [Type]+             -> QualIdent -> INCM (InstIdent, PredSet)+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''+  ps'''' <- reducePredSet p "derived instance" doc clsEnv ps'''+  mapM_ (reportUndecidable p "derived instance" doc) $ Set.toList ps''''+  return ((cls, tc), ps'''')++updatePredSets :: [(InstIdent, PredSet)] -> INCM Bool+updatePredSets = (=<<) (return . or) . mapM (uncurry updatePredSet)++updatePredSet :: InstIdent -> PredSet -> INCM Bool+updatePredSet i ps = do+  inEnv <- getInstEnv+  case lookupInstInfo i inEnv of+    Just (m, ps', is)+      | ps == ps' -> return False+      | otherwise -> do+        modifyInstEnv $ bindInstInfo i (m, ps, is)+        return True+    Nothing -> internalError "InstanceCheck.updatePredSet"++reportUndecidable :: Position -> 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 p cx cls inst _) = do+  m <- getModuleIdent+  let PredType ps ty = expandPolyType m tcEnv clsEnv $ QualTypeExpr 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 p what doc clsEnv ps'+  Set.mapM_ (report . errMissingInstance m p 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 p tys) =+  mapM_ (checkDefaultType p tcEnv clsEnv) tys+checkDefault _ _ _ = ok++checkDefaultType :: Position -> TCEnv -> ClassEnv -> TypeExpr -> INCM ()+checkDefaultType p tcEnv clsEnv ty = do+  m <- getModuleIdent+  let PredType _ ty' = expandPolyType m tcEnv clsEnv $ QualTypeExpr [] ty+  ps <- reducePredSet p what empty clsEnv (Set.singleton $ Pred qNumId ty')+  Set.mapM_ (report . errMissingInstance m p 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.++reducePredSet :: Position -> String -> Doc -> ClassEnv -> PredSet+              -> INCM PredSet+reducePredSet p what doc clsEnv ps = do+  m <- getModuleIdent+  inEnv <- getInstEnv+  let (ps1, ps2) = partitionPredSet $ minPredSet clsEnv $ reducePreds inEnv ps+  Set.mapM_ (report . errMissingInstance m p what doc) ps2+  return ps1+  where+    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 $ qualify tc) qclss+genInstIdents m tcEnv (NewtypeDecl _ tc _ _ qclss) =+  map (flip (genInstIdent m tcEnv) $ ConstructorType $ 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++-- ---------------------------------------------------------------------------+-- 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 :: ModuleIdent -> Position -> String -> Doc -> Pred+                   -> Message+errMissingInstance m p what doc predicate = posMessage p $ vcat+  [ text "Missing instance for" <+> ppPred m predicate+  , text "in" <+> text what <+> doc+  ]

@@ -0,0 +1,315 @@+{- |+    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)++import Curry.Base.Ident+import Curry.Base.Position+import Curry.Base.Pretty+import Curry.Syntax++import Base.CurryKinds (toKind')+import Base.CurryTypes+import Base.Messages (Message, posMessage, 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 p fix pr op) = checkPrecInfo check p op+  where check (PrecInfo op' (OpPrec fix' pr')) =+          op == op' && fix == fix' && pr == pr'+checkImport (HidingDataDecl p tc k tvs) =+  checkTypeInfo "hidden data type" check p 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 p tc k tvs cs _) = checkTypeInfo "data type" check p 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 p tc k tvs nc _) = checkTypeInfo "newtype" check p 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 p 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 p tc+checkImport (IFunctionDecl p f (Just tv) n ty) = do+  m <- getModuleIdent+  let check (Value f' cm' n' (ForAll _ ty')) =+        f == f' && True == cm' && n' == n && toQualPredType m [tv] ty == ty'+      check _ = False+  checkValueInfo "method" check p f+checkImport (IFunctionDecl p f Nothing n ty) = do+  m <- getModuleIdent+  let check (Value f' cm' n' (ForAll _ ty')) =+        f == f' && False == cm' && n' == n && toQualPredType m [] ty == ty'+      check _ = False+  checkValueInfo "function" check p f+checkImport (HidingClassDecl p 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 p cls+checkImport (IClassDecl p 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 p cls+checkImport (IInstanceDecl p cx cls ty is m) = do+  checkInstInfo check p (cls, typeConstr ty) m+  where PredType ps _ = toPredType [] $ QualTypeExpr cx ty+        check ps' is' = ps == ps' && sort is == sort is'++checkConstrImport :: QualIdent -> [Ident] -> ConstrDecl -> IC ()+checkConstrImport tc tvs (ConstrDecl p evs cx c tys) = do+  m <- getModuleIdent+  let qc = qualifyLike tc c+      check (DataConstructor c' _ _ (ForAllExist uqvs eqvs pty)) =+        qc == c' && length evs == eqvs && length tvs == uqvs &&+        qualifyPredType m (toConstrType tc tvs cx tys) == pty+      check _ = False+  checkValueInfo "data constructor" check p qc+checkConstrImport tc tvs (ConOpDecl p evs cx ty1 op ty2) = do+  m <- getModuleIdent+  let qc = qualifyLike tc op+      check (DataConstructor c' _ _ (ForAllExist uqvs eqvs pty)) =+        qc == c' && length evs == eqvs && length tvs == uqvs &&+        qualifyPredType m (toConstrType tc tvs cx [ty1, ty2]) == pty+      check _ = False+  checkValueInfo "data constructor" check p qc+checkConstrImport tc tvs (RecordDecl p evs cx 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' (ForAllExist uqvs eqvs pty)) =+        qc == c' && length evs == eqvs && length tvs == uqvs && ls == ls' &&+        qualifyPredType m (toConstrType tc tvs cx tys) == pty+      check _ = False+  checkValueInfo "data constructor" check p qc++checkNewConstrImport :: QualIdent -> [Ident] -> NewConstrDecl -> IC ()+checkNewConstrImport tc tvs (NewConstrDecl p c ty) = do+  m <- getModuleIdent+  let qc = qualifyLike tc c+      check (NewtypeConstructor c' _ (ForAllExist uqvs _ (PredType _ ty'))) =+        qc == c' && length tvs == uqvs &&toQualType m tvs ty == head (arrowArgs ty')+      check _ = False+  checkValueInfo "newtype constructor" check p qc+checkNewConstrImport tc tvs (NewRecordDecl p c (l, ty)) = do+  m <- getModuleIdent+  let qc = qualifyLike tc c+      check (NewtypeConstructor c' l' (ForAllExist uqvs _ (PredType _ ty'))) =+        qc == c' && length tvs == uqvs && l == l' &&+        toQualType m tvs ty == head (arrowArgs ty')+      check _ = False+  checkValueInfo "newtype constructor" check p qc++checkMethodImport :: QualIdent -> Ident -> IMethodDecl -> IC ()+checkMethodImport qcls clsvar (IMethodDecl p f _ qty) =+  checkValueInfo "method" check p qf+  where qf = qualifyLike qcls f+        check (Value f' cm' _ (ForAll _ pty)) =+          qf == f' && cm' == True && toMethodType qcls clsvar qty == pty+        check _ = False++checkPrecInfo :: (PrecInfo -> Bool) -> Position -> QualIdent -> IC ()+checkPrecInfo check p op = do+  pEnv <- getPrecEnv+  let checkInfo m op' = case qualLookupTopEnv op pEnv of+        []     -> report $ errNoPrecedence p m op'+        [prec] -> unless (check prec)+                         (report $ errImportConflict p "precedence" m op')+        _      -> internalError "checkPrecInfo"+  checkImported checkInfo op++checkTypeInfo :: String -> (TypeInfo -> Maybe (IC ())) -> Position+              -> QualIdent -> IC ()+checkTypeInfo what check p tc = do+  tcEnv <- 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 :: (PredSet -> [(Ident, Int)] -> Bool) -> Position -> 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 :: String -> (ValueInfo -> Bool) -> Position+               -> QualIdent -> IC ()+checkValueInfo what check p x = do+  tyEnv <- getValueEnv+  let checkInfo m x' = case qualLookupTopEnv x tyEnv of+        []   -> report $ errNotExported p what m x'+        [vi] -> unless (check vi) (report $ errImportConflict p what m x')+        _    -> internalError "checkValueInfo"+  checkImported checkInfo x++checkImported :: (ModuleIdent -> Ident -> IC ()) -> QualIdent -> IC ()+checkImported _ (QualIdent Nothing  _) = ok+checkImported f (QualIdent (Just m) x) = f m x++-- ---------------------------------------------------------------------------+-- Error messages+-- ---------------------------------------------------------------------------++errNotExported :: Position -> String -> ModuleIdent -> Ident -> Message+errNotExported p what m x = posMessage p $+  text "Inconsistent module interfaces"+  $+$ text "Module" <+> text (moduleName m)+  <+> text "does not export"<+> text what <+> text (escName x)++errNoPrecedence :: Position -> ModuleIdent -> Ident -> Message+errNoPrecedence p m x = posMessage p $+  text "Inconsistent module interfaces"+  $+$ text "Module" <+> text (moduleName m)+  <+> text "does not define a precedence for" <+> text (escName x)++errNoInstance :: Position -> ModuleIdent -> InstIdent -> Message+errNoInstance p m i = posMessage p $+  text "Inconsistent module interfaces"+  $+$ text "Module" <+> text (moduleName m)+  <+> text "does not define an instance for" <+> ppInstIdent i++errImportConflict :: Position -> String -> ModuleIdent -> Ident -> Message+errImportConflict p what m x = posMessage p $+  text "Inconsistent module interfaces"+  $+$ text "Declaration of" <+> text what <+> text (escName x)+  <+> text "does not match its definition in module" <+> text (moduleName m)++errInstanceConflict :: Position -> ModuleIdent -> InstIdent -> Message+errInstanceConflict p m i = posMessage p $+  text "Inconsistent module interfaces"+  $+$ text "Declaration of instance" <+> ppInstIdent i+  <+> text "does not match its definition in module" <+> text (moduleName m)

@@ -0,0 +1,356 @@+{- |+    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, posMessage, internalError)+import Base.TopEnv+import Base.Utils    (findMultiples, findDouble)++import Env.TypeConstructor+import Env.Type++import Curry.Base.Ident+import Curry.Base.Position+import Curry.Base.Pretty+import Curry.Syntax+import Curry.Syntax.Pretty++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 cx inst+  checkSimpleContext cx'+  checkInstanceType p 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"++checkExistVars :: [Ident] -> ISC ()+checkExistVars = checkTypeVars "list of existentially quantified type variables"++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 evs cx c tys) = do+  checkExistVars evs+  cx' <- checkClosedContext tvs' cx+  liftM (ConstrDecl p evs cx' c) (mapM (checkClosedType tvs') tys)+  where tvs' = evs ++ tvs+checkConstrDecl tvs (ConOpDecl p evs cx ty1 op ty2) = do+  checkExistVars evs+  cx' <- checkClosedContext tvs' cx+  liftM2 (\t1 t2 -> ConOpDecl p evs cx' t1 op t2)+         (checkClosedType tvs' ty1)+         (checkClosedType tvs' ty2)+  where tvs' = evs ++ tvs+checkConstrDecl tvs (RecordDecl p evs cx c fs) = do+  checkExistVars evs+  cx' <- checkClosedContext tvs' cx+  liftM (RecordDecl p evs cx' c) (mapM (checkFieldDecl tvs') fs)+  where tvs' = evs ++ tvs++checkFieldDecl :: [Ident] -> FieldDecl -> ISC FieldDecl+checkFieldDecl tvs (FieldDecl p ls ty) =+  liftM (FieldDecl p ls) (checkClosedType tvs ty)++checkNewConstrDecl :: [Ident] -> NewConstrDecl -> ISC NewConstrDecl+checkNewConstrDecl tvs (NewConstrDecl p 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 p tv+  let QualTypeExpr cx _ = qty'+  when (tv `elem` fv cx) $ report $ errConstrainedClassVariable p tv+  return $ IMethodDecl p f a qty'++checkInstanceType :: Position -> InstanceType -> ISC ()+checkInstanceType p inst = do+  tEnv <- getTypeEnv+  unless (isSimpleType inst &&+    not (isTypeSyn (typeConstr inst) tEnv) &&+    null (filter isAnonId $ typeVars inst) &&+    isNothing (findDouble $ fv inst)) $+      report $ errIllegalInstanceType p inst++checkQualType :: QualTypeExpr -> ISC QualTypeExpr+checkQualType (QualTypeExpr cx ty) = do+  ty' <- checkType ty+  cx' <- checkClosedContext (fv ty') cx+  return $ QualTypeExpr 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 qcls ty) = do+  checkClass qcls+  Constraint 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 tc) = checkTypeConstructor tc+checkType (ApplyType  ty1 ty2) = liftM2 ApplyType (checkType ty1) (checkType ty2)+checkType (VariableType    tv) = checkType $ ConstructorType (qualify tv)+checkType (TupleType      tys) = liftM TupleType (mapM checkType tys)+checkType (ListType        ty) = liftM ListType (checkType ty)+checkType (ArrowType  ty1 ty2) = liftM2 ArrowType (checkType ty1) (checkType ty2)+checkType (ParenType       ty) = liftM ParenType (checkType ty)+checkType (ForallType   vs ty) = liftM (ForallType 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 :: QualIdent -> ISC TypeExpr+checkTypeConstructor tc = do+  tyEnv <- getTypeEnv+  case qualLookupTypeKind tc tyEnv of+    [] | not (isQualified tc) -> return $ VariableType $ unqualify tc+       | otherwise            -> do+          report $ errUndefinedType tc+          return $ ConstructorType tc+    [Data _ _] -> return $ ConstructorType tc+    [Alias  _] -> do+                  report $ errBadTypeSynonym tc+                  return $ ConstructorType 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 = posMessage 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 = posMessage f $ hsep $ map text+  ["Arity information for method", idName f, "occurs more than once"]++errAmbiguousType :: Position -> Ident -> Message+errAmbiguousType p ident = posMessage p $ hsep $ map text+  [ "Method type does not mention class variable", idName ident ]++errConstrainedClassVariable :: Position -> Ident -> Message+errConstrainedClassVariable p ident = posMessage p $ hsep $ map text+  [ "Method context must not constrain class variable", idName ident ]++errNonLinear :: Ident -> String -> Message+errNonLinear tv what = posMessage tv $ hsep $ map text+  [ "Type variable", escName tv, "occurs more than once in", what ]++errNoVariable :: Ident -> String -> Message+errNoVariable tv what = posMessage tv $ hsep $ map text+  [ "Type constructor or type class identifier", escName tv, "used in", what ]++errUnboundVariable :: Ident -> Message+errUnboundVariable tv = posMessage tv $+  text "Undefined type variable" <+> text (escName tv)++errBadTypeSynonym :: QualIdent -> Message+errBadTypeSynonym tc = posMessage tc $ text "Synonym type"+                    <+> text (qualName tc) <+> text "in interface"++errNoElement :: String -> String -> QualIdent -> Ident -> Message+errNoElement what for tc x = posMessage tc $ hsep $ map text+  [ "Hidden", what, escName x, "is not defined for", for, qualName tc ]++errIllegalSimpleConstraint :: Constraint -> Message+errIllegalSimpleConstraint c@(Constraint qcls _) = posMessage qcls $ vcat+  [ text "Illegal class constraint" <+> ppConstraint 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 :: Position -> InstanceType -> Message+errIllegalInstanceType p inst = posMessage p $ 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."+  ]

@@ -0,0 +1,765 @@+{- |+    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__ < 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.Pretty+import Curry.Syntax+import Curry.Syntax.Pretty++import Base.CurryKinds+import Base.Expr+import Base.Kinds+import Base.KindSubst+import Base.Messages (Message, posMessage, 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+  if null errs then suf else return ()++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     _ _ cx _ tys) = fts m cx . fts m tys+  fts m (ConOpDecl  _ _ cx ty1 _ ty2) = fts m cx . fts m ty1 . fts m ty2+  fts m (RecordDecl      _ _ cx _ fs) = fts m cx . 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 _) = do+  bindTypeConstructor DataType tc tvs (Just KindStar) (map mkData cs) tcEnv+  where+    mkData (ConstrDecl _ evs cx     c  tys) = mkData' evs cx c  tys+    mkData (ConOpDecl  _ evs cx ty1 op ty2) = mkData' evs cx op [ty1, ty2]+    mkData (RecordDecl _ evs cx     c   fs) =+      let (labels, tys) = unzip [(l, ty) | FieldDecl _ ls ty <- fs, l <- ls]+      in  mkRec evs cx c labels tys+    mkData' evs cx c tys = DataConstr c (length evs) ps tys'+      where qtc = qualifyWith m tc+            tvs' = tvs ++ evs+            PredType ps ty = expandConstrType m tcEnv' clsEnv qtc tvs' cx tys+            tys' = arrowArgs ty+    mkRec evs cx c ls tys =+      RecordConstr c (length evs) ps ls tys'+      where qtc = qualifyWith m tc+            tvs' = tvs ++ evs+            PredType ps ty = expandConstrType m tcEnv' clsEnv qtc tvs' cx tys+            tys' = arrowArgs ty+bindKind _ _     _       tcEnv (ExternalDataDecl _ tc tvs) = do+  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 0 emptyPredSet [ty']+      where ty'  = expandMonoType m tcEnv' tvs ty+    mkData (NewRecordDecl _ c (l, ty)) = RecordConstr c 0 emptyPredSet [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 p tc tvs ty) = do+  (k, tcEnv') <- bindTypeVars tc tvs tcEnv+  kcType tcEnv' p "type declaration" (ppDecl t) k ty+kcDecl tcEnv (TypeSig p _ qty) = kcTypeSig tcEnv p 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 p tys) = do+  tcEnv' <- foldM bindFreshKind tcEnv $ nub $ fv tys+  mapM_ (kcValueType tcEnv' p "default declaration" empty) tys+kcDecl tcEnv (ClassDecl p cx cls tv ds) = do+  m <- getModuleIdent+  let tcEnv' = bindTypeVar tv (clsKind m (qualifyWith m cls) tcEnv) tcEnv+  kcContext tcEnv' p cx+  mapM_ (kcDecl tcEnv') ds+kcDecl tcEnv (InstanceDecl p cx qcls inst ds) = do+  m <- getModuleIdent+  tcEnv' <- foldM bindFreshKind tcEnv $ fv inst+  kcContext tcEnv' p cx+  kcType tcEnv' p what doc (clsKind m qcls tcEnv) inst+  mapM_ (kcDecl tcEnv') ds+    where+      what = "instance declaration"+      doc = ppDecl (InstanceDecl p cx qcls inst [])++kcConstrDecl :: TCEnv -> ConstrDecl -> KCM ()+kcConstrDecl tcEnv d@(ConstrDecl p evs cx _ tys) = do+  tcEnv' <- foldM bindFreshKind tcEnv evs+  kcContext tcEnv' p cx+  mapM_ (kcValueType tcEnv' p what doc) tys+    where+      what = "data constructor declaration"+      doc = ppConstr d+kcConstrDecl tcEnv d@(ConOpDecl p evs cx ty1 _ ty2) = do+  tcEnv' <- foldM bindFreshKind tcEnv evs+  kcContext tcEnv' p cx+  kcValueType tcEnv' p what doc ty1+  kcValueType tcEnv' p what doc ty2+    where+      what = "data constructor declaration"+      doc = ppConstr d+kcConstrDecl tcEnv (RecordDecl p evs cx _ fs) = do+  tcEnv' <- foldM bindFreshKind tcEnv evs+  kcContext tcEnv' p cx+  mapM_ (kcFieldDecl tcEnv') fs++kcFieldDecl :: TCEnv -> FieldDecl -> KCM ()+kcFieldDecl tcEnv d@(FieldDecl p _ ty) =+  kcValueType tcEnv p "field declaration" (ppFieldDecl d) ty++kcNewConstrDecl :: TCEnv -> NewConstrDecl -> KCM ()+kcNewConstrDecl tcEnv d@(NewConstrDecl p _ ty) =+  kcValueType tcEnv p "newtype constructor declaration" (ppNewConstr 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 p e ds) = do+  kcExpr tcEnv p 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 p g e) = kcExpr tcEnv p g >> kcExpr tcEnv p e++kcExpr :: TCEnv -> Position -> Expression a -> KCM ()+kcExpr _     _ (Literal _ _) = ok+kcExpr _     _ (Variable _ _) = ok+kcExpr _     _ (Constructor _ _) = ok+kcExpr tcEnv p (Paren e) = kcExpr tcEnv p e+kcExpr tcEnv p (Typed e qty) = do+  kcExpr tcEnv p e+  kcTypeSig tcEnv p qty+kcExpr tcEnv p (Record _ _ fs) = mapM_ (kcField tcEnv p) fs+kcExpr tcEnv p (RecordUpdate e fs) = do+  kcExpr tcEnv p e+  mapM_ (kcField tcEnv p) fs+kcExpr tcEnv p (Tuple es) = mapM_ (kcExpr tcEnv p) es+kcExpr tcEnv p (List _ es) = mapM_ (kcExpr tcEnv p) es+kcExpr tcEnv p (ListCompr e stms) = do+  kcExpr tcEnv p e+  mapM_ (kcStmt tcEnv p) stms+kcExpr tcEnv p (EnumFrom e) = kcExpr tcEnv p e+kcExpr tcEnv p (EnumFromThen e1 e2) = do+  kcExpr tcEnv p e1+  kcExpr tcEnv p e2+kcExpr tcEnv p (EnumFromTo e1 e2) = do+  kcExpr tcEnv p e1+  kcExpr tcEnv p e2+kcExpr tcEnv p (EnumFromThenTo e1 e2 e3) = do+  kcExpr tcEnv p e1+  kcExpr tcEnv p e2+  kcExpr tcEnv p e3+kcExpr tcEnv p (UnaryMinus e) = kcExpr tcEnv p e+kcExpr tcEnv p (Apply e1 e2) = do+  kcExpr tcEnv p e1+  kcExpr tcEnv p e2+kcExpr tcEnv p (InfixApply e1 _ e2) = do+  kcExpr tcEnv p e1+  kcExpr tcEnv p e2+kcExpr tcEnv p (LeftSection e _) = kcExpr tcEnv p e+kcExpr tcEnv p (RightSection _ e) = kcExpr tcEnv p e+kcExpr tcEnv p (Lambda _ e) = kcExpr tcEnv p e+kcExpr tcEnv p (Let ds e) = do+  mapM_ (kcDecl tcEnv) ds+  kcExpr tcEnv p e+kcExpr tcEnv p (Do stms e) = do+  mapM_ (kcStmt tcEnv p) stms+  kcExpr tcEnv p e+kcExpr tcEnv p (IfThenElse e1 e2 e3) = do+  kcExpr tcEnv p e1+  kcExpr tcEnv p e2+  kcExpr tcEnv p e3+kcExpr tcEnv p (Case _ e alts) = do+  kcExpr tcEnv p e+  mapM_ (kcAlt tcEnv) alts++kcStmt :: TCEnv -> Position -> Statement a -> KCM ()+kcStmt tcEnv p (StmtExpr e) = kcExpr tcEnv p e+kcStmt tcEnv _ (StmtDecl ds) = mapM_ (kcDecl tcEnv) ds+kcStmt tcEnv p (StmtBind _ e) = kcExpr tcEnv p e++kcAlt :: TCEnv -> Alt a -> KCM ()+kcAlt tcEnv (Alt _ _ rhs) = kcRhs tcEnv rhs++kcField :: TCEnv -> Position -> Field (Expression a) -> KCM ()+kcField tcEnv p (Field _ _ e) = kcExpr tcEnv p e++kcContext :: TCEnv -> Position -> Context -> KCM ()+kcContext tcEnv p = mapM_ (kcConstraint tcEnv p)++kcConstraint :: TCEnv -> Position -> Constraint -> KCM ()+kcConstraint tcEnv p sc@(Constraint qcls ty) = do+  m <- getModuleIdent+  kcType tcEnv p "class constraint" doc (clsKind m qcls tcEnv) ty+  where+    doc = ppConstraint sc++kcTypeSig :: TCEnv -> Position -> QualTypeExpr -> KCM ()+kcTypeSig tcEnv p (QualTypeExpr cx ty) = do+  tcEnv' <- foldM bindFreshKind tcEnv free+  kcContext tcEnv' p cx+  kcValueType tcEnv' p "type signature" doc ty+  where+    free = filter (null . flip lookupTypeInfo tcEnv) $ nub $ fv ty+    doc = ppTypeExpr 0 ty++kcValueType :: TCEnv -> Position -> String -> Doc -> TypeExpr -> KCM ()+kcValueType tcEnv p what doc = kcType tcEnv p what doc KindStar++kcType :: TCEnv -> Position -> String -> Doc -> Kind -> TypeExpr -> KCM ()+kcType tcEnv p what doc k ty = do+  k' <- kcTypeExpr tcEnv p "type expression" doc' 0 ty+  unify p what (doc $-$ text "Type:" <+> doc') k k'+  where+    doc' = ppTypeExpr 0 ty++kcTypeExpr :: TCEnv -> Position -> String -> Doc -> Int -> TypeExpr -> KCM Kind+kcTypeExpr tcEnv p _ _ n (ConstructorType 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 p what doc n (ApplyType ty1 ty2) = do+  (alpha, beta) <- kcTypeExpr tcEnv p what doc (n + 1) ty1 >>=+    kcArrow p what (doc $-$ text "Type:" <+> ppTypeExpr 0 ty1)+  kcTypeExpr tcEnv p what doc 0 ty2 >>=+    unify p what (doc $-$ text "Type:" <+> ppTypeExpr 0 ty2) alpha+  return beta+kcTypeExpr tcEnv _ _ _ _ (VariableType tv) = return (varKind tv tcEnv)+kcTypeExpr tcEnv p what doc _ (TupleType tys) = do+  mapM_ (kcValueType tcEnv p what doc) tys+  return KindStar+kcTypeExpr tcEnv p what doc _ (ListType ty) = do+  kcValueType tcEnv p what doc ty+  return KindStar+kcTypeExpr tcEnv p what doc _ (ArrowType ty1 ty2) = do+  kcValueType tcEnv p what doc ty1+  kcValueType tcEnv p what doc ty2+  return KindStar+kcTypeExpr tcEnv p what doc n (ParenType ty) = kcTypeExpr tcEnv p what doc n ty+kcTypeExpr tcEnv p what doc n (ForallType vs ty) = do+  tcEnv' <- foldM bindFreshKind tcEnv $ vs+  kcTypeExpr tcEnv' p what doc n ty++kcArrow :: Position -> 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 :: Position -> 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]     = posMessage tc $ hsep $ map text+  ["Recursive synonym or renaming type", idName tc]+errRecursiveTypes (tc:tcs) = posMessage 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 $ idPosition tc')++errRecursiveClasses :: [Ident] -> Message+errRecursiveClasses []         = internalError+  "KindCheck.errRecursiveClasses: empty list"+errRecursiveClasses [cls]      = posMessage cls $ hsep $ map text+  ["Recursive type class", idName cls]+errRecursiveClasses (cls:clss) = posMessage 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 $ idPosition cls')++errNonArrowKind :: Position -> String -> Doc -> Kind -> Message+errNonArrowKind p what doc k = posMessage p $ vcat+  [ text "Kind error in" <+> text what, doc+  , text "Kind:" <+> ppKind k+  , text "Cannot be applied"+  ]++errPartialAlias :: Position -> QualIdent -> Int -> Int -> Message+errPartialAlias p tc arity argc = posMessage 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 :: Position -> String -> Doc -> Kind -> Kind -> Message+errKindMismatch p what doc k1 k2 = posMessage p $ vcat+  [ text "Kind error in"  <+> text what, doc+  , text "Inferred kind:" <+> ppKind k2+  , text "Expected kind:" <+> ppKind k1+  ]