curry-frontend 1.0.4 → 2.0.0
raw patch · 100 files changed
+16604/−3494 lines, 100 filesdep +binarydep +parsecdep +timedep −curry-basedep −networkdep ~basedep ~bytestringdep ~containers
Dependencies added: binary, parsec, time
Dependencies removed: curry-base, network
Dependency ranges changed: base, bytestring, containers, directory, extra, file-embed, filepath, mtl, network-uri, pretty, process, set-extra, template-haskell, transformers
Files
- CHANGELOG.md +11/−0
- LIESMICH +0/−172
- README.md +65/−0
- app/cymake.hs +57/−0
- curry-frontend.cabal +108/−75
- data/currysource.css +64/−20
- src/Base/AnnotExpr.hs +13/−13
- src/Base/CurryKinds.hs +2/−2
- src/Base/CurryTypes.hs +4/−4
- src/Base/Expr.hs +23/−23
- src/Base/Kinds.hs +7/−0
- src/Base/Messages.hs +4/−4
- src/Base/PrettyTypes.hs +3/−4
- src/Base/Types.hs +7/−2
- src/Base/Typing.hs +5/−5
- src/Checks.hs +11/−12
- src/Checks/DeriveCheck.hs +29/−16
- src/Checks/ExportCheck.hs +21/−15
- src/Checks/ExtensionCheck.hs +5/−5
- src/Checks/ImportSyntaxCheck.hs +5/−5
- src/Checks/InstanceCheck.hs +101/−51
- src/Checks/InterfaceCheck.hs +55/−52
- src/Checks/InterfaceSyntaxCheck.hs +23/−25
- src/Checks/KindCheck.hs +160/−160
- src/Checks/PrecCheck.hs +29/−26
- src/Checks/SyntaxCheck.hs +166/−146
- src/Checks/TypeCheck.hs +402/−302
- src/Checks/TypeSyntaxCheck.hs +98/−284
- src/Checks/WarnCheck.hs +292/−134
- src/CompilerOpts.hs +98/−53
- src/Curry/AbstractCurry.hs +30/−0
- src/Curry/AbstractCurry/Files.hs +61/−0
- src/Curry/AbstractCurry/Type.hs +329/−0
- src/Curry/Base/Ident.hs +1036/−0
- src/Curry/Base/LLParseComb.hs +380/−0
- src/Curry/Base/LexComb.hs +179/−0
- src/Curry/Base/Message.hs +114/−0
- src/Curry/Base/Monad.hs +95/−0
- src/Curry/Base/Position.hs +128/−0
- src/Curry/Base/Pretty.hs +209/−0
- src/Curry/Base/Span.hs +180/−0
- src/Curry/Base/SpanInfo.hs +139/−0
- src/Curry/CondCompile/Parser.hs +90/−0
- src/Curry/CondCompile/Transform.hs +116/−0
- src/Curry/CondCompile/Type.hs +88/−0
- src/Curry/Files/Filenames.hs +256/−0
- src/Curry/Files/PathUtils.hs +206/−0
- src/Curry/Files/Unlit.hs +124/−0
- src/Curry/FlatCurry.hs +19/−0
- src/Curry/FlatCurry/Annotated/Goodies.hs +685/−0
- src/Curry/FlatCurry/Annotated/Type.hs +132/−0
- src/Curry/FlatCurry/Files.hs +68/−0
- src/Curry/FlatCurry/Goodies.hs +1037/−0
- src/Curry/FlatCurry/InterfaceEquivalence.hs +58/−0
- src/Curry/FlatCurry/Pretty.hs +217/−0
- src/Curry/FlatCurry/Type.hs +521/−0
- src/Curry/FlatCurry/Typeable.hs +22/−0
- src/Curry/FlatCurry/Typed/Goodies.hs +666/−0
- src/Curry/FlatCurry/Typed/Type.hs +146/−0
- src/Curry/Syntax.hs +81/−0
- src/Curry/Syntax/Extension.hs +120/−0
- src/Curry/Syntax/InterfaceEquivalence.hs +209/−0
- src/Curry/Syntax/Lexer.hs +889/−0
- src/Curry/Syntax/Parser.hs +1428/−0
- src/Curry/Syntax/Pretty.hs +463/−0
- src/Curry/Syntax/ShowModule.hs +777/−0
- src/Curry/Syntax/Type.hs +1540/−0
- src/Curry/Syntax/Utils.hs +325/−0
- src/CurryBuilder.hs +13/−14
- src/CurryDeps.hs +3/−3
- src/Env/Class.hs +7/−8
- src/Env/Instance.hs +9/−5
- src/Env/Value.hs +13/−13
- src/Exports.hs +4/−3
- src/Generators.hs +15/−16
- src/Generators/GenAbstractCurry.hs +17/−20
- src/Generators/GenAnnotatedFlatCurry.hs +488/−0
- src/Generators/GenFlatCurry.hs +21/−21
- src/Generators/GenTypeAnnotatedFlatCurry.hs +0/−517
- src/Generators/GenTypedFlatCurry.hs +30/−489
- src/Html/CurryHtml.hs +3/−3
- src/Html/SyntaxColoring.hs +23/−23
- src/IL/Pretty.hs +16/−10
- src/IL/ShowModule.hs +15/−1
- src/IL/Type.hs +22/−7
- src/Imports.hs +17/−8
- src/Interfaces.hs +17/−18
- src/Modules.hs +70/−63
- src/Transformations.hs +19/−16
- src/Transformations/CaseCompletion.hs +47/−21
- src/Transformations/CurryToIL.hs +226/−68
- src/Transformations/Derive.hs +94/−23
- src/Transformations/Desugar.hs +111/−41
- src/Transformations/Dictionary.hs +64/−245
- src/Transformations/Lift.hs +22/−21
- src/Transformations/Newtypes.hs +9/−7
- src/Transformations/Qual.hs +25/−25
- src/Transformations/Simplify.hs +26/−26
- src/cymake.hs +0/−57
- test/TestFrontend.hs +127/−92
CHANGELOG.md view
@@ -1,6 +1,16 @@ Change log for curry-frontend ============================= +Version 2.0.0+=============++ * Implemented the "MonadFail-Proposal" for curry+ (see <https://wiki.haskell.org/MonadFail_Proposal>)+ * Data class (see <https://arxiv.org/abs/1908.10607>)+ * Fixed bug with partially imported Typeclasses+ * Fixed bug with parsing of empty blocks+ * Fixed bug with re-export of record labels+ Version 1.0.4 ============= @@ -314,3 +324,4 @@ * All compiler warnings removed. * Fixed various implementation bugs (#9, #16, #19, #29, #289).+
− LIESMICH
@@ -1,172 +0,0 @@-===============================================================================-==-== Münster-Curry-Compiler-== Distribution zur Anwendung als Frontend in PAKCS-==-== Letztes Update: 27.10.05--Diese Distribution enthält die modifizierte Version des -Münster-Curry-Compilers (MCC) für die Verwendung als Frontend in PAKCS. Dieses -System ist u.a. in der Lage aus Curry-Programmen (entwickelt nach -PAKCS-Standard) Flat-Darstellungen (FlatCurry ".fcy", FlatInterface ".fint" -und FlatXML "_flat.xml"), sowie Abstract-Darstellungen (AbstractCurry ".acy" -und untyped AbstractCurry ".uacy") zu generieren.----1. Installation------------------1.1 Installation der Binary-Distribution--Die Binary-Distribution befindet sich in einem tar-Archiv und wird-durch folgendes Kommando entpackt:-- tar zxvf <Distribution>.tar.gz--Danach steht der Compiler im Verzeichnis 'mcc' zur Verfügung.---1.2 Installation der Source-Distribution--Nach dem Entpacken des tar-Archivs mittels-- tar zxvf <Distribution>.tar.gz--kann der Compiler durch Aufruf von 'make' im Verzeichnis 'mcc' installiert-werden. Bei Recompilierung (z.B. nach Änderungen in der Quelldateien)-wird empfohlen vor einer erneuten Installation 'make clean' auszuführen.----Nach erfolgreicher Installation befindet sich in beiden Fällen im Verzeichnis -'mcc/bin/' folgende ausführbare Datei:-- cymake - der Curry-Programm-Builder--Dieses Tool übersetzt Curry-Programme unter Berücksichtigung der Import--abhängigkeiten.----2. Kommandoübersicht-----------------------In der folgenden Tabelle sind die Optionen zur Generierung der jeweiligen-Darstellungen für das Kommando 'cymake' aufgelistet:-- --flat : Erzeugt FlatCurry- und FlatInterface-Datei- --xml : Erzeugt FlatXML-Datei- --acy : Erzeugt (typinferierte) AbstractCurry-Datei- --uacy : Erzeugt ungetypte AbstractCurry-Datei----3. Erzeugung von FlatCurry- und FlatXML-Programmen-----------------------------------------------------Die Übersetzung eines Curry-Programms 'file.curry', sowie sämtlicher-importierter Module nach FlatCurry bzw. FlatInterface, bewirkt folgendes-Kommando:-- cymake --flat <filename>--Hierdurch werden die Dateien mit den entsprechenden Endungen ".fcy" und-".fint" generiert. Der Dateiname <filename> kann hierbei mit oder ohne -Endung ".curry" bzw. ".lcurry" angegeben werden.--Die analogen Übersetzungen in die FlatXML-Darstellung bewirkt folgendes-Kommando:-- cymake --xml <file name>--Die hierdurch generierte Flat-XML-Datei hat die Endung '_flat.xml'.----4. Erzeugung von AbstractCurry-Programmen--------------------------------------------Die Übersetzung eines Curry-Programms 'file.curry' nach (typgeprüftem)-AbstractCurry bewirkt folgendes Kommando:-- cymake --acy <filename>--Hierdurch wird die entsprechende Datei (mit der Endung ".acy") generiert.-Der Dateiname <filename> kann hierbei mit oder ohne Endung ".curry" bzw.-".lcurry" angegeben werden.--Ungetypte, bzw. typsignierte AbstractCurry-Programme werden mit folgendem-Kommando generiert:-- cymake --uacy <filename>--Die hierdurch generierte Datei besitzt die Endung ".uacy".--Die Generierung des ungetypten AbstractCurry-Programms findet ohne-Typüberprüfung statt (d.h. auch Programme mit Typfehlern werden übersetzt).-Alle Funktionen besitzen entweder die im Quellprogramm angegebenen Typsignatur,-oder, sofern diese nicht vorhanden ist, den Dummy-Typ "prelude.untyped".--In beiden Fällen werden für die Übersetzung FlatCurry-Dateien -für alle importierten Module erzeugt. Dies ist notwendig, da die -entsprechenden Interfaces für die Typinferenz (nur im Fall der getypten -AbstractCurry-Generierung) und die statisch-semantische Analyse benötigt -werden.----5. Anmerkungen------------------ Um die PAKCS-Bibliotheken (insbesondere die Prelude) für Übersetzungen - nutzen zu können muß die Umgebungsvariable 'PAKCS_LIB' auf die- entsprechenden Pfade verweisen, z.B. mittels-- export PAKCS_LIB=<pakcs path>/pacs/lib:<pakcs path>/pacs/lib/meta:...-- wobei <pakcs path> das Verzeichnis ist, das die PAKCS-Distribution- enthält.--- Im Gegensatz zu PAKCS erlaubt das Frontend die Verwendung anonymer- Variablen (dargestellt durch dem Unterstrich '_') in Typdeklarationen,- z.B.-- data T _ = C----Bekannte Probleme---------------------- Lambda-, do-, if-, case-, oder let-Ausdrücke, die in Argumenten von- Funktionsaufrufen verwendet werden, müssen immer geklammert werden.--- 'let'-Anweisungen dürfen nicht folgendes Layout besitzen:-- let x = <expr>- in ...--- Die Regeln einer Funktionsdeklaration müssen immer zusammenstehen, d.h.- nicht durch andere Deklarationen unterbrochen werden.--- Es ist bislang nicht möglich, den Konstruktor für leere Listen [], sowie - den Unit-Konstruktor () zu qualifizieren (z.B. führt 'prelude.[]' zu - einem Fehler). Der Listenkonstruktor (:), sowie Tupel-Konstruktoren- dagegen sind qualifizierbar.--- FlatXML-Übersetzungen können derzeit mittels der Funktionen aus dem- PAKCS-Modul "FlatXML" noch nicht eingelesen werden, da es Unstimmigkeiten- zwischen dem generierten und den erforderlichen Formaten gibt.--- Bei der Erzeugung von typgeprüftem AbstractCurry können die im Quelltext- verwendeten Bezeichner für Typvariablen nicht ins AbstractCurry-Programm- übernommen werden. Stattdessen generiert der Übersetzer neue- Bezeichner.--- Bei der Erzeugung von ungetyptem AbstractCurry werden Typsynonyme in- Typsignaturen von Funktionen nicht dereferenziert.--- Das Frontend gibt derzeit noch keinerlei Warnungen aus.--
+ README.md view
@@ -0,0 +1,65 @@+# Curry Frontend++The frontend lexes, parses, type-checks and transforms Curry source files into a variety of intermediate formats, including++* **FlatCurry** for program analyzers and backends+* **AbstractCurry** for program manipulation tools+* **HTML** for documentation++It is used by the two major Curry compilers, [PAKCS](https://git.ps.informatik.uni-kiel.de/curry/pakcs) and+[KiCS2](https://git.ps.informatik.uni-kiel.de/curry/kics2).++## Requirements++* Make sure that a recent version of Haskell Stack is installed on your computer++## Building++* To build the project, run `make`.+* To test the project, run `make runtests`.++The built executable will be located at `bin/curry-frontend`.++## Usage++For a detailed overview of the available options, you can use the following command:++`curry-frontend --help`++### Available Formats++```+--flat : Generate a FlatCurry (.fcy) and FlatInterface (.fint) file+--xml : Generate a FlatXML (_flat.xml) file+--acy : Generate a (type-inferred) AbstractCurry (.acy) file+--uacy : Generate an untyped AbstractCurry (.uacy) file+```++The generation of an untyped AbstractCurry program is performed without+type checking (i.e. programs with type checks will compile). All functions+will either have the type signature specified in the source or, if not+available, the dummy type `prelude.untyped`.++FlatCurry files will always be generated for the imported modules,+since the interfaces are required for static-semantic analysis and type+inference (only for typed AbstractCurry).++## Remarks++- To use the PAKCS libraries (especially for the `Prelude`), the environment+ variable `PAKCS_LIB` has to point to the correct paths, e.g. using+ + `export PAKCS_LIB=[pakcs path]/pacs/lib:[pakcs path]/pacs/lib/meta:...`++ where `[pakcs path]` is the directory containing the PAKCS distribution.++- In contrast to PAKCS, the frontend allow use of anonymous variables+ (denoted by an underscore `_`) in type declarations, e.g.+ + ```curry+ data T _ = c+ ```++## Known Issues++[See GitLab](https://git.ps.informatik.uni-kiel.de/curry/curry-frontend/-/issues)
+ app/cymake.hs view
@@ -0,0 +1,57 @@+{- |+ Module : $Header$+ Description : Main module+ Copyright : (c) 2005 Martin Engelke+ 2011 - 2016 Björn Peemöller+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ Command line tool for generating Curry representations (e.g. FlatCurry,+ AbstractCurry) for a Curry source file including all imported modules.+-}+module Main (main) where++import Curry.Base.Monad (runCYIO)++import Base.Messages+import Files.CymakePath (cymakeGreeting, cymakeVersion)++import CurryBuilder (buildCurry)+import CompilerOpts (Options (..), CymakeMode (..), getCompilerOpts, usage)++-- |The command line tool cymake+main :: IO ()+main = getCompilerOpts >>= cymake++-- |Invoke the curry builder w.r.t the command line arguments+cymake :: (String, Options, [String], [String]) -> IO ()+cymake (prog, opts, files, errs) = case optMode opts of+ ModeHelp -> printUsage prog+ ModeVersion -> printVersion+ ModeNumericVersion -> printNumericVersion+ ModeMake | not (null errs) -> badUsage prog errs+ | null files -> badUsage prog ["No input files"]+ | otherwise -> runCYIO (mapM_ (buildCurry opts) files) >>=+ either abortWithMessages continueWithMessages+ where continueWithMessages = warnOrAbort (optWarnOpts opts) . snd++-- |Print the usage information of the command line tool+printUsage :: String -> IO ()+printUsage prog = putStrLn $ usage prog++-- |Print the program version+printVersion :: IO ()+printVersion = putStrLn cymakeGreeting++-- |Print the numeric program version+printNumericVersion :: IO ()+printNumericVersion = putStrLn cymakeVersion++-- |Print errors and abort execution on bad parameters+badUsage :: String -> [String] -> IO ()+badUsage prog errs = do+ putErrsLn $ map (\ err -> prog ++ ": " ++ err) errs+ abortWith ["Try '" ++ prog ++ " --help' for more information"]
curry-frontend.cabal view
@@ -1,9 +1,9 @@-Name: curry-frontend-Version: 1.0.4-Cabal-Version: >= 1.10-Synopsis: Compile the functional logic language Curry to several+name: curry-frontend+version: 2.0.0+cabal-version: 2.0+synopsis: Compile the functional logic language Curry to several intermediate formats-Description: The Curry front end consists of the executable program+description: The Curry front end consists of the executable program "curry-frontend". It is used by various backends to compile Curry programs to an intermediate representation.@@ -14,52 +14,49 @@ representations. For further information, please check <http://curry-language.org>-Category: Language-License: BSD3-License-File: LICENSE-Author: Wolfgang Lux, Martin Engelke, Bernd Brassel, Holger Siegel,+category: Language+license: BSD3+license-file: LICENSE+author: Wolfgang Lux, Martin Engelke, Bernd Brassel, Holger Siegel, Bjoern Peemoeller, Finn Teegen-Maintainer: fte@informatik.uni-kiel.de-Homepage: http://curry-language.org-Build-Type: Simple-Stability: experimental+maintainer: fte@informatik.uni-kiel.de+homepage: http://curry-language.org+build-type: Simple+stability: experimental -Extra-Source-Files: LIESMICH CHANGELOG.md+extra-source-files: README.md CHANGELOG.md -Data-Dir: data-Data-Files: currysource.css+data-dir: data+data-files: currysource.css source-repository head type: git location: https://git.ps.informatik.uni-kiel.de/curry/curry-frontend.git -Flag network-uri- description: Get Network.URI from the network-uri package- default: True--Library+library hs-source-dirs: src- default-language: Haskell2010- Build-Depends:- base == 4.*- , containers- , curry-base == 1.1.1- , directory- , template-haskell >= 2.10 && < 3- , bytestring >= 0.10 && < 0.11- , extra >= 1.4.6- , filepath- , mtl- , pretty- , process- , file-embed- , set-extra- , transformers- if flag(network-uri)- build-depends: network-uri >= 2.6- else- build-depends: network < 2.6- Exposed-Modules:+ default-language: Haskell2010+ other-extensions: CPP, TemplateHaskell+ ghc-options: -Wall+ build-depends:+ base >= 4.11 && < 4.15+ , template-haskell >= 2.10 && < 2.16+ , extra >= 1.4.6 && < 1.8+ , transformers >= 0.5 && < 0.6+ , mtl >= 2.2 && < 2.3+ , directory >= 1.2 && < 1.4+ , filepath >= 1.4 && < 1.5+ , file-embed >= 0.0 && < 0.1+ , containers >= 0.6 && < 0.7+ , set-extra >= 1.4 && < 1.5+ , bytestring >= 0.10 && < 0.11+ , process >= 1.6 && < 1.7+ , network-uri >= 2.6 && < 2.7+ , pretty >= 1.1 && < 1.2+ , binary >= 0.8 && < 0.9+ , time >= 1.9 && < 2.0+ , parsec >= 3.1 && < 3.2+ exposed-modules: Base.AnnotExpr , Base.CurryKinds , Base.CurryTypes@@ -92,6 +89,44 @@ , Checks.TypeCheck , Checks.TypeSyntaxCheck , Checks.WarnCheck+ , Curry.AbstractCurry+ , Curry.AbstractCurry.Files+ , Curry.AbstractCurry.Type+ , Curry.Base.Ident+ , Curry.Base.LexComb+ , Curry.Base.LLParseComb+ , Curry.Base.Message+ , Curry.Base.Monad+ , Curry.Base.Position+ , Curry.Base.Pretty+ , Curry.Base.Span+ , Curry.Base.SpanInfo+ , Curry.CondCompile.Parser+ , Curry.CondCompile.Transform+ , Curry.CondCompile.Type+ , Curry.Files.Filenames+ , Curry.Files.PathUtils+ , Curry.Files.Unlit+ , Curry.FlatCurry+ , Curry.FlatCurry.Files+ , Curry.FlatCurry.Goodies+ , Curry.FlatCurry.InterfaceEquivalence+ , Curry.FlatCurry.Pretty+ , Curry.FlatCurry.Type+ , Curry.FlatCurry.Typeable+ , Curry.FlatCurry.Annotated.Goodies+ , Curry.FlatCurry.Annotated.Type+ , Curry.FlatCurry.Typed.Goodies+ , Curry.FlatCurry.Typed.Type+ , Curry.Syntax+ , Curry.Syntax.Extension+ , Curry.Syntax.InterfaceEquivalence+ , Curry.Syntax.Lexer+ , Curry.Syntax.Parser+ , Curry.Syntax.Pretty+ , Curry.Syntax.ShowModule+ , Curry.Syntax.Type+ , Curry.Syntax.Utils , CompilerEnv , CompilerOpts , CondCompile@@ -111,7 +146,7 @@ , Generators.GenAbstractCurry , Generators.GenFlatCurry , Generators.GenTypedFlatCurry- , Generators.GenTypeAnnotatedFlatCurry+ , Generators.GenAnnotatedFlatCurry , Html.CurryHtml , Html.SyntaxColoring , IL@@ -133,42 +168,40 @@ , Transformations.Newtypes , Transformations.Qual , Transformations.Simplify- other-modules:- Paths_curry_frontend+ , Paths_curry_frontend autogen-modules:- Paths_curry_frontend- ghc-options: -Wall+ Paths_curry_frontend -Executable curry-frontend- hs-source-dirs: src- Main-is: cymake.hs- default-language: Haskell2010- Build-Depends:- base == 4.*- , containers- , curry-base == 1.1.1+executable curry-frontend+ hs-source-dirs: app+ main-is: cymake.hs+ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base >= 4.11 , curry-frontend- , directory- , template-haskell >= 2.10 && < 3- , bytestring >= 0.10 && < 0.11++test-suite test-frontend+ type: detailed-0.9+ hs-source-dirs: test+ test-module: TestFrontend+ default-language: Haskell2010+ other-extensions: CPP, TemplateHaskell+ ghc-options: -Wall+ build-depends:+ base >= 4.11+ , Cabal >= 1.20+ , template-haskell >= 2.10 , extra >= 1.4.6- , filepath+ , transformers , mtl- , pretty- , process+ , directory >= 1.2.0.1+ , filepath , file-embed+ , containers , set-extra- , transformers- if flag(network-uri)- build-depends: network-uri >= 2.6- else- build-depends: network < 2.6- ghc-options: -Wall--Test-Suite test-frontend- type: detailed-0.9- hs-source-dirs: test- default-language: Haskell2010- test-module: TestFrontend- build-depends: base == 4.*, Cabal >= 1.20, curry-base == 1.1.1- , curry-frontend, filepath+ , bytestring >= 0.10+ , process+ , network-uri >= 2.6+ , pretty+ , curry-frontend
data/currysource.css view
@@ -1,7 +1,23 @@-/* Use always white background. */+:root {+ --link-bg-color: lightyellow;+ --line-number-color: grey;+ --pragma-color: green;+ --comment-color: green;+ --keyword-color: blue;+ --symbol-color: red;+ --type-color: orange;+ --cons-color: magenta;+ --label-color: darkgreen;+ --func-color: purple;+ --ident-color: black;+ --module-color: brown;+ --number-color: teal;+ --string-color: maroon;+ --char-color: maroon;+ color-scheme: light dark;+}+ body {- background: white;- color: black; font-family: monospace; text-size-adjust: none; -moz-text-size-adjust: none;@@ -13,18 +29,18 @@ border-collapse: collapse; } -/* Show hyperlinks without text decoration, but in light yellow. */+/* Hyperlinks */ a:link, a:visited, a:active {- background: lightyellow;+ background: var(--link-bg-color); text-decoration: none; } /* Line numbers */ .line-numbers {- border-right: 1px solid grey;- color: grey;+ border-right: 1px solid var(--line-number-color);+ color: var(--line-number-color); min-width: 5ch; padding-right: 1em; text-align: right;@@ -36,16 +52,44 @@ } /* 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 }+.pragma { color: var(--pragma-color) }+.comment { color: var(--comment-color) }+.keyword { color: var(--keyword-color) }+.symbol { color: var(--symbol-color) }+.type { color: var(--type-color) }+.cons { color: var(--cons-color) }+.label { color: var(--label-color) }+.func { color: var(--func-color) }+.ident { color: var(--ident-color) }+.module { color: var(--module-color) }+.number { color: var(--number-color) }+.string { color: var(--string-color) }+.char { color: var(--char-color) }++@supports not (color-scheme: light dark) {+ @media (prefers-color-scheme: dark) {+ html {+ background: hsl(0, 0%, 12%);+ color: white;+ }+ }+}++@media (prefers-color-scheme: dark) {+ :root {+ --link-bg-color: hsl(0, 0%, 17%);+ --pragma-color: hsl(0, 0%, 60%);+ --comment-color: hsl(0, 0%, 60%);+ --keyword-color: hsl(300, 66%, 70%);+ --symbol-color: hsl(0, 66%, 70%);+ --type-color: hsl(60, 66%, 70%);+ --cons-color: hsl(330, 66%, 70%);+ --label-color: hsl(240, 66%, 70%);+ --func-color: hsl(200, 66%, 70%);+ --ident-color: hsl(0, 0%, 85%);+ --module-color: hsl(20, 66%, 70%);+ --number-color: hsl(180, 66%, 70%);+ --string-color: hsl(120, 66%, 70%);+ --char-color: hsl(120, 66%, 70%);+ }+}
src/Base/AnnotExpr.hs view
@@ -33,11 +33,11 @@ -- 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 _ _ = []+ 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@@ -46,8 +46,8 @@ 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) =+ 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@@ -75,11 +75,11 @@ 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) =+ 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 (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+ 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@@ -88,9 +88,9 @@ 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+ 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
src/Base/CurryKinds.hs view
@@ -20,7 +20,7 @@ ) where import Curry.Base.Pretty (Doc)-import Curry.Syntax.Pretty (ppKindExpr)+import Curry.Syntax.Pretty (pPrintPrec) import Curry.Syntax.Type (KindExpr (..)) import Base.Kinds@@ -42,4 +42,4 @@ | otherwise = Just (fromKind k) ppKind :: Kind -> Doc-ppKind = ppKindExpr 0 . fromKind+ppKind = pPrintPrec 0 . fromKind
src/Base/CurryTypes.hs view
@@ -41,7 +41,7 @@ import Curry.Base.Pretty (Doc) import Curry.Base.SpanInfo import qualified Curry.Syntax as CS-import Curry.Syntax.Pretty (ppConstraint, ppTypeExpr, ppQualTypeExpr)+import Curry.Syntax.Pretty (pPrint, pPrintPrec) import Base.Expr import Base.Messages (internalError)@@ -201,13 +201,13 @@ -- The following functions implement pretty-printing for types. ppType :: ModuleIdent -> Type -> Doc-ppType m = ppTypeExpr 0 . fromQualType m identSupply+ppType m = pPrintPrec 0 . fromQualType m identSupply ppPred :: ModuleIdent -> Pred -> Doc-ppPred m = ppConstraint . fromQualPred m identSupply+ppPred m = pPrint . fromQualPred m identSupply ppPredType :: ModuleIdent -> PredType -> Doc-ppPredType m = ppQualTypeExpr . fromQualPredType m identSupply+ppPredType m = pPrint . fromQualPredType m identSupply ppTypeScheme :: ModuleIdent -> TypeScheme -> Doc ppTypeScheme m (ForAll _ pty) = ppPredType m pty
src/Base/Expr.hs view
@@ -58,20 +58,20 @@ -- 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 _ _ = []+ 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 _ = []+ 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@@ -83,8 +83,8 @@ 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+ 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@@ -110,18 +110,18 @@ 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 (Let _ _ ds e) = filterBv ds $ qfv m ds ++ qfv m e+ qfv m (Do _ _ sts e) = foldr (qfvStmt m) (qfv m e) sts qfv m (IfThenElse _ e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3- qfv m (Case _ _ e alts) = qfv m e ++ qfv m alts+ qfv m (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+ 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@@ -136,9 +136,9 @@ qfv m (Field _ _ t) = qfv m t instance QuantExpr (Statement a) where- bv (StmtExpr _ _) = []- bv (StmtBind _ t _) = bv t- bv (StmtDecl _ ds) = bv ds+ bv (StmtExpr _ _) = []+ bv (StmtBind _ t _) = bv t+ bv (StmtDecl _ _ ds) = bv ds instance QualExpr (InfixOp a) where qfv m (InfixOp a op) = qfv m $ Variable NoSpanInfo a op
src/Base/Kinds.hs view
@@ -53,3 +53,10 @@ -- |The function 'isSimpleKind' returns whether a kind is simple or not. isSimpleKind :: Kind -> Bool isSimpleKind k = k == simpleKind (kindArity k)++-- |Fetches a kind's 'arguments', i.e. everything before an+-- arrow at the top-level. For example: A kind k1 -> k2 -> k3+-- would have the arguments [k1, k2].+kindArgs :: Kind -> [Kind]+kindArgs (KindArrow k k') = k : kindArgs k'+kindArgs _ = []
src/Base/Messages.hs view
@@ -17,7 +17,7 @@ -- * program abortion , abortWith, abortWithMessage, abortWithMessages, warnOrAbort, internalError -- * creating messages- , Message, message, posMessage+ , Message, message, posMessage, spanInfoMessage ) where import Control.Monad (unless, when)@@ -26,8 +26,8 @@ import System.IO (hFlush, hPutStrLn, stderr, stdout) import System.Exit (exitFailure) -import Curry.Base.Message ( Message, message, posMessage, ppWarning- , ppMessages, ppError)+import Curry.Base.Message ( Message, message, posMessage, spanInfoMessage+ , ppWarning, ppMessagesWithPreviews, ppError) import Curry.Base.Pretty (Doc, text) import CompilerOpts (Options (..), WarnOpts (..), Verbosity (..)) @@ -71,7 +71,7 @@ -- |Print a list of messages on 'stderr' printMessages :: (Message -> Doc) -> [Message] -> IO () printMessages msgType msgs- = unless (null msgs) $ putErrLn (show $ ppMessages msgType $ sort msgs)+ = unless (null msgs) $ putErrLn =<< (fmap show $ ppMessagesWithPreviews msgType $ sort msgs) -- |Raise an internal error internalError :: String -> a
src/Base/PrettyTypes.hs view
@@ -23,22 +23,21 @@ 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+ pPrint = pPrintPrec 0 . fromType identSupply instance Pretty Pred where- pPrint = ppConstraint . fromPred identSupply+ pPrint = pPrint . 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+ pPrint = pPrint . fromPredType identSupply instance Pretty DataConstr where pPrint (DataConstr i tys) = pPrint i <+> hsep (map pPrint tys)
src/Base/Types.hs view
@@ -216,8 +216,13 @@ 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).+-- the type component of the predicate before the class component. This way,+-- we ensure that a class method's implicit class constraint is always the+-- minimum w.r.t. this order, because the type expression for that constraint+-- is a type variable with index 0 and there are no other class constraints+-- in a predicate set that constraint the same type variable as restrictions+-- on class variables are not allowed (see predicate sets below for more+-- information why this order is relevant). instance Ord Pred where Pred qcls1 ty1 `compare` Pred qcls2 ty2 = case ty1 `compare` ty2 of
src/Base/Typing.hs view
@@ -46,8 +46,8 @@ typeOf = unpredType instance Typeable a => Typeable (Rhs a) where- typeOf (SimpleRhs _ e _ ) = typeOf e- typeOf (GuardedRhs _ es _) = head [typeOf e | CondExpr _ _ e <- es]+ 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@@ -93,10 +93,10 @@ 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 (Let _ _ _ e) = typeOf e+ typeOf (Do _ _ _ e) = typeOf e typeOf (IfThenElse _ _ e _) = typeOf e- typeOf (Case _ _ _ as) = typeOf $ head as+ typeOf (Case _ _ _ _ as) = typeOf $ head as instance Typeable a => Typeable (Alt a) where typeOf (Alt _ _ rhs) = typeOf rhs
src/Checks.hs view
@@ -69,10 +69,9 @@ -- * Environment: remains unchanged typeSyntaxCheck :: Monad m => Check m (Module a) typeSyntaxCheck _ (env, mdl)- | null msgs = ok (env { extensions = exts }, mdl')+ | null msgs = ok (env, mdl') | otherwise = failMessages msgs- where ((mdl', exts), msgs) = TSC.typeSyntaxCheck (extensions env)- (tyConsEnv env) mdl+ where (mdl', msgs) = TSC.typeSyntaxCheck (tyConsEnv env) mdl -- |Check the kinds of type definitions and signatures. --@@ -103,8 +102,8 @@ -- precedences -- * Environment: The operator precedence environment is updated precCheck :: Monad m => Check m (Module a)-precCheck _ (env, Module spi ps m es is ds)- | null msgs = ok (env { opPrecEnv = pEnv' }, Module spi ps m es is ds')+precCheck _ (env, Module spi li ps m es is ds)+ | null msgs = ok (env { opPrecEnv = pEnv' }, Module spi li ps m es is ds') | otherwise = failMessages msgs where (ds', pEnv', msgs) = PC.precCheck (moduleIdent env) (opPrecEnv env) ds @@ -122,8 +121,8 @@ -- * Declarations: remain unchanged -- * Environment: The instance environment is updated instanceCheck :: Monad m => Check m (Module a)-instanceCheck _ (env, Module spi ps m es is ds)- | null msgs = ok (env { instEnv = inEnv' }, Module spi ps m es is ds)+instanceCheck _ (env, Module spi li ps m es is ds)+ | null msgs = ok (env { instEnv = inEnv' }, Module spi li ps m es is ds) | otherwise = failMessages msgs where (inEnv', msgs) = INC.instanceCheck (moduleIdent env) (tyConsEnv env) (classEnv env) (instEnv env) ds@@ -134,8 +133,8 @@ -- * Environment: The value environment is updated. typeCheck :: Monad m => Options -> CompEnv (Module a) -> CYT m (CompEnv (Module PredType))-typeCheck _ (env, Module spi ps m es is ds)- | null msgs = ok (env { valueEnv = vEnv' }, Module spi ps m es is ds')+typeCheck _ (env, Module spi li ps m es is ds)+ | null msgs = ok (env { valueEnv = vEnv' }, Module spi li ps m es is ds') | otherwise = failMessages msgs where (ds', vEnv', msgs) = TC.typeCheck (moduleIdent env) (tyConsEnv env) (valueEnv env) (classEnv env)@@ -143,7 +142,7 @@ -- |Check the export specification exportCheck :: Monad m => Check m (Module a)-exportCheck _ (env, mdl@(Module _ _ _ es _ _))+exportCheck _ (env, mdl@(Module _ _ _ _ es _ _)) | null msgs = ok (env, mdl) | otherwise = failMessages msgs where msgs = EC.exportCheck (moduleIdent env) (aliasEnv env)@@ -151,8 +150,8 @@ -- |Check the export specification expandExports :: Monad m => Options -> CompEnv (Module a) -> m (CompEnv (Module a))-expandExports _ (env, Module spi ps m es is ds)- = return (env, Module spi ps m (Just es') is ds)+expandExports _ (env, Module spi li ps m es is ds)+ = return (env, Module spi li ps m (Just es') is ds) where es' = EC.expandExports (moduleIdent env) (aliasEnv env) (tyConsEnv env) (valueEnv env) es
src/Checks/DeriveCheck.hs view
@@ -15,16 +15,16 @@ module Checks.DeriveCheck (deriveCheck) where import Curry.Base.Ident-import Curry.Base.Position import Curry.Base.Pretty+import Curry.Base.SpanInfo (HasSpanInfo) import Curry.Syntax -import Base.Messages (Message, posMessage)+import Base.Messages (Message, spanInfoMessage) import Env.TypeConstructor deriveCheck :: TCEnv -> Module a -> [Message]-deriveCheck tcEnv (Module _ _ m _ _ ds) = concatMap (checkDecl m tcEnv) ds+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.@@ -42,18 +42,19 @@ checkDerivable m tcEnv cs cls | ocls == qEnumId && not (isEnum cs) = [errNotEnum cls] | ocls == qBoundedId && not (isBounded cs) = [errNotBounded cls]- | ocls `notElem` derivableClasses = [errNotDerivable ocls]+ | ocls `notElem` derivableClasses = [errNotDerivable cls]+ | ocls == qDataId = [errNoDataDerive cls] | otherwise = [] where ocls = getOrigName m cls tcEnv derivableClasses :: [QualIdent]-derivableClasses = [qEqId, qOrdId, qEnumId, qBoundedId, qReadId, qShowId]+derivableClasses = [qEqId, qOrdId, qEnumId, qBoundedId, qReadId, qShowId, qDataId] -- Instances of 'Enum' can be derived only for enumeration types, i.e., types -- where all data constructors are constants. isEnum :: [ConstrDecl] -> Bool-isEnum cs = all ((0 ==) . constrArity) cs+isEnum = all ((0 ==) . constrArity) -- Instances of 'Bounded' can be derived only for enumerations and for single -- constructor types.@@ -79,20 +80,32 @@ -- Error messages -- --------------------------------------------------------------------------- -errNoAbstractDerive :: HasPosition a => a -> Message-errNoAbstractDerive p = posMessage p $+errNoAbstractDerive :: HasSpanInfo a => a -> Message+errNoAbstractDerive s = spanInfoMessage s $ text "Instances can only be derived for data types with" <+> text "at least one constructor" errNotDerivable :: QualIdent -> Message-errNotDerivable cls = posMessage cls $ hsep $ map text+errNotDerivable cls = spanInfoMessage 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"+errNoDataDerive :: QualIdent -> Message+errNoDataDerive qcls = spanInfoMessage qcls $ hsep $ map text+ [ "Instances of type class"+ , escQualName qcls+ , "are automatically derived if possible"+ ] -errNotBounded :: HasPosition a => a -> Message-errNotBounded p = posMessage p $- text "Instances of Bounded can be derived only for enumeration" <+>- text "and single constructor types"+errNotEnum :: QualIdent -> Message+errNotEnum qcls = spanInfoMessage qcls $ hsep $ map text+ [ "Instances of type class"+ , escQualName qcls+ , "can be derived only for enumeration types"+ ]++errNotBounded :: QualIdent -> Message+errNotBounded qcls = spanInfoMessage qcls $ hsep $ map text+ [ "Instances of type class"+ , escQualName qcls+ , "can be derived only for enumeration and single constructor types"+ ]
src/Checks/ExportCheck.hs view
@@ -48,12 +48,12 @@ import Curry.Base.Pretty import Curry.Syntax -import Base.Messages (Message, internalError, posMessage)+import Base.Messages (Message, internalError, spanInfoMessage) import Base.TopEnv (allEntities, origName, localBindings, moduleImports) import Base.Types ( Type (..), unapplyType, arrowBase, PredType (..) , DataConstr (..), constrIdent, recLabels , ClassMethod, methodName- , TypeScheme (..) )+ , TypeScheme (..), rawType, rootOfType ) import Base.Utils (findMultiples) import Env.ModuleAlias (AliasEnv)@@ -325,26 +325,32 @@ tcEnv <- getTyConsEnv tyEnv <- getValueEnv return $- [ exportType t | (_, t) <- localBindings tcEnv ]+ [ exportType t+ | (_, t) <- localBindings tcEnv ]+ ++ [ exportLabel l' ty+ | (l, Label l' _ ty) <- localBindings tyEnv, hasGlobalScope l ] ++ [ Export NoSpanInfo f' | (f, Value f' _ _ _) <- localBindings tyEnv, hasGlobalScope f ]- ++ [ Export NoSpanInfo 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]+ return $ [exportType t | (_, t) <- moduleImports m tcEnv]+ ++ [exportLabel l ty | (_, Label l _ ty) <- moduleImports m tyEnv] ++ [Export NoSpanInfo f | (_, Value f _ _ _) <- moduleImports m tyEnv]- ++ [Export NoSpanInfo l | (_, Label l _ _) <- moduleImports m tyEnv] exportType :: TypeInfo -> Export exportType t = ExportTypeWith NoSpanInfo tc xs where tc = origName t xs = elements t +exportLabel :: QualIdent -> TypeScheme -> Export+exportLabel qid ty = case rawType ty of+ TypeArrow a _ -> ExportTypeWith NoSpanInfo (rootOfType a) [qidIdent qid]+ _ -> internalError $ "ExportCheck.exportLabel: " ++ show (qid, ty)+ -- ----------------------------------------------------------------------------- -- Canonicalization and joining of exports -- -----------------------------------------------------------------------------@@ -435,13 +441,13 @@ errAmbiguousType tc tcs = errAmbiguous "type" tc (map origName tcs) errAmbiguous :: String -> QualIdent -> [QualIdent] -> Message-errAmbiguous what qn qns = posMessage qn+errAmbiguous what qn qns = spanInfoMessage qn $ text "Ambiguous" <+> text what <+> text (escQualName qn) $+$ text "It could refer to:" $+$ nest 2 (vcat (map (text . escQualName) qns)) errModuleNotImported :: ModuleIdent -> Message-errModuleNotImported m = posMessage m $ hsep $ map text+errModuleNotImported m = spanInfoMessage m $ hsep $ map text ["Module", escModuleName m, "not imported"] errMultipleName :: [Ident] -> Message@@ -453,13 +459,13 @@ errMultiple :: String -> [Ident] -> Message errMultiple _ [] = internalError $ currentModuleName ++ ".errMultiple: empty list"-errMultiple what (i:is) = posMessage i $+errMultiple what (i:is) = spanInfoMessage i $ text "Multiple exports of" <+> text what <+> text (escName i) <+> text "at:" $+$ nest 2 (vcat (map showPos (i:is))) where showPos = text . showLine . getPosition errNonDataTypeOrTypeClass :: QualIdent -> Message-errNonDataTypeOrTypeClass tc = posMessage tc $ hsep $ map text+errNonDataTypeOrTypeClass tc = spanInfoMessage tc $ hsep $ map text [escQualName tc, "is not a data type or type class"] errOutsideTypeConstructor :: QualIdent -> QualIdent -> Message@@ -469,18 +475,18 @@ errOutsideTypeLabel l tc = errOutsideTypeExport "Label" l tc errOutsideTypeExport :: String -> QualIdent -> QualIdent -> Message-errOutsideTypeExport what q tc = posMessage q+errOutsideTypeExport what q tc = spanInfoMessage q $ text what <+> text (escQualName q) <+> text "outside type export in export list" $+$ text "Use `" <> text (qualName tc) <+> parens (text (qualName q)) <> text "' instead" errUndefinedElement :: QualIdent -> Ident -> Message-errUndefinedElement tc c = posMessage c $ hsep $ map text+errUndefinedElement tc c = spanInfoMessage c $ hsep $ map text [ escName c, "is not a constructor or label of type", escQualName tc ] errUndefinedMethod :: QualIdent -> Ident -> Message-errUndefinedMethod cls f = posMessage f $ hsep $ map text+errUndefinedMethod cls f = spanInfoMessage f $ hsep $ map text [ escName f, "is not a method of class", escQualName cls ] errUndefinedName :: QualIdent -> Message@@ -490,5 +496,5 @@ errUndefinedTypeOrClass = errUndefined "type or class" errUndefined :: String -> QualIdent -> Message-errUndefined what tc = posMessage tc $ hsep $ map text+errUndefined what tc = spanInfoMessage tc $ hsep $ map text ["Undefined", what, escQualName tc, "in export list"]
src/Checks/ExtensionCheck.hs view
@@ -15,11 +15,11 @@ import qualified Control.Monad.State as S (State, execState, modify) -import Curry.Base.Position+import Curry.Base.SpanInfo import Curry.Base.Pretty import Curry.Syntax -import Base.Messages (Message, posMessage)+import Base.Messages (Message, spanInfoMessage) import CompilerOpts @@ -53,7 +53,7 @@ -- if an extension is unknown. checkModule :: Module a -> EXCM ()-checkModule (Module _ ps _ _ _ _) = mapM_ checkPragma ps+checkModule (Module _ _ ps _ _ _ _) = mapM_ checkPragma ps checkPragma :: ModulePragma -> EXCM () checkPragma (LanguagePragma _ exts) = mapM_ checkExtension exts@@ -67,6 +67,6 @@ -- Error messages -- --------------------------------------------------------------------------- -errUnknownExtension :: Position -> String -> Message-errUnknownExtension p e = posMessage p $+errUnknownExtension :: SpanInfo -> String -> Message+errUnknownExtension p e = spanInfoMessage p $ text "Unknown language extension:" <+> text e
src/Checks/ImportSyntaxCheck.hs view
@@ -259,21 +259,21 @@ -- error messages errUndefinedElement :: Ident -> Ident -> Message-errUndefinedElement tc c = posMessage c $ hsep $ map text+errUndefinedElement tc c = spanInfoMessage c $ hsep $ map text [ idName c, "is not a constructor or label of type ", idName tc ] errUndefinedMethod :: Ident -> Ident -> Message-errUndefinedMethod cls f = posMessage f $ hsep $ map text+errUndefinedMethod cls f = spanInfoMessage f $ hsep $ map text [ idName f, "is not a method of class", idName cls ] errUndefinedEntity :: ModuleIdent -> Ident -> Message-errUndefinedEntity m x = posMessage x $ hsep $ map text+errUndefinedEntity m x = spanInfoMessage x $ hsep $ map text [ "Module", moduleName m, "does not export", idName x ] errNonDataTypeOrTypeClass :: Ident -> Message-errNonDataTypeOrTypeClass tc = posMessage tc $ hsep $ map text+errNonDataTypeOrTypeClass tc = spanInfoMessage 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+errImportDataConstr _ c = spanInfoMessage c $ hsep $ map text [ "Explicit import for data constructor", idName c ]
src/Checks/InstanceCheck.hs view
@@ -19,21 +19,20 @@ -} module Checks.InstanceCheck (instanceCheck) where -import Control.Monad.Extra (concatMapM, whileM)+import Control.Monad.Extra (concatMapM, whileM, unless) import qualified Control.Monad.State as S (State, execState, gets, modify) import Data.List (nub, partition, sortBy) import qualified Data.Map as Map import qualified Data.Set.Extra as Set import Curry.Base.Ident-import Curry.Base.Position import Curry.Base.Pretty import Curry.Base.SpanInfo import Curry.Syntax hiding (impls) import Curry.Syntax.Pretty import Base.CurryTypes-import Base.Messages (Message, posMessage, message, internalError)+import Base.Messages (Message, spanInfoMessage, message, internalError) import Base.SCC (scc) import Base.TypeExpansion import Base.Types@@ -52,7 +51,7 @@ 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+ imported = map (uncurry InstSource . fmap fst3) $ Map.toList inEnv state = INCState m inEnv [] -- In order to provide better error messages, we use the following data type@@ -95,6 +94,8 @@ checkDecls :: TCEnv -> ClassEnv -> [Decl a] -> INCM () checkDecls tcEnv clsEnv ds = do mapM_ (bindInstance tcEnv clsEnv) ids+ mapM (declDeriveDataInfo tcEnv clsEnv) (filter isDataDecl tds) >>=+ mapM_ (bindDerivedInstances clsEnv) . groupDeriveInfos mapM (declDeriveInfo tcEnv clsEnv) (filter hasDerivedInstances tds) >>= mapM_ (bindDerivedInstances clsEnv) . groupDeriveInfos mapM_ (checkInstance tcEnv clsEnv) ids@@ -102,12 +103,15 @@ where (tds, ods) = partition isTypeDecl ds ids = filter isInstanceDecl ods dds = filter isDefaultDecl ods+ isDataDecl (DataDecl _ _ _ _ _) = True+ isDataDecl (NewtypeDecl _ _ _ _ _) = True+ isDataDecl _ = False -- First, the compiler adds all explicit instance declarations to the -- instance environment. bindInstance :: TCEnv -> ClassEnv -> Decl a -> INCM ()-bindInstance tcEnv clsEnv (InstanceDecl _ cx qcls inst ds) = do+bindInstance tcEnv clsEnv (InstanceDecl _ _ cx qcls inst ds) = do m <- getModuleIdent let PredType ps _ = expandPolyType m tcEnv clsEnv $ QualTypeExpr NoSpanInfo cx inst@@ -136,7 +140,7 @@ -- 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]+data DeriveInfo = DeriveInfo SpanInfo QualIdent PredType [Type] [QualIdent] declDeriveInfo :: TCEnv -> ClassEnv -> Decl a -> INCM DeriveInfo declDeriveInfo tcEnv clsEnv (DataDecl p tc tvs cs clss) =@@ -151,45 +155,70 @@ declDeriveInfo _ _ _ = internalError "InstanceCheck.declDeriveInfo: no data or newtype declaration" -mkDeriveInfo :: TCEnv -> ClassEnv -> SpanInfo -> Ident -> [Ident] -> [TypeExpr]- -> [QualIdent] -> INCM DeriveInfo+declDeriveDataInfo :: TCEnv -> ClassEnv -> Decl a -> INCM DeriveInfo+declDeriveDataInfo tcEnv clsEnv (DataDecl p tc tvs cs _) =+ mkDeriveDataInfo tcEnv clsEnv p tc tvs (concat tyss)+ where tyss = map constrDeclTypes cs+ constrDeclTypes (ConstrDecl _ _ tys) = tys+ constrDeclTypes (ConOpDecl _ ty1 _ ty2) = [ty1, ty2]+ constrDeclTypes (RecordDecl _ _ fs) = tys+ where tys = [ty | FieldDecl _ ls ty <- fs, _ <- ls]+declDeriveDataInfo tcEnv clsEnv (NewtypeDecl p tc tvs nc _) =+ mkDeriveDataInfo tcEnv clsEnv p tc tvs [nconstrType nc]+declDeriveDataInfo _ _ _ = internalError+ "InstanceCheck.declDeriveDataInfo: no data or newtype declaration"++mkDeriveInfo :: TCEnv -> ClassEnv -> SpanInfo -> Ident -> [Ident]+ -> [TypeExpr] -> [QualIdent] -> INCM DeriveInfo mkDeriveInfo tcEnv clsEnv spi tc tvs tys clss = do m <- getModuleIdent let otc = qualifyWith m tc oclss = map (flip (getOrigName m) tcEnv) clss PredType ps ty = expandConstrType m tcEnv clsEnv otc tvs tys (tys', ty') = arrowUnapply ty- return $ DeriveInfo p otc (PredType ps ty') tys' $ sortClasses clsEnv oclss- where p = spanInfo2Pos spi+ return $ DeriveInfo spi otc (PredType ps ty') tys' $ sortClasses clsEnv oclss +mkDeriveDataInfo :: TCEnv -> ClassEnv -> SpanInfo -> Ident -> [Ident]+ -> [TypeExpr] -> INCM DeriveInfo+mkDeriveDataInfo tcEnv clsEnv spi tc tvs tys = do+ m <- getModuleIdent+ let otc = qualifyWith m tc+ PredType ps ty = expandConstrType m tcEnv clsEnv otc tvs tys+ (tys', ty') = arrowUnapply ty+ return $ DeriveInfo spi otc (PredType ps ty') tys' [qDataId]+ sortClasses :: ClassEnv -> [QualIdent] -> [QualIdent] sortClasses clsEnv clss = map fst $ sortBy compareDepth $ map adjoinDepth clss where (_, d1) `compareDepth` (_, d2) = d1 `compare` d2 adjoinDepth cls = (cls, length $ allSuperClasses cls clsEnv) groupDeriveInfos :: [DeriveInfo] -> [[DeriveInfo]]-groupDeriveInfos ds = scc bound free ds+groupDeriveInfos = scc bound free where bound (DeriveInfo _ tc _ _ _) = [tc] free (DeriveInfo _ _ _ tys _) = concatMap typeConstrs tys bindDerivedInstances :: ClassEnv -> [DeriveInfo] -> INCM ()-bindDerivedInstances clsEnv dis = do+bindDerivedInstances clsEnv dis = unless (any hasDataFunType dis) $ do mapM_ (enterInitialPredSet clsEnv) dis whileM $ concatMapM (inferPredSets clsEnv) dis >>= updatePredSets+ where+ hasDataFunType (DeriveInfo _ _ _ tys clss) =+ clss == [qDataId] && any isFunType tys enterInitialPredSet :: ClassEnv -> DeriveInfo -> INCM ()-enterInitialPredSet clsEnv (DeriveInfo p tc pty _ clss) =- mapM_ (bindDerivedInstance clsEnv p tc pty []) clss+enterInitialPredSet clsEnv (DeriveInfo spi tc pty _ clss) =+ mapM_ (bindDerivedInstance clsEnv spi tc pty) clss -- Note: The methods and arities entered into the instance environment have -- to match methods and arities of the later generated instance declarations.+-- TODO: Add remark about value environment entry -bindDerivedInstance :: ClassEnv -> Position -> QualIdent -> PredType -> [Type]- -> QualIdent -> INCM ()-bindDerivedInstance clsEnv p tc pty tys cls = do+bindDerivedInstance :: HasSpanInfo s => ClassEnv -> s -> QualIdent -> PredType -> QualIdent+ -> INCM ()+bindDerivedInstance clsEnv p tc pty cls = do m <- getModuleIdent- (i, ps) <- inferPredSet clsEnv p tc pty tys cls- modifyInstEnv $ bindInstInfo i (m, ps, impls)+ ((i, ps), _) <- inferPredSet clsEnv p tc pty [] cls+ modifyInstEnv (bindInstInfo i (m, ps, impls)) where impls | cls == qEqId = [(eqOpId, 2)] | cls == qOrdId = [(leqOpId, 2)] | cls == qEnumId = [ (succId, 1), (predId, 1), (toEnumId, 1)@@ -199,15 +228,16 @@ | cls == qBoundedId = [(maxBoundId, 0), (minBoundId, 0)] | cls == qReadId = [(readsPrecId, 2)] | cls == qShowId = [(showsPrecId, 2)]+ | cls == qDataId = [(dataEqId, 2), (aValueId, 0)] | otherwise = internalError "InstanceCheck.bindDerivedInstance.impls" -inferPredSets :: ClassEnv -> DeriveInfo -> INCM [(InstIdent, PredSet)]-inferPredSets clsEnv (DeriveInfo p tc pty tys clss) =- mapM (inferPredSet clsEnv p tc pty tys) clss+inferPredSets :: ClassEnv -> DeriveInfo -> INCM [((InstIdent, PredSet), Bool)]+inferPredSets clsEnv (DeriveInfo spi tc pty tys clss) =+ mapM (inferPredSet clsEnv spi tc pty tys) clss -inferPredSet :: ClassEnv -> Position -> QualIdent -> PredType -> [Type]- -> QualIdent -> INCM (InstIdent, PredSet)+inferPredSet :: HasSpanInfo s => ClassEnv -> s -> QualIdent -> PredType -> [Type]+ -> QualIdent -> INCM ((InstIdent, PredSet), Bool) inferPredSet clsEnv p tc (PredType ps inst) tys cls = do m <- getModuleIdent let doc = ppPred m $ Pred cls inst@@ -215,25 +245,34 @@ 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'''')+ (ps4, novarps) <-+ reducePredSet (cls == qDataId) p "derived instance" doc clsEnv ps'''+ let ps5 = filter noPolyPred $ Set.toList ps4+ if any (isDataPred m) (Set.toList novarps ++ ps5) && cls == qDataId+ then return (((cls, tc), ps4), False)+ else mapM_ (reportUndecidable p "derived instance" doc) ps5+ >> return (((cls, tc), ps4), True)+ where+ noPolyPred (Pred _ (TypeVariable _)) = False+ noPolyPred (Pred _ _ ) = True+ isDataPred _ (Pred qid _) = qid == qDataId -updatePredSets :: [(InstIdent, PredSet)] -> INCM Bool-updatePredSets = (=<<) (return . or) . mapM (uncurry updatePredSet)+updatePredSets :: [((InstIdent, PredSet), Bool)] -> INCM Bool+updatePredSets = fmap or . mapM (uncurry updatePredSet) -updatePredSet :: InstIdent -> PredSet -> INCM Bool-updatePredSet i ps = do+updatePredSet :: (InstIdent, PredSet) -> Bool -> INCM Bool+updatePredSet (i, ps) enter = do inEnv <- getInstEnv case lookupInstInfo i inEnv of Just (m, ps', is)+ | not enter -> modifyInstEnv (removeInstInfo i) >> return False | ps == ps' -> return False | otherwise -> do modifyInstEnv $ bindInstInfo i (m, ps, is) return True Nothing -> internalError "InstanceCheck.updatePredSet" -reportUndecidable :: Position -> String -> Doc -> Pred -> INCM ()+reportUndecidable :: HasSpanInfo s => s -> String -> Doc -> Pred -> INCM () reportUndecidable p what doc predicate@(Pred _ ty) = do m <- getModuleIdent case ty of@@ -251,7 +290,7 @@ -- satisfied by cx. checkInstance :: TCEnv -> ClassEnv -> Decl a -> INCM ()-checkInstance tcEnv clsEnv (InstanceDecl spi cx cls inst _) = do+checkInstance tcEnv clsEnv (InstanceDecl _ _ cx cls inst _) = do m <- getModuleIdent let PredType ps ty = expandPolyType m tcEnv clsEnv $ QualTypeExpr NoSpanInfo cx inst@@ -259,10 +298,9 @@ 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)- where p = spanInfo2Pos spi+ (ps'', _) <- reducePredSet False inst what doc clsEnv ps'+ Set.mapM_ (report . errMissingInstance m inst what doc) $+ ps'' `Set.difference` maxPredSet clsEnv ps checkInstance _ _ _ = ok -- All types specified in the optional default declaration of a module@@ -271,17 +309,18 @@ -- must be empty. checkDefault :: TCEnv -> ClassEnv -> Decl a -> INCM ()-checkDefault tcEnv clsEnv (DefaultDecl p tys) =- mapM_ (checkDefaultType (spanInfo2Pos p) tcEnv clsEnv) tys+checkDefault tcEnv clsEnv (DefaultDecl _ tys) =+ mapM_ (checkDefaultType tcEnv clsEnv) tys checkDefault _ _ _ = ok -checkDefaultType :: Position -> TCEnv -> ClassEnv -> TypeExpr -> INCM ()-checkDefaultType p tcEnv clsEnv ty = do+checkDefaultType :: TCEnv -> ClassEnv -> TypeExpr -> INCM ()+checkDefaultType tcEnv clsEnv ty = do m <- getModuleIdent let PredType _ ty' = expandPolyType m tcEnv clsEnv $ QualTypeExpr NoSpanInfo [] ty- ps <- reducePredSet p what empty clsEnv (Set.singleton $ Pred qNumId ty')- Set.mapM_ (report . errMissingInstance m p what empty) ps+ (ps, _) <- reducePredSet False ty what empty clsEnv+ (Set.singleton $ Pred qNumId ty')+ Set.mapM_ (report . errMissingInstance m ty what empty) ps where what = "default declaration" -- The function 'reducePredSet' simplifies a predicate set of the form@@ -290,16 +329,20 @@ -- a type variable. An error is reported if the predicate set cannot -- be transformed into this form. In addition, we remove all predicates -- that are implied by others within the same set.+-- When the flag is set, all missing Data preds are ignored -reducePredSet :: Position -> String -> Doc -> ClassEnv -> PredSet- -> INCM PredSet-reducePredSet p what doc clsEnv ps = do+reducePredSet :: HasSpanInfo s => Bool -> s -> String -> Doc -> ClassEnv -> PredSet+ -> INCM (PredSet, PredSet)+reducePredSet b p what doc clsEnv ps = do m <- getModuleIdent inEnv <- getInstEnv let (ps1, ps2) = partitionPredSet $ minPredSet clsEnv $ reducePreds inEnv ps- Set.mapM_ (report . errMissingInstance m p what doc) ps2- return ps1+ ps2' = if b then Set.filter (isNotDataPred m) ps2 else ps2+ Set.mapM_ (reportMissing m) ps2' >> return (ps1, ps2) where+ isNotDataPred _ (Pred qid _) = qid /= qDataId+ reportMissing m pr@(Pred _ _) =+ report $ errMissingInstance m p what doc pr reducePreds inEnv = Set.concatMap $ reducePred inEnv reducePred inEnv predicate = maybe (Set.singleton predicate) (reducePreds inEnv)@@ -323,7 +366,7 @@ genInstIdents m tcEnv (NewtypeDecl _ tc _ _ qclss) = map (flip (genInstIdent m tcEnv) $ ConstructorType NoSpanInfo $ qualify tc) qclss-genInstIdents m tcEnv (InstanceDecl _ _ qcls ty _) =+genInstIdents m tcEnv (InstanceDecl _ _ _ qcls ty _) = [genInstIdent m tcEnv qcls ty] genInstIdents _ _ _ = [] @@ -344,6 +387,13 @@ where unqual = head . flip reverseLookupByOrigName tcEnv +isFunType :: Type -> Bool+isFunType (TypeArrow _ _) = True+isFunType (TypeApply t1 t2) = isFunType t1 || isFunType t2+isFunType (TypeForall _ ty) = isFunType ty+isFunType (TypeConstrained tys _) = any isFunType tys+isFunType _ = False+ -- --------------------------------------------------------------------------- -- Error messages -- ---------------------------------------------------------------------------@@ -356,9 +406,9 @@ ppInstSource (InstSource i m) = ppInstIdent (unqualInstIdent tcEnv i) <+> parens (text "defined in" <+> ppMIdent m) -errMissingInstance :: ModuleIdent -> Position -> String -> Doc -> Pred+errMissingInstance :: HasSpanInfo s => ModuleIdent -> s -> String -> Doc -> Pred -> Message-errMissingInstance m p what doc predicate = posMessage p $ vcat+errMissingInstance m p what doc predicate = spanInfoMessage (getSpanInfo p) $ vcat [ text "Missing instance for" <+> ppPred m predicate , text "in" <+> text what <+> doc ]
src/Checks/InterfaceCheck.hs view
@@ -51,17 +51,16 @@ import Control.Monad (unless) import qualified Control.Monad.State as S import Data.List (sort)-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, isJust, isNothing) import Curry.Base.Ident-import Curry.Base.Position import Curry.Base.SpanInfo import Curry.Base.Pretty import Curry.Syntax import Base.CurryKinds (toKind') import Base.CurryTypes-import Base.Messages (Message, posMessage, internalError)+import Base.Messages (Message, spanInfoMessage, internalError) import Base.TopEnv import Base.Types @@ -110,22 +109,23 @@ interfaceCheck :: OpPrecEnv -> TCEnv -> ClassEnv -> InstEnv -> ValueEnv -> Interface -> [Message]-interfaceCheck pEnv tcEnv clsEnv inEnv tyEnv (Interface m _ ds) = reverse (errors s)+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+checkImport (IInfixDecl _ fix pr op) = checkPrecInfo check op 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+checkImport (HidingDataDecl _ tc k tvs) =+ checkTypeInfo "hidden data type" check tc tc where check (DataType tc' k' _) | tc == tc' && toKind' k (length tvs) == k' = Just ok check (RenamingType tc' k' _) | tc == tc' && toKind' k (length tvs) == k' = Just ok check _ = Nothing-checkImport (IDataDecl p tc k tvs cs _) = checkTypeInfo "data type" check p tc+checkImport (IDataDecl _ tc k tvs cs _) = checkTypeInfo "data type" check tc tc where check (DataType tc' k' cs') | tc == tc' && toKind' k (length tvs) == k' && (null cs || map constrId cs == map constrIdent cs')@@ -134,41 +134,43 @@ | 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+checkImport (INewtypeDecl _ tc k tvs nc _) = checkTypeInfo "newtype" check tc tc where check (RenamingType tc' k' nc') | tc == tc' && toKind' k (length tvs) == k' && nconstrId nc == constrIdent nc' = Just (checkNewConstrImport tc tvs nc) check _ = Nothing-checkImport (ITypeDecl p tc k tvs ty) = do+checkImport (ITypeDecl _ tc k tvs ty) = do m <- getModuleIdent let check (AliasType tc' k' n' ty') | tc == tc' && toKind' k (length tvs) == k' && length tvs == n' && toQualType m tvs ty == ty' = Just ok check _ = Nothing- checkTypeInfo "synonym type" check p tc-checkImport (IFunctionDecl p f (Just tv) n ty) = do+ checkTypeInfo "synonym type" check tc tc+checkImport (IFunctionDecl _ f (Just tv) n ty) = do m <- getModuleIdent let check (Value f' cm' n' (ForAll _ ty')) =- f == f' && cm' && n' == n && toQualPredType m [tv] ty == ty'+ f == f' && isJust cm' && n' == n &&+ toQualPredType m [tv] ty == ty' check _ = False- checkValueInfo "method" check p f-checkImport (IFunctionDecl p f Nothing n ty) = do+ checkValueInfo "method" check f f+checkImport (IFunctionDecl _ f Nothing n ty) = do m <- getModuleIdent let check (Value f' cm' n' (ForAll _ ty')) =- f == f' && not cm' && n' == n && toQualPredType m [] ty == ty'+ f == f' && isNothing cm' && n' == n &&+ toQualPredType m [] ty == ty' check _ = False- checkValueInfo "function" check p f-checkImport (HidingClassDecl p cx cls k _) = do+ checkValueInfo "function" check f f+checkImport (HidingClassDecl _ cx cls k _) = do clsEnv <- getClassEnv let check (TypeClass cls' k' _) | cls == cls' && toKind' k 0 == k' && [cls'' | Constraint _ cls'' _ <- cx] == superClasses cls' clsEnv = Just ok check _ = Nothing- checkTypeInfo "hidden type class" check p cls-checkImport (IClassDecl p cx cls k clsvar ms _) = do+ checkTypeInfo "hidden type class" check cls cls+checkImport (IClassDecl _ cx cls k clsvar ms _) = do clsEnv <- getClassEnv let check (TypeClass cls' k' fs) | cls == cls' && toKind' k 0 == k' &&@@ -177,30 +179,30 @@ 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) =- checkInstInfo check p (cls, typeConstr ty) m+ checkTypeInfo "type class" check cls cls+checkImport (IInstanceDecl _ cx cls ty is m) =+ checkInstInfo check cls (cls, typeConstr ty) m where PredType ps _ = toPredType [] $ QualTypeExpr NoSpanInfo cx ty check ps' is' = ps == ps' && sort is == sort is' checkConstrImport :: QualIdent -> [Ident] -> ConstrDecl -> IC ()-checkConstrImport tc tvs (ConstrDecl p c tys) = do+checkConstrImport tc tvs (ConstrDecl _ c tys) = do m <- getModuleIdent let qc = qualifyLike tc c check (DataConstructor c' _ _ (ForAll uqvs pty)) = qc == c' && length tvs == uqvs && qualifyPredType m (toConstrType tc tvs tys) == pty check _ = False- checkValueInfo "data constructor" check p qc-checkConstrImport tc tvs (ConOpDecl p ty1 op ty2) = do+ checkValueInfo "data constructor" check c qc+checkConstrImport tc tvs (ConOpDecl _ ty1 op ty2) = do m <- getModuleIdent let qc = qualifyLike tc op check (DataConstructor c' _ _ (ForAll uqvs pty)) = qc == c' && length tvs == uqvs && qualifyPredType m (toConstrType tc tvs [ty1, ty2]) == pty check _ = False- checkValueInfo "data constructor" check p qc-checkConstrImport tc tvs (RecordDecl p c fs) = do+ checkValueInfo "data constructor" check op qc+checkConstrImport tc tvs (RecordDecl _ c fs) = do m <- getModuleIdent let qc = qualifyLike tc c (ls, tys) = unzip [(l, ty) | FieldDecl _ labels ty <- fs, l <- labels]@@ -208,34 +210,35 @@ qc == c' && length tvs == uqvs && ls == ls' && qualifyPredType m (toConstrType tc tvs tys) == pty check _ = False- checkValueInfo "data constructor" check p qc+ checkValueInfo "data constructor" check c qc checkNewConstrImport :: QualIdent -> [Ident] -> NewConstrDecl -> IC ()-checkNewConstrImport tc tvs (NewConstrDecl p c ty) = do+checkNewConstrImport tc tvs (NewConstrDecl _ c ty) = do m <- getModuleIdent let qc = qualifyLike tc c check (NewtypeConstructor c' _ (ForAll uqvs (PredType _ ty'))) =- qc == c' && length tvs == uqvs &&toQualType m tvs ty == head (arrowArgs ty')+ 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+ checkValueInfo "newtype constructor" check c qc+checkNewConstrImport tc tvs (NewRecordDecl _ c (l, ty)) = do m <- getModuleIdent let qc = qualifyLike tc c check (NewtypeConstructor c' l' (ForAll uqvs (PredType _ ty'))) = qc == c' && length tvs == uqvs && l == l' && toQualType m tvs ty == head (arrowArgs ty') check _ = False- checkValueInfo "newtype constructor" check p qc+ checkValueInfo "newtype constructor" check c qc checkMethodImport :: QualIdent -> Ident -> IMethodDecl -> IC ()-checkMethodImport qcls clsvar (IMethodDecl p f _ qty) =- checkValueInfo "method" check p qf+checkMethodImport qcls clsvar (IMethodDecl _ f _ qty) =+ checkValueInfo "method" check f qf where qf = qualifyLike qcls f check (Value f' cm' _ (ForAll _ pty)) =- qf == f' && cm' && toMethodType qcls clsvar qty == pty+ qf == f' && isJust cm' &&+ toMethodType qcls clsvar qty == pty check _ = False -checkPrecInfo :: (PrecInfo -> Bool) -> Position -> QualIdent -> IC ()+checkPrecInfo :: HasSpanInfo s => (PrecInfo -> Bool) -> s -> QualIdent -> IC () checkPrecInfo check p op = do pEnv <- getPrecEnv let checkInfo m op' = case qualLookupTopEnv op pEnv of@@ -245,7 +248,7 @@ _ -> internalError "checkPrecInfo" checkImported checkInfo op -checkTypeInfo :: String -> (TypeInfo -> Maybe (IC ())) -> Position+checkTypeInfo :: HasSpanInfo s => String -> (TypeInfo -> Maybe (IC ())) -> s -> QualIdent -> IC () checkTypeInfo what check p tc = do tcEnv <- getTyConsEnv@@ -255,7 +258,7 @@ _ -> internalError "checkTypeInfo" checkImported checkInfo tc -checkInstInfo :: (PredSet -> [(Ident, Int)] -> Bool) -> Position -> InstIdent+checkInstInfo :: HasSpanInfo s => (PredSet -> [(Ident, Int)] -> Bool) -> s -> InstIdent -> Maybe ModuleIdent -> IC () checkInstInfo check p i mm = do inEnv <- getInstEnv@@ -267,7 +270,7 @@ Nothing -> report $ errNoInstance p m i checkImported checkInfo (maybe qualify qualifyWith mm anonId) -checkValueInfo :: HasPosition a => String -> (ValueInfo -> Bool) -> a+checkValueInfo :: HasSpanInfo a => String -> (ValueInfo -> Bool) -> a -> QualIdent -> IC () checkValueInfo what check p x = do tyEnv <- getValueEnv@@ -277,7 +280,7 @@ (report $ errImportConflict p' what m x') _ -> internalError "checkValueInfo" checkImported checkInfo x- where p' = getPosition p+ where p' = getSpanInfo p checkImported :: (ModuleIdent -> Ident -> IC ()) -> QualIdent -> IC () checkImported _ (QualIdent _ Nothing _) = ok@@ -287,32 +290,32 @@ -- Error messages -- --------------------------------------------------------------------------- -errNotExported :: Position -> String -> ModuleIdent -> Ident -> Message-errNotExported p what m x = posMessage p $+errNotExported :: HasSpanInfo s => s -> String -> ModuleIdent -> Ident -> Message+errNotExported p what m x = spanInfoMessage p $ text "Inconsistent module interfaces" $+$ text "Module" <+> text (moduleName m) <+> text "does not export"<+> text what <+> text (escName x) -errNoPrecedence :: Position -> ModuleIdent -> Ident -> Message-errNoPrecedence p m x = posMessage p $+errNoPrecedence :: HasSpanInfo s => s -> ModuleIdent -> Ident -> Message+errNoPrecedence p m x = spanInfoMessage p $ text "Inconsistent module interfaces" $+$ text "Module" <+> text (moduleName m) <+> text "does not define a precedence for" <+> text (escName x) -errNoInstance :: Position -> ModuleIdent -> InstIdent -> Message-errNoInstance p m i = posMessage p $+errNoInstance :: HasSpanInfo s => s -> ModuleIdent -> InstIdent -> Message+errNoInstance p m i = spanInfoMessage p $ text "Inconsistent module interfaces" $+$ text "Module" <+> text (moduleName m) <+> text "does not define an instance for" <+> ppInstIdent i -errImportConflict :: Position -> String -> ModuleIdent -> Ident -> Message-errImportConflict p what m x = posMessage p $+errImportConflict :: HasSpanInfo s => s -> String -> ModuleIdent -> Ident -> Message+errImportConflict p what m x = spanInfoMessage p $ text "Inconsistent module interfaces" $+$ text "Declaration of" <+> text what <+> text (escName x) <+> text "does not match its definition in module" <+> text (moduleName m) -errInstanceConflict :: Position -> ModuleIdent -> InstIdent -> Message-errInstanceConflict p m i = posMessage p $+errInstanceConflict :: HasSpanInfo s => s -> ModuleIdent -> InstIdent -> Message+errInstanceConflict p m i = spanInfoMessage p $ text "Inconsistent module interfaces" $+$ text "Declaration of instance" <+> ppInstIdent i <+> text "does not match its definition in module" <+> text (moduleName m)
src/Checks/InterfaceSyntaxCheck.hs view
@@ -29,7 +29,7 @@ import Data.Maybe (isNothing) import Base.Expr-import Base.Messages (Message, posMessage, internalError)+import Base.Messages (Message, spanInfoMessage, internalError) import Base.TopEnv import Base.Utils (findMultiples, findDouble) @@ -37,11 +37,9 @@ import Env.Type import Curry.Base.Ident-import Curry.Base.Position import Curry.Base.SpanInfo import Curry.Base.Pretty import Curry.Syntax-import Curry.Syntax.Pretty data ISCState = ISCState { typeEnv :: TypeEnv@@ -124,7 +122,7 @@ checkClass qcls QualTypeExpr _ cx' inst' <- checkQualType $ QualTypeExpr NoSpanInfo cx inst checkSimpleContext cx'- checkInstanceType p inst'+ checkInstanceType inst' mapM_ (report . errMultipleImplementation . head) $ findMultiples $ map fst is return $ IInstanceDecl p cx' qcls inst' is m @@ -178,19 +176,19 @@ 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+ unless (tv `elem` fv qty') $ report $ errAmbiguousType f tv let QualTypeExpr _ cx _ = qty'- when (tv `elem` fv cx) $ report $ errConstrainedClassVariable p tv+ when (tv `elem` fv cx) $ report $ errConstrainedClassVariable f tv return $ IMethodDecl p f a qty' -checkInstanceType :: Position -> InstanceType -> ISC ()-checkInstanceType p inst = do+checkInstanceType :: InstanceType -> ISC ()+checkInstanceType inst = do tEnv <- getTypeEnv unless (isSimpleType inst && not (isTypeSyn (typeConstr inst) tEnv) && null (filter isAnonId $ typeVars inst) && isNothing (findDouble $ fv inst)) $- report $ errIllegalInstanceType p inst+ report $ errIllegalInstanceType inst inst checkQualType :: QualTypeExpr -> ISC QualTypeExpr checkQualType (QualTypeExpr spi cx ty) = do@@ -291,7 +289,7 @@ -- --------------------------------------------------------------------------- errUndefined :: String -> QualIdent -> Message-errUndefined what qident = posMessage qident $ hsep $ map text+errUndefined what qident = spanInfoMessage qident $ hsep $ map text ["Undefined", what, qualName qident] errUndefinedClass :: QualIdent -> Message@@ -301,47 +299,47 @@ errUndefinedType = errUndefined "type" errMultipleImplementation :: Ident -> Message-errMultipleImplementation f = posMessage f $ hsep $ map text+errMultipleImplementation f = spanInfoMessage 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+errAmbiguousType :: HasSpanInfo s => s -> Ident -> Message+errAmbiguousType p ident = spanInfoMessage 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+errConstrainedClassVariable :: HasSpanInfo s => s -> Ident -> Message+errConstrainedClassVariable p ident = spanInfoMessage p $ hsep $ map text [ "Method context must not constrain class variable", idName ident ] errNonLinear :: Ident -> String -> Message-errNonLinear tv what = posMessage tv $ hsep $ map text+errNonLinear tv what = spanInfoMessage tv $ hsep $ map text [ "Type variable", escName tv, "occurs more than once in", what ] errNoVariable :: Ident -> String -> Message-errNoVariable tv what = posMessage tv $ hsep $ map text+errNoVariable tv what = spanInfoMessage tv $ hsep $ map text [ "Type constructor or type class identifier", escName tv, "used in", what ] errUnboundVariable :: Ident -> Message-errUnboundVariable tv = posMessage tv $+errUnboundVariable tv = spanInfoMessage tv $ text "Undefined type variable" <+> text (escName tv) errBadTypeSynonym :: QualIdent -> Message-errBadTypeSynonym tc = posMessage tc $ text "Synonym type"+errBadTypeSynonym tc = spanInfoMessage 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+errNoElement what for tc x = spanInfoMessage x $ hsep $ map text [ "Hidden", what, escName x, "is not defined for", for, qualName tc ] errIllegalSimpleConstraint :: Constraint -> Message-errIllegalSimpleConstraint c@(Constraint _ qcls _) = posMessage qcls $ vcat- [ text "Illegal class constraint" <+> ppConstraint c+errIllegalSimpleConstraint c@(Constraint _ qcls _) = spanInfoMessage qcls $ vcat+ [ text "Illegal class constraint" <+> pPrint c , text "Constraints in class and instance declarations must be of" , text "the form C u, where C is a type class and u is a type variable." ] -errIllegalInstanceType :: Position -> InstanceType -> Message-errIllegalInstanceType p inst = posMessage p $ vcat- [ text "Illegal instance type" <+> ppInstanceType inst+errIllegalInstanceType :: HasSpanInfo s => s -> InstanceType -> Message+errIllegalInstanceType p inst = spanInfoMessage p $ vcat+ [ text "Illegal instance type" <+> pPrint inst , text "The instance type must be of the form (T u_1 ... u_n)," , text "where T is not a type synonym and u_1, ..., u_n are" , text "mutually distinct, non-anonymous type variables."
src/Checks/KindCheck.hs view
@@ -30,7 +30,7 @@ import Curry.Base.Ident import Curry.Base.Position-import Curry.Base.SpanInfo ()+import Curry.Base.SpanInfo import Curry.Base.Pretty import Curry.Syntax import Curry.Syntax.Pretty@@ -39,7 +39,7 @@ import Base.Expr import Base.Kinds import Base.KindSubst-import Base.Messages (Message, posMessage, internalError)+import Base.Messages (Message, spanInfoMessage, internalError) import Base.SCC import Base.TopEnv import Base.Types@@ -58,7 +58,7 @@ -- synonyms into the type constructor environment. kindCheck :: TCEnv -> ClassEnv -> Module a -> ((TCEnv, ClassEnv), [Message])-kindCheck tcEnv clsEnv (Module _ _ m _ _ ds) = runKCM check initState+kindCheck tcEnv clsEnv (Module _ _ _ m _ _ ds) = runKCM check initState where check = do checkNonRecursiveTypes tds &&> checkAcyclicSuperClasses cds@@ -123,7 +123,7 @@ bt (ExternalDataDecl _ tc _) = [tc] bt (NewtypeDecl _ tc _ _ _) = [tc] bt (TypeDecl _ tc _ _) = [tc]-bt (ClassDecl _ _ cls _ _) = [cls]+bt (ClassDecl _ _ _ cls _ _) = [cls] bt _ = [] ft :: ModuleIdent -> Decl a -> [Ident]@@ -139,19 +139,19 @@ 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 _ (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@@ -186,8 +186,8 @@ 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+ 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@@ -213,15 +213,15 @@ 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 (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+ 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+ 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@@ -277,16 +277,16 @@ checkAcyclicSuperClasses :: [Decl a] -> KCM () checkAcyclicSuperClasses ds = do m <- getModuleIdent- mapM_ checkClassDecl $ scc bt (\(ClassDecl _ cx _ _ _) -> fc m cx) ds+ 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+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 (ClassDecl _ _ _ cls _ _ : ds) =+ report $ errRecursiveClasses $ cls : [cls' | ClassDecl _ _ _ cls' _ _ <- ds] checkClassDecl _ = internalError "Checks.KindCheck.checkClassDecl: no class declaration" @@ -342,7 +342,7 @@ where aliasType tc' k = AliasType tc' k $ length tvs ty' = expandMonoType m tcEnv' tvs ty-bindKind m tcEnv' clsEnv tcEnv (ClassDecl _ _ cls tv ds) =+bindKind m tcEnv' clsEnv tcEnv (ClassDecl _ _ _ cls tv ds) = bindTypeClass cls (concatMap mkMethods ds) tcEnv where mkMethods (TypeSig _ fs qty) = map (mkMethod qty) fs@@ -390,7 +390,7 @@ bindTypeVar ident k = bindTopEnv ident (TypeVar k) bindClass :: ModuleIdent -> TCEnv -> ClassEnv -> Decl a -> ClassEnv-bindClass m tcEnv clsEnv (ClassDecl _ cx cls _ ds) =+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@@ -442,54 +442,54 @@ kcDecl tcEnv (NewtypeDecl _ tc tvs nc _) = do (_, tcEnv') <- bindTypeVars tc tvs tcEnv kcNewConstrDecl tcEnv' nc-kcDecl tcEnv t@(TypeDecl p tc tvs ty) = do+kcDecl tcEnv t@(TypeDecl _ 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+ kcType tcEnv' "type declaration" (pPrint t) k ty+kcDecl tcEnv (TypeSig _ _ qty) = kcTypeSig tcEnv qty kcDecl tcEnv (FunctionDecl _ _ _ eqs) = mapM_ (kcEquation tcEnv) eqs kcDecl _ (ExternalDecl _ _) = ok kcDecl tcEnv (PatternDecl _ _ rhs) = kcRhs tcEnv rhs kcDecl _ (FreeDecl _ _) = ok-kcDecl tcEnv (DefaultDecl p tys) = do+kcDecl tcEnv (DefaultDecl _ 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+ mapM_ (kcValueType tcEnv' "default declaration" empty) tys+kcDecl tcEnv (ClassDecl _ _ cx cls tv ds) = do m <- getModuleIdent let tcEnv' = bindTypeVar tv (clsKind m (qualifyWith m cls) tcEnv) tcEnv- kcContext tcEnv' p cx+ kcContext tcEnv' cx mapM_ (kcDecl tcEnv') ds-kcDecl tcEnv (InstanceDecl p cx qcls inst ds) = do+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+ kcContext tcEnv' cx+ kcType tcEnv' what doc (clsKind m qcls tcEnv) inst mapM_ (kcDecl tcEnv') ds where what = "instance declaration"- doc = ppDecl (InstanceDecl p cx qcls inst [])+ doc = pPrint (InstanceDecl p WhitespaceLayout cx qcls inst []) kcConstrDecl :: TCEnv -> ConstrDecl -> KCM ()-kcConstrDecl tcEnv d@(ConstrDecl p _ tys) = do- mapM_ (kcValueType tcEnv p what doc) tys+kcConstrDecl tcEnv d@(ConstrDecl _ _ tys) = do+ mapM_ (kcValueType tcEnv what doc) tys where what = "data constructor declaration"- doc = ppConstr d-kcConstrDecl tcEnv d@(ConOpDecl p ty1 _ ty2) = do- kcValueType tcEnv p what doc ty1- kcValueType tcEnv p what doc ty2+ doc = pPrint d+kcConstrDecl tcEnv d@(ConOpDecl _ ty1 _ ty2) = do+ kcValueType tcEnv what doc ty1+ kcValueType tcEnv what doc ty2 where what = "data constructor declaration"- doc = ppConstr d+ doc = pPrint d kcConstrDecl tcEnv (RecordDecl _ _ fs) = do mapM_ (kcFieldDecl tcEnv) fs kcFieldDecl :: TCEnv -> FieldDecl -> KCM ()-kcFieldDecl tcEnv d@(FieldDecl p _ ty) =- kcValueType tcEnv p "field declaration" (ppFieldDecl d) ty+kcFieldDecl tcEnv d@(FieldDecl _ _ ty) =+ kcValueType tcEnv "field declaration" (pPrint d) ty kcNewConstrDecl :: TCEnv -> NewConstrDecl -> KCM ()-kcNewConstrDecl tcEnv d@(NewConstrDecl p _ ty) =- kcValueType tcEnv p "newtype constructor declaration" (ppNewConstr d) ty+kcNewConstrDecl tcEnv d@(NewConstrDecl _ _ ty) =+ kcValueType tcEnv "newtype constructor declaration" (pPrint d) ty kcNewConstrDecl tcEnv (NewRecordDecl p _ (l, ty)) = kcFieldDecl tcEnv (FieldDecl p [l] ty) @@ -497,110 +497,110 @@ kcEquation tcEnv (Equation _ _ rhs) = kcRhs tcEnv rhs kcRhs :: TCEnv -> Rhs a -> KCM ()-kcRhs tcEnv (SimpleRhs p e ds) = do- kcExpr tcEnv p e+kcRhs tcEnv (SimpleRhs _ _ e ds) = do+ kcExpr tcEnv e mapM_ (kcDecl tcEnv) ds-kcRhs tcEnv (GuardedRhs _ es ds) = do+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+kcCondExpr tcEnv (CondExpr _ g e) = kcExpr tcEnv g >> kcExpr tcEnv e -kcExpr :: HasPosition p => TCEnv -> p -> 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+kcExpr :: TCEnv -> Expression a -> KCM ()+kcExpr _ (Literal _ _ _) = ok+kcExpr _ (Variable _ _ _) = ok+kcExpr _ (Constructor _ _ _) = ok+kcExpr tcEnv (Paren _ e) = kcExpr tcEnv e+kcExpr tcEnv (Typed _ e qty) = do+ kcExpr tcEnv e+ kcTypeSig tcEnv qty+kcExpr tcEnv (Record _ _ _ fs) = mapM_ (kcField tcEnv) fs+kcExpr tcEnv (RecordUpdate _ e fs) = do+ kcExpr tcEnv e+ mapM_ (kcField tcEnv) fs+kcExpr tcEnv (Tuple _ es) = mapM_ (kcExpr tcEnv) es+kcExpr tcEnv (List _ _ es) = mapM_ (kcExpr tcEnv) es+kcExpr tcEnv (ListCompr _ e stms) = do+ kcExpr tcEnv e+ mapM_ (kcStmt tcEnv) stms+kcExpr tcEnv (EnumFrom _ e) = kcExpr tcEnv e+kcExpr tcEnv (EnumFromThen _ e1 e2) = do+ kcExpr tcEnv e1+ kcExpr tcEnv e2+kcExpr tcEnv (EnumFromTo _ e1 e2) = do+ kcExpr tcEnv e1+ kcExpr tcEnv e2+kcExpr tcEnv (EnumFromThenTo _ e1 e2 e3) = do+ kcExpr tcEnv e1+ kcExpr tcEnv e2+ kcExpr tcEnv e3+kcExpr tcEnv (UnaryMinus _ e) = kcExpr tcEnv e+kcExpr tcEnv (Apply _ e1 e2) = do+ kcExpr tcEnv e1+ kcExpr tcEnv e2+kcExpr tcEnv (InfixApply _ e1 _ e2) = do+ kcExpr tcEnv e1+ kcExpr tcEnv e2+kcExpr tcEnv (LeftSection _ e _) = kcExpr tcEnv e+kcExpr tcEnv (RightSection _ _ e) = kcExpr tcEnv e+kcExpr tcEnv (Lambda _ _ e) = kcExpr tcEnv e+kcExpr tcEnv (Let _ _ ds e) = do mapM_ (kcDecl tcEnv) ds- kcExpr tcEnv 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+ kcExpr tcEnv e+kcExpr tcEnv (Do _ _ stms e) = do+ mapM_ (kcStmt tcEnv) stms+ kcExpr tcEnv e+kcExpr tcEnv (IfThenElse _ e1 e2 e3) = do+ kcExpr tcEnv e1+ kcExpr tcEnv e2+ kcExpr tcEnv e3+kcExpr tcEnv (Case _ _ _ e alts) = do+ kcExpr tcEnv e mapM_ (kcAlt tcEnv) alts -kcStmt :: HasPosition p => TCEnv -> p -> 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+kcStmt :: TCEnv -> Statement a -> KCM ()+kcStmt tcEnv (StmtExpr _ e) = kcExpr tcEnv e+kcStmt tcEnv (StmtDecl _ _ ds) = mapM_ (kcDecl tcEnv) ds+kcStmt tcEnv (StmtBind _ _ e) = kcExpr tcEnv e kcAlt :: TCEnv -> Alt a -> KCM () kcAlt tcEnv (Alt _ _ rhs) = kcRhs tcEnv rhs -kcField :: HasPosition p => TCEnv -> p -> Field (Expression a) -> KCM ()-kcField tcEnv p (Field _ _ e) = kcExpr tcEnv p e+kcField :: TCEnv -> Field (Expression a) -> KCM ()+kcField tcEnv (Field _ _ e) = kcExpr tcEnv e -kcContext :: HasPosition p => TCEnv -> p -> Context -> KCM ()-kcContext tcEnv p = mapM_ (kcConstraint tcEnv p)+kcContext :: TCEnv -> Context -> KCM ()+kcContext tcEnv = mapM_ (kcConstraint tcEnv) -kcConstraint :: HasPosition p => TCEnv -> p -> Constraint -> KCM ()-kcConstraint tcEnv p sc@(Constraint _ qcls ty) = do+kcConstraint :: TCEnv -> Constraint -> KCM ()+kcConstraint tcEnv sc@(Constraint _ qcls ty) = do m <- getModuleIdent- kcType tcEnv p "class constraint" doc (clsKind m qcls tcEnv) ty+ kcType tcEnv "class constraint" doc (clsKind m qcls tcEnv) ty where- doc = ppConstraint sc+ doc = pPrint sc -kcTypeSig :: HasPosition p => TCEnv -> p -> QualTypeExpr -> KCM ()-kcTypeSig tcEnv p (QualTypeExpr _ cx ty) = do+kcTypeSig :: TCEnv -> QualTypeExpr -> KCM ()+kcTypeSig tcEnv (QualTypeExpr _ cx ty) = do tcEnv' <- foldM bindFreshKind tcEnv free- kcContext tcEnv' p cx- kcValueType tcEnv' p "type signature" doc ty+ kcContext tcEnv' cx+ kcValueType tcEnv' "type signature" doc ty where free = filter (null . flip lookupTypeInfo tcEnv) $ nub $ fv ty- doc = ppTypeExpr 0 ty+ doc = pPrintPrec 0 ty -kcValueType :: HasPosition p => TCEnv -> p -> String -> Doc -> TypeExpr -> KCM ()-kcValueType tcEnv p what doc = kcType tcEnv p what doc KindStar+kcValueType :: TCEnv -> String -> Doc -> TypeExpr -> KCM ()+kcValueType tcEnv what doc = kcType tcEnv what doc KindStar -kcType :: HasPosition p => TCEnv -> p -> 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'+kcType :: TCEnv -> String -> Doc -> Kind -> TypeExpr -> KCM ()+kcType tcEnv what doc k ty = do+ k' <- kcTypeExpr tcEnv "type expression" doc' 0 ty+ unify ty what (doc $-$ text "Type:" <+> doc') k k' where- doc' = ppTypeExpr 0 ty+ doc' = pPrintPrec 0 ty -kcTypeExpr :: HasPosition p => TCEnv -> p -> String -> Doc -> Int -> TypeExpr -> KCM Kind-kcTypeExpr tcEnv p _ _ n (ConstructorType _ tc) = do+kcTypeExpr :: TCEnv -> String -> Doc -> Int -> TypeExpr -> KCM Kind+kcTypeExpr tcEnv _ _ n (ConstructorType p tc) = do m <- getModuleIdent case qualLookupTypeInfo tc tcEnv of [AliasType _ _ n' _] -> case n >= n' of@@ -609,29 +609,29 @@ 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+kcTypeExpr tcEnv what doc n (ApplyType p ty1 ty2) = do+ (alpha, beta) <- kcTypeExpr tcEnv what doc (n + 1) ty1 >>=+ kcArrow p what (doc $-$ text "Type:" <+> pPrintPrec 0 ty1)+ kcTypeExpr tcEnv what doc 0 ty2 >>=+ unify p what (doc $-$ text "Type:" <+> pPrintPrec 0 ty2) alpha return beta-kcTypeExpr tcEnv _ _ _ _ (VariableType _ tv) = return (varKind tv tcEnv)-kcTypeExpr tcEnv p what doc _ (TupleType _ tys) = do- mapM_ (kcValueType tcEnv p what doc) tys+kcTypeExpr tcEnv _ _ _ (VariableType _ tv) = return (varKind tv tcEnv)+kcTypeExpr tcEnv what doc _ (TupleType _ tys) = do+ mapM_ (kcValueType tcEnv what doc) tys return KindStar-kcTypeExpr tcEnv p what doc _ (ListType _ ty) = do- kcValueType tcEnv p what doc ty+kcTypeExpr tcEnv what doc _ (ListType _ ty) = do+ kcValueType tcEnv 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+kcTypeExpr tcEnv what doc _ (ArrowType _ ty1 ty2) = do+ kcValueType tcEnv what doc ty1+ kcValueType tcEnv 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+kcTypeExpr tcEnv what doc n (ParenType _ ty) = kcTypeExpr tcEnv what doc n ty+kcTypeExpr tcEnv what doc n (ForallType _ vs ty) = do tcEnv' <- foldM bindFreshKind tcEnv vs- kcTypeExpr tcEnv' p what doc n ty+ kcTypeExpr tcEnv' what doc n ty -kcArrow :: HasPosition p => p -> String -> Doc -> Kind -> KCM (Kind, Kind)+kcArrow :: HasSpanInfo p => p -> String -> Doc -> Kind -> KCM (Kind, Kind) kcArrow p what doc k = do theta <- getKindSubst case subst theta k of@@ -650,7 +650,7 @@ -- --------------------------------------------------------------------------- -- The unification uses Robinson's algorithm.-unify :: HasPosition p => p -> String -> Doc -> Kind -> Kind -> KCM ()+unify :: HasSpanInfo p => p -> String -> Doc -> Kind -> Kind -> KCM () unify p what doc k1 k2 = do theta <- getKindSubst let k1' = subst theta k1@@ -710,9 +710,9 @@ errRecursiveTypes :: [Ident] -> Message errRecursiveTypes [] = internalError "KindCheck.errRecursiveTypes: empty list"-errRecursiveTypes [tc] = posMessage tc $ hsep $ map text+errRecursiveTypes [tc] = spanInfoMessage tc $ hsep $ map text ["Recursive synonym or renaming type", idName tc]-errRecursiveTypes (tc:tcs) = posMessage tc $+errRecursiveTypes (tc:tcs) = spanInfoMessage tc $ text "Mutually recursive synonym and/or renaming types" <+> text (idName tc) <> types empty tcs where@@ -725,9 +725,9 @@ errRecursiveClasses :: [Ident] -> Message errRecursiveClasses [] = internalError "KindCheck.errRecursiveClasses: empty list"-errRecursiveClasses [cls] = posMessage cls $ hsep $ map text+errRecursiveClasses [cls] = spanInfoMessage cls $ hsep $ map text ["Recursive type class", idName cls]-errRecursiveClasses (cls:clss) = posMessage cls $+errRecursiveClasses (cls:clss) = spanInfoMessage cls $ text "Mutually recursive type classes" <+> text (idName cls) <> classes empty clss where@@ -737,15 +737,15 @@ classPos cls' = text (idName cls') <+> parens (text $ showLine $ getPosition cls') -errNonArrowKind :: HasPosition p => p -> String -> Doc -> Kind -> Message-errNonArrowKind p what doc k = posMessage p $ vcat+errNonArrowKind :: HasSpanInfo p => p -> String -> Doc -> Kind -> Message+errNonArrowKind p what doc k = spanInfoMessage p $ vcat [ text "Kind error in" <+> text what, doc , text "Kind:" <+> ppKind k , text "Cannot be applied" ] -errPartialAlias :: HasPosition p => p -> QualIdent -> Int -> Int -> Message-errPartialAlias p tc arity argc = posMessage p $ hsep+errPartialAlias :: HasSpanInfo p => p -> QualIdent -> Int -> Int -> Message+errPartialAlias p tc arity argc = spanInfoMessage p $ hsep [ text "Type synonym", ppQIdent tc , text "requires at least" , int arity, text (plural arity "argument") <> comma@@ -754,8 +754,8 @@ where plural n x = if n == 1 then x else x ++ "s" -errKindMismatch :: HasPosition p => p -> String -> Doc -> Kind -> Kind -> Message-errKindMismatch p what doc k1 k2 = posMessage p $ vcat+errKindMismatch :: HasSpanInfo p => p -> String -> Doc -> Kind -> Kind -> Message+errKindMismatch p what doc k1 k2 = spanInfoMessage p $ vcat [ text "Kind error in" <+> text what, doc , text "Inferred kind:" <+> ppKind k2 , text "Expected kind:" <+> ppKind k1
src/Checks/PrecCheck.hs view
@@ -37,7 +37,7 @@ import Curry.Syntax import Base.Expr-import Base.Messages (Message, posMessage, internalError)+import Base.Messages (Message, spanInfoMessage, internalError) import Base.Utils (findMultiples) import Env.OpPrec (OpPrecEnv, OpPrec (..), PrecInfo (..), defaultP, bindP@@ -94,7 +94,7 @@ opss -> mapM_ (report . errMultiplePrecedence) opss where (fixDs, nonFixDs) = partition isInfixDecl ds0- innerDs = [ d | ClassDecl _ _ _ _ ds <- ds0, d <- ds ]+ innerDs = [ d | ClassDecl _ _ _ _ _ ds <- ds0, d <- ds ] opFixDecls = [ op | InfixDecl _ _ _ ops <- fixDs, op <- ops ] -- Unrenaming is necessary for inner class declarations, because operators -- within class declarations have been renamed during syntax checking.@@ -136,10 +136,10 @@ FunctionDecl p a f <$> mapM checkEquation eqs checkDecl (PatternDecl p t rhs) = PatternDecl p <$> checkPattern t <*> checkRhs rhs-checkDecl (ClassDecl p cx cls tv ds) =- ClassDecl p cx cls tv <$> mapM checkDecl ds-checkDecl (InstanceDecl p cx qcls inst ds) =- InstanceDecl p cx qcls inst <$> mapM checkDecl ds+checkDecl (ClassDecl p li cx cls tv ds) =+ ClassDecl p li cx cls tv <$> mapM checkDecl ds+checkDecl (InstanceDecl p li cx qcls inst ds) =+ InstanceDecl p li cx qcls inst <$> mapM checkDecl ds checkDecl d = return d checkEquation :: Equation a -> PCM (Equation a)@@ -188,10 +188,10 @@ RecordPattern spi a c <$> mapM (checkField checkPattern) fs checkRhs :: Rhs a -> PCM (Rhs a)-checkRhs (SimpleRhs spi e ds) = withLocalPrecEnv $- flip (SimpleRhs spi) <$> checkDecls ds <*> checkExpr e-checkRhs (GuardedRhs spi es ds) = withLocalPrecEnv $- flip (GuardedRhs spi) <$> checkDecls ds <*> mapM checkCondExpr es+checkRhs (SimpleRhs spi li e ds) = withLocalPrecEnv $+ flip (SimpleRhs spi li) <$> checkDecls ds <*> checkExpr e+checkRhs (GuardedRhs spi li es ds) = withLocalPrecEnv $+ flip (GuardedRhs spi li) <$> checkDecls ds <*> mapM checkCondExpr es checkCondExpr :: CondExpr a -> PCM (CondExpr a) checkCondExpr (CondExpr p g e) = CondExpr p <$> checkExpr g <*> checkExpr e@@ -223,23 +223,26 @@ e1' <- checkExpr e1 e2' <- checkExpr e2 fixPrec spi e1' op e2'-checkExpr (LeftSection spi e op) = checkExpr e >>= checkLSection spi op-checkExpr (RightSection spi op e) = checkExpr e >>= checkRSection spi op-checkExpr (Lambda spi ts e) =+checkExpr (LeftSection spi e op) = checkExpr e >>= checkLSection spi op+checkExpr (RightSection spi op e) = checkExpr e >>= checkRSection spi op+checkExpr (Lambda spi ts e) = Lambda spi <$> mapM checkPattern ts <*> checkExpr e-checkExpr (Let spi ds e) = withLocalPrecEnv $- Let spi <$> checkDecls ds <*> checkExpr e-checkExpr (Do spi sts e) = withLocalPrecEnv $- Do spi <$> mapM checkStmt sts <*> checkExpr e+checkExpr (Let spi li ds e) = withLocalPrecEnv $+ Let spi li <$> checkDecls ds <*> checkExpr e+checkExpr (Do spi li sts e) = withLocalPrecEnv $+ Do spi li <$> mapM checkStmt sts <*> checkExpr e checkExpr (IfThenElse spi e1 e2 e3) = IfThenElse spi <$> checkExpr e1 <*> checkExpr e2 <*> checkExpr e3-checkExpr (Case spi ct e alts) =- Case spi ct <$> checkExpr e <*> mapM checkAlt alts+checkExpr (Case spi li ct e alts) =+ Case spi li ct <$> checkExpr e <*> mapM checkAlt alts checkStmt :: Statement a -> PCM (Statement a)-checkStmt (StmtExpr spi e) = StmtExpr spi <$> checkExpr e-checkStmt (StmtDecl spi ds) = StmtDecl spi <$> checkDecls ds-checkStmt (StmtBind spi t e) = StmtBind spi <$> checkPattern t <*> checkExpr e+checkStmt (StmtExpr spi e) =+ StmtExpr spi <$> checkExpr e+checkStmt (StmtDecl spi li ds) =+ StmtDecl spi li <$> checkDecls ds+checkStmt (StmtBind spi t e) =+ StmtBind spi <$> checkPattern t <*> checkExpr e checkAlt :: Alt a -> PCM (Alt a) checkAlt (Alt p t rhs) = Alt p <$> checkPattern t <*> checkRhs rhs@@ -488,18 +491,18 @@ -- --------------------------------------------------------------------------- errUndefinedOperator :: Ident -> Message-errUndefinedOperator op = posMessage op $ hsep $ map text+errUndefinedOperator op = spanInfoMessage op $ hsep $ map text ["No definition for", escName op, "in this scope"] errMultiplePrecedence :: [Ident] -> Message errMultiplePrecedence [] = internalError "PrecCheck.errMultiplePrecedence: empty list"-errMultiplePrecedence (op:ops) = posMessage op $+errMultiplePrecedence (op:ops) = spanInfoMessage op $ (hsep $ map text ["More than one fixity declaration for", escName op, "at"]) $+$ nest 2 (vcat (map (ppPosition . getPosition) (op:ops))) errInvalidParse :: String -> Ident -> QualIdent -> Message-errInvalidParse what op1 op2 = posMessage op1 $ hsep $ map text+errInvalidParse what op1 op2 = spanInfoMessage op1 $ hsep $ map text [ "Invalid use of", what, escName op1, "with", escQualName op2, "in" , showLine $ getPosition op2] @@ -507,6 +510,6 @@ -- TODO: Is this still true after span update for parser? errAmbiguousParse :: String -> QualIdent -> QualIdent -> Message-errAmbiguousParse what op1 op2 = posMessage op1 $ hsep $ map text+errAmbiguousParse what op1 op2 = spanInfoMessage op1 $ hsep $ map text ["Ambiguous use of", what, escQualName op1, "with", escQualName op2, "in" , showLine $ getPosition op2]
src/Checks/SyntaxCheck.hs view
@@ -34,34 +34,36 @@ import Control.Applicative ((<$>), (<*>)) #endif -import Control.Monad (unless, when)-import qualified Control.Monad.State as S ( State, runState, gets, modify- , withState )-import Data.Function (on)-import Data.List (insertBy, intersect, nub, nubBy)-import qualified Data.Map as Map ( Map, empty, findWithDefault- , fromList, insertWith, keys )-import Data.Maybe (isJust, isNothing)-import qualified Data.Set as Set ( Set, empty, insert, member- , singleton, toList, union)+import Control.Monad (unless, when)+import qualified Control.Monad.State as S (State, gets, modify, runState,+ withState)+import Data.Function (on)+import Data.List (insertBy, intersect, nub, nubBy)+import qualified Data.Map as Map (Map, empty, findWithDefault,+ fromList, insertWith, keys)+import Data.Maybe (isJust, isNothing)+import qualified Data.Set as Set (Set, empty, insert, member,+ singleton, toList, union) -import Curry.Base.Ident-import Curry.Base.Position-import Curry.Base.Pretty-import Curry.Base.Span-import Curry.Base.SpanInfo-import Curry.Syntax-import Curry.Syntax.Pretty (ppPattern)+import Curry.Base.Ident+import Curry.Base.Position+import Curry.Base.Pretty+import Curry.Base.Span+import Curry.Base.SpanInfo+import Curry.Syntax -import Base.Expr-import Base.Messages (Message, posMessage, internalError)-import Base.NestEnv-import Base.SCC (scc)-import Base.Utils ((++!), findDouble, findMultiples)+import Base.Expr+import Base.Messages (Message, internalError,+ spanInfoMessage)+import Base.NestEnv+import Base.SCC (scc)+import Base.Utils (findDouble, findMultiples, (++!)) -import Env.TypeConstructor (TCEnv, clsMethods)-import Env.Value (ValueEnv, ValueInfo (..))+import Env.TypeConstructor (TCEnv, clsMethods, getOrigName)+import Env.Value (ValueEnv, ValueInfo (..),+ qualLookupValueUnique) + -- The syntax checking proceeds as follows. First, the compiler extracts -- information about all imported values and data constructors from the -- imported (type) environments. Next, the data constructors defined in@@ -77,7 +79,7 @@ syntaxCheck :: [KnownExtension] -> TCEnv -> ValueEnv -> Module () -> ((Module (), [KnownExtension]), [Message])-syntaxCheck exts tcEnv vEnv mdl@(Module _ _ m _ _ ds) =+syntaxCheck exts tcEnv vEnv mdl@(Module _ _ _ m _ _ ds) = case findMultiples cons of [] -> case findMultiples (ls ++ fs ++ cons ++ cs) of [] -> runSC (checkModule mdl) state@@ -90,9 +92,9 @@ cons = concatMap constrs tds ls = nub $ concatMap recLabels tds fs = nub $ concatMap vars vds- cs = concatMap (concatMap methods) [ds' | ClassDecl _ _ _ _ ds' <- cds]+ cs = concatMap (concatMap methods) [ds' | ClassDecl _ _ _ _ _ ds' <- cds] rEnv = globalEnv $ fmap renameInfo vEnv- state = initState exts m tcEnv rEnv+ state = initState exts m tcEnv rEnv vEnv -- A global state transformer is used for generating fresh integer keys with -- which the variables are renamed.@@ -109,6 +111,7 @@ , moduleIdent :: ModuleIdent -- ^ 'ModuleIdent' of the current module , tyConsEnv :: TCEnv , renameEnv :: RenameEnv -- ^ Information store+ , valueEnv :: ValueEnv -- ^ To check instance method visibility , scopeId :: Integer -- ^ Identifier for the current scope , nextId :: Integer -- ^ Next fresh identifier , funcDeps :: FuncDeps -- ^ Stores data about functions dependencies@@ -117,9 +120,10 @@ } -- |Initial syntax check state-initState :: [KnownExtension] -> ModuleIdent -> TCEnv -> RenameEnv -> SCState-initState exts m tcEnv rEnv =- SCState exts m tcEnv rEnv globalScopeId 1 noFuncDeps False []+initState :: [KnownExtension] -> ModuleIdent -> TCEnv -> RenameEnv -> ValueEnv+ -> SCState+initState exts m tcEnv rEnv vEnv =+ SCState exts m tcEnv rEnv vEnv globalScopeId 1 noFuncDeps False [] -- |Identifier for global (top-level) declarations globalScopeId :: Integer@@ -154,6 +158,10 @@ getRenameEnv :: SCM RenameEnv getRenameEnv = S.gets renameEnv +-- |Retrieve the 'ValueEnv'+getValueEnv :: SCM ValueEnv+getValueEnv = S.gets valueEnv+ -- |Modify the 'RenameEnv' modifyRenameEnv :: (RenameEnv -> RenameEnv) -> SCM () modifyRenameEnv f = S.modify $ \s -> s { renameEnv = f $ renameEnv s }@@ -361,7 +369,7 @@ bindRecordLabel :: (Ident, [Ident]) -> SCM () bindRecordLabel (l, cs) = do m <- getModuleIdent- new <- (null . lookupVar l) <$> getRenameEnv+ new <- null . lookupVar l <$> getRenameEnv unless new $ report $ errDuplicateDefinition l modifyRenameEnv $ bindGlobal False m l $ RecordLabel (qualifyWith m l) (map (qualifyWith m) cs)@@ -376,7 +384,7 @@ = let arty = length $ snd $ getFlatLhs eq in bindGlobal tcc m f (GlobalVar (qualifyWith m f) arty) env bindFuncDecl tcc m (TypeSig _ fs (QualTypeExpr _ _ ty)) env- = foldr bindTS env $ map (qualifyWith m) fs+ = foldr (bindTS . qualifyWith m) env fs where bindTS qf env' | null $ qualLookupVar qf env'@@ -388,8 +396,8 @@ -- |Bind type class information, i.e. class methods bindClassDecl :: Decl a -> SCM ()-bindClassDecl (ClassDecl _ _ _ _ ds) = mapM_ bindClassMethod ds-bindClassDecl _ = ok+bindClassDecl (ClassDecl _ _ _ _ _ ds) = mapM_ bindClassMethod ds+bindClassDecl _ = ok bindClassMethod :: Decl a -> SCM () bindClassMethod ts@(TypeSig _ _ _) = do@@ -406,8 +414,7 @@ | otherwise = let arty = length $ snd $ getFlatLhs $ head eqs in bindLocal (unRenameIdent f) (LocalVar f arty) env bindVarDecl (PatternDecl _ t _) env = foldr bindVar env (bv t)-bindVarDecl (FreeDecl _ vs) env =- foldr bindVar env (map varIdent vs)+bindVarDecl (FreeDecl _ vs) env = foldr (bindVar . varIdent) env vs bindVarDecl _ env = env bindVar :: Ident -> RenameEnv -> RenameEnv@@ -447,7 +454,7 @@ -- declaration are allowed to be declared). checkModule :: Module () -> SCM (Module (), [KnownExtension])-checkModule (Module spi ps m es is ds) = do+checkModule (Module spi li ps m es is ds) = do mapM_ bindTypeDecl tds mapM_ bindClassDecl cds ds' <- checkTopDecls ds@@ -456,7 +463,7 @@ let ds'' = updateClassAndInstanceDecls cds' ids' ds' checkFuncPatDeps exts <- getExtensions- return (Module spi ps m es is ds'', exts)+ return (Module spi li ps m es is ds'', exts) where tds = filter isTypeDecl ds cds = filter isClassDecl ds ids = filter isInstanceDecl ds@@ -468,7 +475,7 @@ fps <- getFuncPats deps <- getGlobalDeps let levels = scc (:[])- (\k -> Set.toList (Map.findWithDefault (Set.empty) k deps))+ (\k -> Set.toList (Map.findWithDefault Set.empty k deps)) (Map.keys deps) levelMap = Map.fromList [ (f, l) | (fs, l) <- zip levels [1 ..], f <- fs ] level f = Map.findWithDefault (0 :: Int) f levelMap@@ -485,21 +492,48 @@ checkDeclGroup (bindFuncDecl tcc m) ds checkClassDecl :: Decl () -> SCM (Decl ())-checkClassDecl (ClassDecl p cx cls tv ds) = do+checkClassDecl (ClassDecl p li cx cls tv ds) = do checkMethods (qualify cls) (concatMap methods ds) ds- ClassDecl p cx cls tv <$> checkTopDecls ds+ ClassDecl p li cx cls tv <$> checkTopDecls ds checkClassDecl _ = internalError "SyntaxCheck.checkClassDecl: no class declaration" checkInstanceDecl :: Decl () -> SCM (Decl ())-checkInstanceDecl (InstanceDecl p cx qcls ty ds) = do+checkInstanceDecl (InstanceDecl p li cx qcls ty ds) = do m <- getModuleIdent+ vEnv <- getValueEnv tcEnv <- getTyConsEnv- checkMethods qcls (clsMethods m qcls tcEnv) ds- InstanceDecl p cx qcls ty <$> checkTopDecls ds+ let clsMthds = clsMethods m qcls tcEnv+ let orig = getOrigName m qcls tcEnv+ let mthds =+ if isLocalIdent m orig+ then clsMthds+ else filter (isFromCls orig m vEnv) clsMthds+ checkMethods qcls mthds ds+ mapM_ checkAmbiguousMethod ds+ InstanceDecl p li cx qcls ty <$> checkTopDecls ds+ where+ isFromCls orig m vEnv f = case qualLookupValueUnique m (qualify f) vEnv of+ [Value _ (Just cls) _ _]+ | cls == orig -> True+ _ -> False+ checkInstanceDecl _ = internalError "SyntaxCheck.checkInstanceDecl: no instance declaration" +checkAmbiguousMethod :: Decl a -> SCM ()+checkAmbiguousMethod (FunctionDecl _ _ f _) = do+ m <- getModuleIdent+ rename <- getRenameEnv+ case lookupVar f rename of+ rs1@(_:_:_) -> case qualLookupVar (qualifyWith m f) rename of+ [] -> report $ errAmbiguousIdent rs1 (qualify f)+ rs2@(_:_:_) -> report $ errAmbiguousIdent rs2 (qualify f)+ _ -> return ()+ _ -> return ()+checkAmbiguousMethod _ =+ internalError "SyntaxCheck.checkAmbiguousMethod: no function declaration"+ checkMethods :: QualIdent -> [Ident] -> [Decl a] -> SCM () checkMethods qcls ms ds = mapM_ (report . errUndefinedMethod qcls) $ filter (`notElem` ms) fs@@ -507,9 +541,9 @@ updateClassAndInstanceDecls :: [Decl a] -> [Decl a] -> [Decl a] -> [Decl a] updateClassAndInstanceDecls [] [] ds = ds-updateClassAndInstanceDecls (c:cs) is (ClassDecl _ _ _ _ _:ds) =+updateClassAndInstanceDecls (c:cs) is (ClassDecl _ _ _ _ _ _:ds) = c : updateClassAndInstanceDecls cs is ds-updateClassAndInstanceDecls cs (i:is) (InstanceDecl _ _ _ _ _:ds) =+updateClassAndInstanceDecls cs (i:is) (InstanceDecl _ _ _ _ _ _:ds) = i : updateClassAndInstanceDecls cs is ds updateClassAndInstanceDecls cs is (d:ds) = d : updateClassAndInstanceDecls cs is ds@@ -555,7 +589,7 @@ checkPrecedence _ Nothing = return Nothing checkPrecedence p (Just i) = do unless (0 <= i && i <= 9) $ report- $ errPrecedenceOutOfRange (spanInfo2Pos p) i+ $ errPrecedenceOutOfRange p i return $ Just i checkVar' :: String -> Var a -> SCM (Var a)@@ -589,7 +623,7 @@ | not $ isDataConstr f env -> return left | k /= globalScopeId -> return right | null infos -> return left- | otherwise -> do report $ errToplevelPattern p+ | otherwise -> do report $ errToplevelPattern pspi return right where f' = renameIdent f k infos = qualLookupVar (qualifyWith m f) env@@ -600,7 +634,7 @@ | not $ isDataConstr op env -> return left | k /= globalScopeId -> return right | null infos -> return left- | otherwise -> do report $ errToplevelPattern p+ | otherwise -> do report $ errToplevelPattern pspi return right where op' = renameIdent op k infos = qualLookupVar (qualifyWith m op) env@@ -620,7 +654,6 @@ r -> do report $ errNonVariable "curried definition" f return $ r where (f, _) = flatLhs lhs- where p = spanInfo2Pos pspi checkOpLhs :: Integer -> RenameEnv -> (Pattern a -> Pattern a) -> Pattern a -> Either (Ident, Lhs a) (Pattern a)@@ -704,7 +737,7 @@ checkLhs p (OpLhs spi t1 op t2) = do let wrongCalls = concatMap (checkParenPattern (Just $ qualify op)) [t1,t2] unless (null wrongCalls) $ report $ errInfixWithoutParens- (getPosition op) wrongCalls+ spi wrongCalls flip (OpLhs spi) op <$> checkPattern p t1 <*> checkPattern p t2 checkLhs p (ApLhs spi lhs ts) = ApLhs spi <$> checkLhs p lhs <*> mapM (checkPattern p) ts@@ -747,7 +780,7 @@ checkPattern _ (NegativePattern spi a l) = return $ NegativePattern spi a l checkPattern p (VariablePattern spi a v)- | isAnonId v = (VariablePattern spi a . renameIdent v) <$> newId+ | isAnonId v = VariablePattern spi a . renameIdent v <$> newId | otherwise = checkConstructorPattern p spi (qualify v) [] checkPattern p (ConstructorPattern spi _ c ts) = checkConstructorPattern p spi c ts@@ -767,9 +800,9 @@ t' <- checkPattern p t banFPTerm "lazy pattern" p t' return (LazyPattern spi t')-checkPattern _ (FunctionPattern _ _ _ _) = internalError $+checkPattern _ (FunctionPattern _ _ _ _) = internalError "SyntaxCheck.checkPattern: function pattern not defined"-checkPattern _ (InfixFuncPattern _ _ _ _ _) = internalError $+checkPattern _ (InfixFuncPattern _ _ _ _ _) = internalError "SyntaxCheck.checkPattern: infix function pattern not defined" checkConstructorPattern :: SpanInfo -> SpanInfo -> QualIdent -> [Pattern ()]@@ -803,16 +836,11 @@ | null ts && not (isQualified c) = return $ VariablePattern spi () $ renameIdent (unqualify c) k -- (varIdent r) k | otherwise = do- let n = arity r- checkFuncPatsExtension (spanInfo2Pos p)+ checkFuncPatsExtension p checkFuncPatCall r c ts' <- mapM (checkPattern p) ts mapM_ (checkFPTerm p) ts'- return $ if n' > n- then let (ts1, ts2) = splitAt n ts'- in genFuncPattAppl- (FunctionPattern spi () (qualVarIdent r) ts1) ts2- else FunctionPattern spi () (qualVarIdent r) ts'+ return $ FunctionPattern spi () (qualVarIdent r) ts' checkInfixPattern :: SpanInfo -> SpanInfo -> Pattern () -> QualIdent -> Pattern () -> SCM (Pattern ())@@ -835,7 +863,7 @@ when (n /= 2) $ report $ errWrongArity op n 2 flip (InfixPattern spi ()) qop <$> checkPattern p t1 <*> checkPattern p t2 funcPattern r qop = do- checkFuncPatsExtension (spanInfo2Pos p)+ checkFuncPatsExtension p checkFuncPatCall r qop ts' <- mapM (checkPattern p) [t1,t2] let [t1',t2'] = ts'@@ -871,10 +899,14 @@ -- Note: process decls first checkRhs :: Rhs () -> SCM (Rhs ())-checkRhs (SimpleRhs spi e ds) = inNestedScope $- flip (SimpleRhs spi) <$> checkDeclGroup bindVarDecl ds <*> checkExpr spi e-checkRhs (GuardedRhs spi es ds) = inNestedScope $- flip (GuardedRhs spi) <$> checkDeclGroup bindVarDecl ds <*> mapM checkCondExpr es+checkRhs (SimpleRhs spi li e ds) = inNestedScope $+ flip (SimpleRhs spi li) <$>+ checkDeclGroup bindVarDecl ds <*>+ checkExpr spi e+checkRhs (GuardedRhs spi li es ds) = inNestedScope $+ flip (GuardedRhs spi li) <$>+ checkDeclGroup bindVarDecl ds <*>+ mapM checkCondExpr es checkCondExpr :: CondExpr () -> SCM (CondExpr ()) checkCondExpr (CondExpr spi g e) = CondExpr spi <$> checkExpr spi g <*> checkExpr spi e@@ -909,14 +941,14 @@ checkExpr p (RightSection spi op e) = RightSection spi <$> checkOp op <*> checkExpr p e checkExpr p (Lambda spi ts e) = inNestedScope $ checkLambda p spi ts e-checkExpr p (Let spi ds e) = inNestedScope $- Let spi <$> checkDeclGroup bindVarDecl ds <*> checkExpr p e-checkExpr p (Do spi sts e) = withLocalEnv $- Do spi <$> mapM (checkStatement "do sequence" p) sts <*> checkExpr p e+checkExpr p (Let spi li ds e) = inNestedScope $+ Let spi li <$> checkDeclGroup bindVarDecl ds <*> checkExpr p e+checkExpr p (Do spi li sts e) = withLocalEnv $+ Do spi li <$> mapM (checkStatement "do sequence" p) sts <*> checkExpr p e checkExpr p (IfThenElse spi e1 e2 e3) = IfThenElse spi <$> checkExpr p e1 <*> checkExpr p e2 <*> checkExpr p e3-checkExpr p (Case spi ct e alts) =- Case spi ct <$> checkExpr p e <*> mapM checkAlt alts+checkExpr p (Case spi li ct e alts) =+ Case spi li ct <$> checkExpr p e <*> mapM checkAlt alts checkLambda :: SpanInfo -> SpanInfo -> [Pattern ()] -> Expression () -> SCM (Expression ())@@ -936,8 +968,8 @@ checkVariable spi a v -- anonymous free variable | isAnonId (unqualify v) = do- checkAnonFreeVarsExtension $ getPosition v- (\n -> Variable spi a $ updQualIdent id (flip renameIdent n) v) <$> newId+ checkAnonFreeVarsExtension $ getSpanInfo v+ (\n -> Variable spi a $ updQualIdent id (`renameIdent` n) v) <$> newId -- return $ Variable v -- normal variable | otherwise = do@@ -947,7 +979,9 @@ return $ Variable spi a v [Constr _ _] -> return $ Constructor spi a v [GlobalVar f _] -> addGlobalDep f >> return (Variable spi a v)- [LocalVar v' _] -> return $ Variable spi a $ qualify v' @> v+ [LocalVar v' _] -> return $ Variable spi a+ $ qualify+ $ spanInfoLike v' (qidIdent v) [RecordLabel _ _] -> return $ Variable spi a v rs -> do m <- getModuleIdent@@ -956,7 +990,9 @@ return $ Variable spi a v [Constr _ _] -> return $ Constructor spi a v [GlobalVar f _] -> addGlobalDep f >> return (Variable spi a v)- [LocalVar v' _] -> return $ Variable spi a $ qualify v' @> v+ [LocalVar v' _] -> return $ Variable spi a+ $ qualify+ $ spanInfoLike v' (qidIdent v) [RecordLabel _ _] -> return $ Variable spi a v rs' -> do report $ errAmbiguousIdent rs' v return $ Variable spi a v@@ -995,11 +1031,11 @@ -- * Because statements are processed list-wise, inNestedEnv can not be -- used as this nesting must be visible to following statements. checkStatement :: String -> SpanInfo -> Statement () -> SCM (Statement ())-checkStatement _ p (StmtExpr spi e) = StmtExpr spi <$> checkExpr p e-checkStatement s p (StmtBind spi t e) =+checkStatement _ p (StmtExpr spi e) = StmtExpr spi <$> checkExpr p e+checkStatement s p (StmtBind spi t e) = flip (StmtBind spi) <$> checkExpr p e <*> (incNesting >> bindPattern s p t)-checkStatement _ _ (StmtDecl spi ds) =- StmtDecl spi <$> (incNesting >> checkDeclGroup bindVarDecl ds)+checkStatement _ _ (StmtDecl spi li ds) =+ StmtDecl spi li <$> (incNesting >> checkDeclGroup bindVarDecl ds) bindPattern :: String -> SpanInfo -> Pattern () -> SCM (Pattern ()) bindPattern s p t = do@@ -1021,9 +1057,9 @@ banFPTerm s p (AsPattern _ _ t) = banFPTerm s p t banFPTerm s p (LazyPattern _ t) = banFPTerm s p t banFPTerm s p pat@(FunctionPattern _ _ _ _)- = report $ errUnsupportedFuncPattern s (spanInfo2Pos p) pat+ = report $ errUnsupportedFuncPattern s p pat banFPTerm s p pat@(InfixFuncPattern _ _ _ _ _)- = report $ errUnsupportedFuncPattern s (spanInfo2Pos p) pat+ = report $ errUnsupportedFuncPattern s p pat checkOp :: InfixOp a -> SCM (InfixOp a) checkOp op = do@@ -1101,9 +1137,10 @@ [l | (l, cs) <- zip ls css, c' `notElem` cs] _ -> internalError $ "Checks.SyntaxCheck.checkLabels: " ++ show c-checkLabels p Nothing ls css =- when (null (foldr1 intersect css))- $ report $ errNoCommonCons (spanInfo2Pos p) ls+checkLabels p Nothing ls css+ | not (null (foldr1 intersect css)) ||+ any null css = ok+ | otherwise = report $ errNoCommonCons p ls checkField :: (a -> SCM a) -> Field a -> SCM (Field a) checkField check (Field p l x) = Field p l <$> check x@@ -1134,7 +1171,7 @@ -- it is necessary to sort the list of declarations. sortFuncDecls :: [Decl a] -> [Decl a]-sortFuncDecls decls = sortFD Set.empty [] decls+sortFuncDecls = sortFD Set.empty [] where sortFD _ res [] = reverse res sortFD env res (decl : decls') = case decl of@@ -1191,23 +1228,6 @@ qualVarIdent (LocalVar v _) = qualify v qualVarIdent _ = internalError "SyntaxCheck.qualVarIdent: no variable" -arity :: RenameInfo -> Int-arity (Constr _ n) = n-arity (GlobalVar _ n) = n-arity (LocalVar _ n) = n-arity (RecordLabel _ _) = 1---- Unlike expressions, constructor terms have no possibility to represent--- over-applications in functional patterns. Therefore it is necessary to--- transform them to nested function patterns using the prelude function--- apply. E.g., the function pattern (id id 10) is transformed to--- (apply (id id) 10).--genFuncPattAppl :: Pattern () -> [Pattern ()] -> Pattern ()-genFuncPattAppl term [] = term-genFuncPattAppl term (t:ts)- = FunctionPattern NoSpanInfo () qApplyId [genFuncPattAppl term ts, t] -- TODO FIXME major problem- checkFPTerm :: SpanInfo -> Pattern a -> SCM () checkFPTerm _ (LiteralPattern _ _ _) = ok checkFPTerm _ (NegativePattern _ _ _) = ok@@ -1219,7 +1239,7 @@ checkFPTerm p (ListPattern _ _ ts) = mapM_ (checkFPTerm p) ts checkFPTerm p (AsPattern _ _ t) = checkFPTerm p t checkFPTerm p t@(LazyPattern _ _) =- report $ errUnsupportedFPTerm "Lazy" (spanInfo2Pos p) t+ report $ errUnsupportedFPTerm "Lazy" p t checkFPTerm p (RecordPattern _ _ _ fs) = mapM_ (checkFPTerm p) [ t | Field _ _ t <- fs ] checkFPTerm _ (FunctionPattern _ _ _ _) = ok -- do not check again@@ -1229,19 +1249,19 @@ -- Miscellaneous functions -- --------------------------------------------------------------------------- -checkFuncPatsExtension :: Position -> SCM ()-checkFuncPatsExtension p = checkUsedExtension p+checkFuncPatsExtension :: SpanInfo -> SCM ()+checkFuncPatsExtension spi = checkUsedExtension spi "Functional Patterns" FunctionalPatterns -checkAnonFreeVarsExtension :: Position -> SCM ()-checkAnonFreeVarsExtension p = checkUsedExtension p+checkAnonFreeVarsExtension :: SpanInfo -> SCM ()+checkAnonFreeVarsExtension spi = checkUsedExtension spi "Anonymous free variables" AnonFreeVars -checkUsedExtension :: Position -> String -> KnownExtension -> SCM ()-checkUsedExtension pos msg ext = do+checkUsedExtension :: SpanInfo -> String -> KnownExtension -> SCM ()+checkUsedExtension spi msg ext = do enabled <- hasExtension ext unless enabled $ do- report $ errMissingLanguageExtension pos msg ext+ report $ errMissingLanguageExtension spi msg ext enableExtension ext -- to avoid multiple warnings typeArity :: TypeExpr -> Int@@ -1259,43 +1279,43 @@ -- Error messages -- --------------------------------------------------------------------------- -errUnsupportedFPTerm :: String -> Position -> Pattern a -> Message-errUnsupportedFPTerm s p pat = posMessage p $ text s+errUnsupportedFPTerm :: String -> SpanInfo -> Pattern a -> Message+errUnsupportedFPTerm s spi pat = spanInfoMessage spi $ text s <+> text "patterns are not supported inside a functional pattern."- $+$ ppPattern 0 pat+ $+$ pPrintPrec 0 pat -errUnsupportedFuncPattern :: String -> Position -> Pattern a -> Message-errUnsupportedFuncPattern s p pat = posMessage p $+errUnsupportedFuncPattern :: String -> SpanInfo -> Pattern a -> Message+errUnsupportedFuncPattern s spi pat = spanInfoMessage spi $ text "Functional patterns are not supported inside a" <+> text s <> dot- $+$ ppPattern 0 pat+ $+$ pPrintPrec 0 pat errFuncPatNotGlobal :: QualIdent -> Message-errFuncPatNotGlobal f = posMessage f $ hsep $ map text+errFuncPatNotGlobal f = spanInfoMessage f $ hsep $ map text ["Function", escQualName f, "in functional pattern is not global"] errFuncPatCyclic :: QualIdent -> QualIdent -> Message-errFuncPatCyclic fp f = posMessage fp $ hsep $ map text+errFuncPatCyclic fp f = spanInfoMessage fp $ hsep $ map text [ "Function", escName $ unqualify fp, "used in functional pattern depends on" , escName $ unqualify f, " causing a cyclic dependency"] -errPrecedenceOutOfRange :: Position -> Integer -> Message-errPrecedenceOutOfRange p i = posMessage p $ hsep $ map text+errPrecedenceOutOfRange :: SpanInfo -> Integer -> Message+errPrecedenceOutOfRange spi i = spanInfoMessage spi $ hsep $ map text ["Precedence out of range:", show i] errUndefinedVariable :: QualIdent -> Message-errUndefinedVariable v = posMessage v $ hsep $ map text+errUndefinedVariable v = spanInfoMessage v $ hsep $ map text [escQualName v, "is undefined"] errUndefinedData :: QualIdent -> Message-errUndefinedData c = posMessage c $ hsep $ map text+errUndefinedData c = spanInfoMessage c $ hsep $ map text ["Undefined data constructor", escQualName c] errUndefinedLabel :: QualIdent -> Message-errUndefinedLabel l = posMessage l $ hsep $ map text+errUndefinedLabel l = spanInfoMessage l $ hsep $ map text ["Undefined record label", escQualName l] errUndefinedMethod :: QualIdent -> Ident -> Message-errUndefinedMethod qcls f = posMessage f $ hsep $ map text+errUndefinedMethod qcls f = spanInfoMessage f $ hsep $ map text [escName f, "is not a (visible) method of class", escQualName qcls] errAmbiguousIdent :: [RenameInfo] -> QualIdent -> Message@@ -1310,26 +1330,26 @@ errAmbiguousLabel = errAmbiguous "field label" errAmbiguous :: String -> [RenameInfo] -> QualIdent -> Message-errAmbiguous what rs qn = posMessage qn+errAmbiguous what rs qn = spanInfoMessage qn $ text "Ambiguous" <+> text what <+> text (escQualName qn) $+$ text "It could refer to:" $+$ nest 2 (vcat (map ppRenameInfo rs)) errDuplicateDefinition :: Ident -> Message-errDuplicateDefinition v = posMessage v $ hsep $ map text+errDuplicateDefinition v = spanInfoMessage v $ hsep $ map text ["More than one definition for", escName v] errDuplicateVariables :: [Ident] -> Message errDuplicateVariables [] = internalError "SyntaxCheck.errDuplicateVariables: empty list"-errDuplicateVariables (v:vs) = posMessage v $+errDuplicateVariables (v:vs) = spanInfoMessage v $ text (escName v) <+> text "occurs more than one in pattern at:" $+$ nest 2 (vcat (map (ppPosition . getPosition) (v:vs))) errMultipleDataConstructor :: [Ident] -> Message errMultipleDataConstructor [] = internalError "SyntaxCheck.errMultipleDataDeclaration: empty list"-errMultipleDataConstructor (i:is) = posMessage i $+errMultipleDataConstructor (i:is) = spanInfoMessage i $ text "Multiple definitions for data/record constructor" <+> text (escName i) <+> text "at:" $+$ nest 2 (vcat (map (ppPosition . getPosition) (i:is)))@@ -1337,7 +1357,7 @@ errMultipleDeclarations :: ModuleIdent -> [Ident] -> Message errMultipleDeclarations _ [] = internalError "SyntaxCheck.errMultipleDeclarations: empty list"-errMultipleDeclarations m (i:is) = posMessage i $+errMultipleDeclarations m (i:is) = spanInfoMessage i $ text "Multiple declarations of" <+> text (escQualName (qualifyWith m i)) $+$ text "Declared at:" $+$ nest 2 (vcat (map (ppPosition . getPosition) (i:is)))@@ -1345,63 +1365,63 @@ errDuplicateTypeSig :: [Ident] -> Message errDuplicateTypeSig [] = internalError "SyntaxCheck.errDuplicateTypeSig: empty list"-errDuplicateTypeSig (v:vs) = posMessage v $+errDuplicateTypeSig (v:vs) = spanInfoMessage v $ text "More than one type signature for" <+> text (escName v) <+> text "at:" $+$ nest 2 (vcat (map (ppPosition . getPosition) (v:vs))) errDuplicateLabel :: String -> QualIdent -> Message-errDuplicateLabel what l = posMessage l $ hsep $ map text+errDuplicateLabel what l = spanInfoMessage l $ hsep $ map text ["Field label", escQualName l, "occurs more than once in record", what] errNonVariable :: String -> Ident -> Message-errNonVariable what c = posMessage c $ hsep $ map text+errNonVariable what c = spanInfoMessage c $ hsep $ map text ["Data constructor", escName c, "in left hand side of", what] errNoBody :: Ident -> Message-errNoBody v = posMessage v $ hsep $ map text ["No body for", escName v]+errNoBody v = spanInfoMessage v $ hsep $ map text ["No body for", escName v] -errNoCommonCons :: Position -> [QualIdent] -> Message-errNoCommonCons p ls = posMessage p $+errNoCommonCons :: SpanInfo -> [QualIdent] -> Message+errNoCommonCons spi ls = spanInfoMessage spi $ text "No constructor has all of these fields:" $+$ nest 2 (vcat (map (text . escQualName) ls)) errNoLabel :: QualIdent -> QualIdent -> Message-errNoLabel c l = posMessage l $ hsep $ map text+errNoLabel c l = spanInfoMessage l $ hsep $ map text [escQualName l, "is not a field label of constructor", escQualName c] errNoTypeSig :: Ident -> Message-errNoTypeSig f = posMessage f $ hsep $ map text+errNoTypeSig f = spanInfoMessage f $ hsep $ map text ["No type signature for external function", escName f] -errToplevelPattern :: Position -> Message-errToplevelPattern p = posMessage p $ text+errToplevelPattern :: SpanInfo -> Message+errToplevelPattern spi = spanInfoMessage spi $ text "Pattern declaration not allowed at top-level" errDifferentArity :: [Ident] -> Message errDifferentArity [] = internalError "SyntaxCheck.errDifferentArity: empty list"-errDifferentArity (i:is) = posMessage i $+errDifferentArity (i:is) = spanInfoMessage i $ text "Equations for" <+> text (escName i) <+> text "have different arities" <+> text "at:" $+$ nest 2 (vcat (map (ppPosition . getPosition) (i:is))) errWrongArity :: QualIdent -> Int -> Int -> Message-errWrongArity c arity' argc = posMessage c $ hsep (map text+errWrongArity c arity' argc = spanInfoMessage c $ hsep (map text ["Data constructor", escQualName c, "expects", arguments arity']) <> comma <+> text "but is applied to" <+> text (show argc) where arguments 0 = "no arguments" arguments 1 = "1 argument" arguments n = show n ++ " arguments" -errMissingLanguageExtension :: Position -> String -> KnownExtension -> Message-errMissingLanguageExtension p what ext = posMessage p $+errMissingLanguageExtension :: SpanInfo -> String -> KnownExtension -> Message+errMissingLanguageExtension spi what ext = spanInfoMessage spi $ text what <+> text "are not supported in standard Curry." $+$ nest 2 (text "Use flag or -X" <+> text (show ext) <+> text "to enable this extension.") -errInfixWithoutParens :: Position -> [(QualIdent, QualIdent)] -> Message-errInfixWithoutParens p calls = posMessage p $+errInfixWithoutParens :: SpanInfo -> [(QualIdent, QualIdent)] -> Message+errInfixWithoutParens spi calls = spanInfoMessage spi $ text "Missing parens in infix patterns:" $+$ vcat (map showCall calls) where
src/Checks/TypeCheck.hs view
@@ -43,12 +43,14 @@ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>), (<*>)) #endif-import Control.Monad.Extra ( (&&^), allM, filterM, foldM- , liftM, notM, replicateM, unless- , unlessM )-import qualified Control.Monad.State as S (State, runState, gets, modify)-import Data.List (nub, nubBy, partition, sortBy)-import Data.Function (on)+import Control.Monad.Trans (lift)+import Control.Monad.Extra (allM, filterM, foldM, liftM, (&&^),+ notM, replicateM, when, unless, unlessM)+import qualified Control.Monad.State as S+ (State, StateT, get, gets, put, modify,+ runState, evalStateT)+import Data.Function (on)+import Data.List (nub, nubBy, partition, sortBy, (\\)) import qualified Data.Map as Map (Map, empty, insert, lookup) import Data.Maybe (fromJust, fromMaybe, isJust) import qualified Data.Set.Extra as Set ( Set, concatMap, deleteMin, empty@@ -57,7 +59,6 @@ , toList, union, unions ) import Curry.Base.Ident-import Curry.Base.Position import Curry.Base.Pretty import Curry.Base.SpanInfo import Curry.Syntax@@ -66,7 +67,7 @@ import Base.CurryTypes import Base.Expr import Base.Kinds-import Base.Messages (Message, posMessage, internalError)+import Base.Messages (Message, spanInfoMessage, internalError) import Base.SCC import Base.TopEnv import Base.TypeExpansion@@ -134,9 +135,9 @@ (&&>) :: TCM () -> TCM () -> TCM () pre &&> suf = do errs <- pre >> S.gets errors- if null errs then suf else return ()+ when (null errs) suf -(>>-) :: TCM (a, b, c) -> (a -> b -> TCM a) -> TCM (a, c)+(>>-) :: Monad m => m (a, b, c) -> (a -> b -> m a) -> m (a, c) m >>- f = do (u, v, w) <- m u' <- f u v@@ -149,7 +150,7 @@ return (u, w, x) runTCM :: TCM a -> TcState -> (a, ValueEnv, [Message])-runTCM tcm s = let (a, s') = S.runState tcm s+runTCM tcm ts = let (a, s') = S.runState tcm ts in (a, typeSubst s' `subst` valueEnv s', reverse $ errors s') getModuleIdent :: TCM ModuleIdent@@ -300,7 +301,7 @@ ok checkFieldLabel _ = ok -tcFieldLabel :: HasPosition p => [Ident] -> (Ident, p, TypeExpr)+tcFieldLabel :: HasSpanInfo p => [Ident] -> (Ident, p, TypeExpr) -> TCM (Ident, p, Type) tcFieldLabel tvs (l, p, ty) = do m <- getModuleIdent@@ -315,7 +316,7 @@ (x, y, z : map thd3 xyzs') : groupLabels xyzs'' where (xyzs', xyzs'') = partition ((x ==) . fst3) xyzs -tcFieldLabels :: HasPosition p => (Ident, p, [Type]) -> TCM ()+tcFieldLabels :: HasSpanInfo p => (Ident, p, [Type]) -> TCM () tcFieldLabels (_, _, []) = return () tcFieldLabels (l, p, ty:tys) = unless (not (any (ty /=) tys)) $ do m <- getModuleIdent@@ -339,11 +340,11 @@ n = kindArity k labels = zip (concatMap recLabels cs) (concatMap recLabelTypes cs) clabels = [(l, constr l, ty) | (l, ty) <- labels]- constr l = map (qualifyLike tc) $- [constrIdent c | c <- cs, l `elem` recLabels c]- sameLabel (l1,_,_) (l2,_,_) = l1 == l2- bindData (RenamingType tc k (RecordConstr c [l] [lty])) vEnv' =- bindLabel m n (constrType' tc n) (l, [qc], lty) vEnv'+ constr l = [qualifyLike tc (constrIdent c)+ | c <- cs, l `elem` recLabels c]+ sameLabel (l1, _, _) (l2, _, _) = l1 == l2+ bindData (RenamingType tc k (RecordConstr c [l] [lty])) vEnv'+ = bindLabel m n (constrType' tc n) (l, [qc], lty) vEnv' where n = kindArity k qc = qualifyLike tc c@@ -371,17 +372,23 @@ bindClassMethods' m tcEnv vEnv = foldr (bindMethods . snd) vEnv $ localBindings tcEnv where- bindMethods (TypeClass _ _ ms) vEnv' =- foldr (bindClassMethod m) vEnv' ms- bindMethods _ vEnv' = vEnv'+ bindMethods (TypeClass cls _ ms) vEnv' =+ foldr (bindClassMethod m cls) vEnv' ms+ bindMethods _ vEnv' =+ vEnv' -- Since the implementations of class methods can differ in their arity, -- we assume an arity of 0 when we enter one into the value environment. -bindClassMethod :: ModuleIdent -> ClassMethod -> ValueEnv -> ValueEnv-bindClassMethod m (ClassMethod f _ pty) =- bindGlobalInfo (\qc tySc -> Value qc True 0 tySc) m f (typeScheme pty)+bindClassMethod :: ModuleIdent -> QualIdent -> ClassMethod -> ValueEnv+ -> ValueEnv+bindClassMethod m cls (ClassMethod f _ ty) =+ bindGlobalInfo (\qc tySc -> Value qc (Just cls) 0 tySc) m f (typeScheme ty) +-- -----------------------------------------------------------------------------+-- Default Types+-- -----------------------------------------------------------------------------+ -- Default Types: -- The list of default types is given either by a default declaration in -- the source code or defaults to the predefined list of numeric data types.@@ -409,30 +416,29 @@ bindTypeSig = Map.insert bindTypeSigs :: Decl a -> SigEnv -> SigEnv-bindTypeSigs (TypeSig _ vs qty) env =- foldr (flip bindTypeSig qty) env vs-bindTypeSigs _ env = env+bindTypeSigs (TypeSig _ vs ty) env = foldr (`bindTypeSig` ty) env vs+bindTypeSigs _ env = env lookupTypeSig :: Ident -> SigEnv -> Maybe QualTypeExpr lookupTypeSig = Map.lookup -- Declaration groups: -- Before type checking a group of declarations, a dependency analysis is--- performed and the declaration group is eventually transformed into--- nested declaration groups which are checked separately. Within each--- declaration group, first the value environment is extended with new--- bindings for all variables and functions defined in the group. Next,--- types are inferred for all declarations without an explicit type signature--- and the inferred types are then generalized. Finally, the types of all--- explicitly typed declarations are checked.+-- performed and the declaration group is eventually transformed into nested+-- declaration groups which are checked separately. Within each declaration+-- group, first the value environment is extended with new bindings for all+-- variables and functions defined in the group. Next, types are inferred for+-- all declarations without an explicit type signature and the inferred types+-- are then generalized. Finally, the types of all explicitly typed declarations+-- are checked. --- Within a group of mutually recursive declarations, all type variables--- that appear in the types of the variables defined in the group and--- whose type cannot be generalized must not be generalized in the other--- declarations of that group as well.+-- Within a group of mutually recursive declarations, all type variables that+-- appear in the types of the variables defined in the group and whose type+-- cannot be generalized must not be generalized in the other declarations of+-- that group as well. tcDecls :: [Decl a] -> TCM (PredSet, [Decl PredType])-tcDecls = liftM (fmap fromPDecls) . tcPDecls . toPDecls+tcDecls = fmap (fmap fromPDecls) . tcPDecls . toPDecls tcPDecls :: [PDecl a] -> TCM (PredSet, [PDecl PredType]) tcPDecls pds = withLocalSigEnv $ do@@ -450,8 +456,15 @@ tcPDeclGroup ps [(i, FreeDecl p fvs)] = do vs <- mapM (tcDeclVar False) (bv fvs) m <- getModuleIdent- modifyValueEnv $ flip (bindVars m) vs- return (ps, [(i, FreeDecl p (map (\(v, _, ForAll _ pty) -> Var pty v) vs))])+ (vs', ps') <- unzip <$> mapM addDataPred vs+ modifyValueEnv $ flip (bindVars m) vs'+ let d = FreeDecl p (map (\(v, _, ForAll _ ty) -> Var ty v) vs')+ return (ps `Set.union` Set.unions ps', [(i, d)])+ where+ addDataPred (idt, n, ForAll ids ty1) = do+ (ps2, ty2) <- freshDataType+ ps' <- unify idt "free variable" (ppIdent idt) emptyPredSet (unpredType ty1) ps2 ty2+ return ((idt, n, ForAll ids ty1), ps') tcPDeclGroup ps pds = do vEnv <- getValueEnv vss <- mapM (tcDeclVars . snd) pds@@ -461,7 +474,7 @@ let (impPds, expPds) = partitionPDecls sigs pds (ps', impPds') <- mapAccumM tcPDecl ps impPds theta <- getTypeSubst- tvs <- liftM (concatMap $ typeVars . subst theta . fst) $+ tvs <- concatMap (typeVars . subst theta . fst) <$> filterM (notM . isNonExpansive . snd . snd) impPds' let fvs = foldr Set.insert (fvEnv (subst theta vEnv)) tvs (gps, lps) = splitPredSet fvs ps'@@ -482,10 +495,10 @@ typeSig _ = Nothing bindVars :: ModuleIdent -> ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv-bindVars m = foldr $ uncurry3 $ flip (bindFun m) False+bindVars m = foldr $ uncurry3 $ flip (bindFun m) Nothing rebindVars :: ModuleIdent -> ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv-rebindVars m = foldr $ uncurry3 $ flip (rebindFun m) False+rebindVars m = foldr $ uncurry3 $ flip (rebindFun m) Nothing tcDeclVars :: Decl a -> TCM [(Ident, Int, TypeScheme)] tcDeclVars (FunctionDecl _ _ f eqs) = do@@ -523,7 +536,7 @@ tcPDecl ps (i, d@(PatternDecl p t rhs)) = do (ps', ty', t') <- tcPattern p t (ps'', rhs') <- tcRhs rhs >>-- unifyDecl p "pattern declaration" (ppDecl d) (ps `Set.union` ps') ty'+ unifyDecl p "pattern declaration" (pPrint d) (ps `Set.union` ps') ty' return (ps'', (ty', (i, PatternDecl p t' rhs'))) tcPDecl _ _ = internalError "TypeCheck.tcPDecl" @@ -541,17 +554,17 @@ tcEquation :: Type -> PredSet -> Equation a -> TCM (PredSet, Equation PredType) tcEquation ty ps eqn@(Equation p lhs rhs) =- tcEqn p lhs rhs >>- unifyDecl p "equation" (ppEquation eqn) ps ty+ tcEqn p lhs rhs >>- unifyDecl p "equation" (pPrint eqn) ps ty tcEqn :: SpanInfo -> Lhs a -> Rhs a -> TCM (PredSet, Type, Equation PredType) tcEqn p lhs rhs = do (ps, tys, lhs', ps', ty, rhs') <- withLocalValueEnv $ do bindLambdaVars lhs- (ps, tys, lhs') <- tcLhs p lhs+ (ps, tys, lhs') <- S.evalStateT (tcLhs p lhs) Set.empty (ps', ty, rhs') <- tcRhs rhs return (ps, tys, lhs', ps', ty, rhs')- ps'' <- reducePredSet p "equation" (ppEquation (Equation p lhs' rhs'))+ ps'' <- reducePredSet p "equation" (pPrint (Equation p lhs' rhs')) (ps `Set.union` ps') return (ps'', foldr TypeArrow ty tys, Equation p lhs' rhs') @@ -566,7 +579,7 @@ ty <- freshTypeVar return (v, 0, monoType ty) -unifyDecl :: HasPosition p => p -> String -> Doc -> PredSet -> Type -> PredSet+unifyDecl :: HasSpanInfo p => p -> String -> Doc -> PredSet -> Type -> PredSet -> Type -> TCM PredSet unifyDecl p what doc psLhs tyLhs psRhs tyRhs = do@@ -590,7 +603,7 @@ _ -> return ps defaultPDecl _ _ _ _ = internalError "TypeCheck.defaultPDecl" -applyDefaultsDecl :: HasPosition p => p -> String -> Doc -> Set.Set Int+applyDefaultsDecl :: HasSpanInfo p => p -> String -> Doc -> Set.Set Int -> PredSet -> Type -> TCM PredSet applyDefaultsDecl p what doc fvs ps ty = do theta <- getTypeSubst@@ -648,13 +661,13 @@ pty <- expandPoly qty unlessM (checkTypeSig pty tySc) $ do m <- getModuleIdent- report $ errTypeSigTooGeneral p m (text "Function:" <+> ppIdent f) qty tySc+ report $ errTypeSigTooGeneral m (text "Function:" <+> ppIdent f) qty tySc return (ps, (i, FunctionDecl p pty f eqs)) checkPDeclType qty ps tySc (i, PatternDecl p (VariablePattern spi _ v) rhs) = do pty <- expandPoly qty unlessM (checkTypeSig pty tySc) $ do m <- getModuleIdent- report $ errTypeSigTooGeneral p m (text "Variable:" <+> ppIdent v) qty tySc+ report $ errTypeSigTooGeneral m (text "Variable:" <+> ppIdent v) qty tySc return (ps, (i, PatternDecl p (VariablePattern spi pty v) rhs)) checkPDeclType _ _ _ _ = internalError "TypeCheck.checkPDeclType" @@ -747,14 +760,14 @@ internalError "TypeCheck.isNonExpansive: declaration" instance Binding (Rhs a) where- isNonExpansive (SimpleRhs _ e ds) = withLocalValueEnv $ do+ isNonExpansive (GuardedRhs _ _ _ _) = return False+ isNonExpansive (SimpleRhs _ _ e ds) = withLocalValueEnv $ do m <- getModuleIdent tcEnv <- getTyConsEnv clsEnv <- getClassEnv sigs <- getSigEnv modifyValueEnv $ flip (foldr (bindDeclArity m tcEnv clsEnv sigs)) ds isNonExpansive e &&^ isNonExpansive ds- isNonExpansive (GuardedRhs _ _ _) = return False -- A record construction is non-expansive only if all field labels are present. @@ -778,21 +791,21 @@ isNonExpansive' _ (Record _ _ c fs) = do m <- getModuleIdent vEnv <- getValueEnv- liftM ((length (constrLabels m c vEnv) == length fs) &&) (isNonExpansive fs)-isNonExpansive' _ (Tuple _ es) = isNonExpansive es-isNonExpansive' _ (List _ _ es) = isNonExpansive es-isNonExpansive' n (Apply _ f e) =- isNonExpansive' (n + 1) f &&^ isNonExpansive e-isNonExpansive' n (InfixApply _ e1 op e2) =- isNonExpansive' (n + 2) (infixOp op) &&^ isNonExpansive e1 &&^- isNonExpansive e2-isNonExpansive' n (LeftSection _ e op) =- isNonExpansive' (n + 1) (infixOp op) &&^ isNonExpansive e-isNonExpansive' n (Lambda _ ts e) = withLocalValueEnv $ do+ fmap ((length (constrLabels m c vEnv) == length fs) &&) (isNonExpansive fs)+isNonExpansive' _ (Tuple _ es) = isNonExpansive es+isNonExpansive' _ (List _ _ es) = isNonExpansive es+isNonExpansive' n (Apply _ f e) = isNonExpansive' (n + 1) f+ &&^ isNonExpansive e+isNonExpansive' n (InfixApply _ e1 op e2)+ = isNonExpansive' (n + 2) (infixOp op) &&^ isNonExpansive e1+ &&^ isNonExpansive e2+isNonExpansive' n (LeftSection _ e op) = isNonExpansive' (n + 1) (infixOp op)+ &&^ isNonExpansive e+isNonExpansive' n (Lambda _ ts e) = withLocalValueEnv $ do modifyValueEnv $ flip (foldr bindVarArity) (bv ts)- liftM ((n < length ts) ||)- (liftM ((all isVariablePattern ts) &&) (isNonExpansive' (n - length ts) e))-isNonExpansive' n (Let _ ds e) = withLocalValueEnv $ do+ fmap (((n < length ts) ||) . (all isVariablePattern ts &&))+ (isNonExpansive' (n - length ts) e)+isNonExpansive' n (Let _ _ ds e) = withLocalValueEnv $ do m <- getModuleIdent tcEnv <- getTyConsEnv clsEnv <- getClassEnv@@ -825,7 +838,7 @@ bindVarArity v = bindArity v 0 bindArity :: Ident -> Int -> ValueEnv -> ValueEnv-bindArity v n = bindTopEnv v (Value (qualify v) False n undefined)+bindArity v n = bindTopEnv v (Value (qualify v) Nothing n undefined) -- Class and instance declarations: -- When checking method implementations in class and instance@@ -838,34 +851,34 @@ -- instance declarations because the instance type must be substituted -- for the type variable used in the type class declaration. ----- When checking inferred method types against their expected types, we--- have to be careful because the class' type variable is always assigned--- index 0 in the method types recorded in the value environment. However,--- in the inferred type scheme returned from 'tcMethodDecl', type variables--- are assigned indices in the order of their occurrence. In order to avoid--- incorrectly reporting errors when the type class variable is not the first--- variable that appears in a method's type, 'tcInstMethodDecl' normalizes--- the expected method type before applying 'checkInstMethodType' to it and--- 'checkClassMethodType' uses 'expandPolyType' instead of 'expandMethodType'--- in order to convert the method's type signature. Unfortunately, this means--- that the compiler has to add the class constraint explicitly to the type--- signature.+-- When checking inferred method types against their expected types, we have to+-- be careful because the class' type variable is always assigned index 0 in+-- the method types recorded in the value environment. However, in the inferred+-- type scheme returned from 'tcMethodDecl', type variables are assigned+-- indices in the order of their occurrence. In order to avoid incorrectly+-- reporting errors when the type class variable is not the first variable that+-- appears in a method's type, 'tcInstanceMethodPDecl' normalizes the expected+-- method type before applying 'checkInstMethodType' to it. Unfortunately, this+-- means that the compiler has to add the class constraint explicitly to the+-- type signature. tcTopPDecl :: PDecl a -> TCM (PDecl PredType)-tcTopPDecl (i, DataDecl p tc tvs cs clss) =- return (i, DataDecl p tc tvs cs clss)-tcTopPDecl (i, ExternalDataDecl p tc tvs) =- return (i, ExternalDataDecl p tc tvs)-tcTopPDecl (i, NewtypeDecl p tc tvs nc clss) =- return (i, NewtypeDecl p tc tvs nc clss)-tcTopPDecl (i, TypeDecl p tc tvs ty) = return (i, TypeDecl p tc tvs ty)-tcTopPDecl (i, DefaultDecl p tys) = return (i, DefaultDecl p tys)-tcTopPDecl (i, ClassDecl p cx cls tv ds) = withLocalSigEnv $ do+tcTopPDecl (i, DataDecl p tc tvs cs clss)+ = return (i, DataDecl p tc tvs cs clss)+tcTopPDecl (i, ExternalDataDecl p tc tvs)+ = return (i, ExternalDataDecl p tc tvs)+tcTopPDecl (i, NewtypeDecl p tc tvs nc clss)+ = return (i, NewtypeDecl p tc tvs nc clss)+tcTopPDecl (i, TypeDecl p tc tvs ty)+ = return (i, TypeDecl p tc tvs ty)+tcTopPDecl (i, DefaultDecl p tys)+ = return (i, DefaultDecl p tys)+tcTopPDecl (i, ClassDecl p li cx cls tv ds) = withLocalSigEnv $ do+ let (vpds, opds) = partition (isValueDecl . snd) $ toPDecls ds setSigEnv $ foldr (bindTypeSigs . snd) emptySigEnv opds vpds' <- mapM (tcClassMethodPDecl (qualify cls) tv) vpds- return (i, ClassDecl p cx cls tv $ fromPDecls $ map untyped opds ++ vpds')- where (vpds, opds) = partition (isValueDecl . snd) $ toPDecls ds-tcTopPDecl (i, InstanceDecl p cx qcls ty ds) = do+ return (i, ClassDecl p li cx cls tv $ fromPDecls $ map untyped opds ++ vpds')+tcTopPDecl (i, InstanceDecl p li cx qcls ty ds) = do tcEnv <- getTyConsEnv pty <- expandPoly $ QualTypeExpr NoSpanInfo cx ty mid <- getModuleIdent@@ -873,14 +886,14 @@ clsQual = head $ filter isQualified $ reverseLookupByOrigName origCls tcEnv qQualCls = qualQualify (fromJust $ qidModule clsQual) qcls vpds' <- mapM (tcInstanceMethodPDecl qQualCls pty) vpds- return (i, InstanceDecl p cx qcls ty $ fromPDecls $ map untyped opds ++ vpds')+ return (i,InstanceDecl p li cx qcls ty $ fromPDecls $ map untyped opds++vpds') where (vpds, opds) = partition (isValueDecl . snd) $ toPDecls ds-tcTopPDecl _ = internalError "Checks.TypeCheck.tcTopDecl"+tcTopPDecl _ = internalError "TypeCheck.tcTopDecl" tcClassMethodPDecl :: QualIdent -> Ident -> PDecl a -> TCM (PDecl PredType) tcClassMethodPDecl qcls tv pd@(_, FunctionDecl _ _ f _) = do methTy <- classMethodType qualify f- (tySc, pd') <- tcMethodPDecl methTy pd+ (tySc, pd') <- tcMethodPDecl qcls methTy pd sigs <- getSigEnv let QualTypeExpr spi cx ty = fromJust $ lookupTypeSig f sigs qty = QualTypeExpr spi@@ -892,36 +905,36 @@ -> TCM (PDecl PredType) tcInstanceMethodPDecl qcls pty pd@(_, FunctionDecl _ _ f _) = do methTy <- instMethodType (qualifyLike qcls) pty f- (tySc, pd') <- tcMethodPDecl (typeScheme methTy) pd+ (tySc, pd') <- tcMethodPDecl qcls (typeScheme methTy) pd checkInstMethodType (normalize 0 methTy) tySc pd' tcInstanceMethodPDecl _ _ _ = internalError "TypeCheck.tcInstanceMethodPDecl" -tcMethodPDecl :: TypeScheme -> PDecl a -> TCM (TypeScheme, PDecl PredType)-tcMethodPDecl tySc (i, FunctionDecl p _ f eqs) = withLocalValueEnv $ do+tcMethodPDecl :: QualIdent -> TypeScheme -> PDecl a -> TCM (TypeScheme, PDecl PredType)+tcMethodPDecl qcls tySc (i, FunctionDecl p _ f eqs) = withLocalValueEnv $ do m <- getModuleIdent- modifyValueEnv $ bindFun m f True (eqnArity $ head eqs) tySc+ modifyValueEnv $ bindFun m f (Just qcls) (eqnArity $ head eqs) tySc (ps, (ty, pd)) <- tcFunctionPDecl i emptyPredSet tySc p f eqs theta <- getTypeSubst return (gen Set.empty ps $ subst theta ty, pd)-tcMethodPDecl _ _ = internalError "TypeCheck.tcMethodPDecl"+tcMethodPDecl _ _ _ = internalError "TypeCheck.tcMethodPDecl" checkClassMethodType :: QualTypeExpr -> TypeScheme -> PDecl PredType -> TCM (PDecl PredType)-checkClassMethodType qty tySc pd@(_, FunctionDecl p _ f _) = do+checkClassMethodType qty tySc pd@(_, FunctionDecl _ _ f _) = do pty <- expandPoly qty unlessM (checkTypeSig pty tySc) $ do m <- getModuleIdent- report $ errTypeSigTooGeneral p m (text "Method:" <+> ppIdent f) qty tySc+ report $ errTypeSigTooGeneral m (text "Method:" <+> ppIdent f) qty tySc return pd checkClassMethodType _ _ _ = internalError "TypeCheck.checkClassMethodType" checkInstMethodType :: PredType -> TypeScheme -> PDecl PredType -> TCM (PDecl PredType)-checkInstMethodType pty tySc pd@(_, FunctionDecl p _ f _) = do+checkInstMethodType pty tySc pd@(_, FunctionDecl _ _ f _) = do unlessM (checkTypeSig pty tySc) $ do m <- getModuleIdent report $- errMethodTypeTooSpecific p m (text "Method:" <+> ppIdent f) pty tySc+ errMethodTypeTooSpecific f m (text "Method:" <+> ppIdent f) pty tySc return pd checkInstMethodType _ _ _ = internalError "TypeCheck.checkInstMethodType" @@ -951,7 +964,7 @@ Just (QualTypeExpr _ _ ty) -> do m <- getModuleIdent PredType _ ty' <- expandPoly $ QualTypeExpr NoSpanInfo [] ty- modifyValueEnv $ bindFun m f False (arrowArity ty') (polyType ty')+ modifyValueEnv $ bindFun m f Nothing (arrowArity ty') (polyType ty') return ty' -- Patterns and Expressions:@@ -963,24 +976,24 @@ tcLiteral :: Bool -> Literal -> TCM (PredSet, Type) tcLiteral _ (Char _) = return (emptyPredSet, charType) tcLiteral poly (Int _)- | poly = freshNumType- | otherwise = liftM ((,) emptyPredSet) (freshConstrained numTypes)+ | poly = freshNumType+ | otherwise = fmap ((,) emptyPredSet) (freshConstrained numTypes) tcLiteral poly (Float _)- | poly = freshFractionalType- | otherwise = liftM ((,) emptyPredSet) (freshConstrained fractionalTypes)-tcLiteral _ (String _) = return (emptyPredSet, stringType)+ | poly = freshFractionalType+ | otherwise = fmap ((,) emptyPredSet) (freshConstrained fractionalTypes)+tcLiteral _ (String _) = return (emptyPredSet, stringType) -tcLhs :: HasPosition p => p -> Lhs a -> TCM (PredSet, [Type], Lhs PredType)+tcLhs :: HasSpanInfo p => p -> Lhs a -> PTCM (PredSet, [Type], Lhs PredType) tcLhs p (FunLhs spi f ts) = do- (pss, tys, ts') <- liftM unzip3 $ mapM (tcPattern p) ts+ (pss, tys, ts') <- unzip3 <$> mapM (tcPatternHelper p) ts return (Set.unions pss, tys, FunLhs spi f ts') tcLhs p (OpLhs spi t1 op t2) = do- (ps1, ty1, t1') <- tcPattern p t1- (ps2, ty2, t2') <- tcPattern p t2+ (ps1, ty1, t1') <- tcPatternHelper p t1+ (ps2, ty2, t2') <- tcPatternHelper p t2 return (ps1 `Set.union` ps2, [ty1, ty2], OpLhs spi t1' op t2') tcLhs p (ApLhs spi lhs ts) = do (ps, tys1, lhs') <- tcLhs p lhs- (pss, tys2, ts') <- liftM unzip3 $ mapM (tcPattern p) ts+ (pss, tys2, ts') <- unzip3 <$> mapM (tcPatternHelper p) ts return (Set.unions (ps:pss), tys1 ++ tys2, ApLhs spi lhs' ts') -- When computing the type of a variable in a pattern, we ignore the@@ -990,129 +1003,161 @@ -- checked as constructor and functional patterns, respectively, resulting -- in slighty misleading error messages if the type check fails. -tcPattern :: HasPosition p => p -> Pattern a+-- We also keep track of already used variables,+-- in order to add a Data constraint for non-linear patterns++tcPattern :: HasSpanInfo p => p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)-tcPattern _ (LiteralPattern spi _ l) = do- (ps, ty) <- tcLiteral False l+tcPattern = tcPatternWith Set.empty++tcPatternWith :: HasSpanInfo p => Set.Set Ident -> p -> Pattern a+ -> TCM (PredSet, Type, Pattern PredType)+tcPatternWith s p pt = S.evalStateT (tcPatternHelper p pt) s++type PTCM a = S.StateT (Set.Set Ident) TCM a++tcPatternHelper :: HasSpanInfo p => p -> Pattern a+ -> PTCM (PredSet, Type, Pattern PredType)+tcPatternHelper _ (LiteralPattern spi _ l) = do+ (ps, ty) <- lift $ tcLiteral False l return (ps, ty, LiteralPattern spi (predType ty) l)-tcPattern _ (NegativePattern spi _ l) = do- (ps, ty) <- tcLiteral False l+tcPatternHelper _ (NegativePattern spi _ l) = do+ (ps, ty) <- lift $ tcLiteral False l return (ps, ty, NegativePattern spi (predType ty) l)-tcPattern _ (VariablePattern spi _ v) = do- vEnv <- getValueEnv- (_, ty) <- inst (varType v vEnv)- return (emptyPredSet, ty, VariablePattern spi (predType ty) v)-tcPattern p t@(ConstructorPattern spi _ c ts) = do- m <- getModuleIdent- vEnv <- getValueEnv- (ps, (tys, ty')) <- liftM (fmap arrowUnapply) (skol (constrType m c vEnv))- (ps', ts') <- mapAccumM (uncurry . tcPatternArg p "pattern" (ppPattern 0 t))+tcPatternHelper _ (VariablePattern spi _ v) = do+ vEnv <- lift getValueEnv+ (_, ty) <- lift $ inst (varType v vEnv)+ used <- S.get+ ps <- if Set.member v used+ then return (Set.singleton (Pred qDataId ty))+ else S.put (Set.insert v used) >> return Set.empty+ return (ps, ty, VariablePattern spi (predType ty) v)+tcPatternHelper p t@(ConstructorPattern spi _ c ts) = do+ m <- lift getModuleIdent+ vEnv <- lift getValueEnv+ (ps, (tys, ty')) <- fmap arrowUnapply <$> lift (skol (constrType m c vEnv))+ (ps', ts') <- mapAccumM (uncurry . ptcPatternArg p "pattern" (pPrintPrec 0 t)) ps (zip tys ts) return (ps', ty', ConstructorPattern spi (predType ty') c ts')-tcPattern p (InfixPattern spi a t1 op t2) = do- (ps, ty, t') <- tcPattern p (ConstructorPattern NoSpanInfo a op [t1, t2])+tcPatternHelper p (InfixPattern spi a t1 op t2) = do+ (ps, ty, t') <- tcPatternHelper p (ConstructorPattern NoSpanInfo a op [t1,t2]) let ConstructorPattern _ a' op' [t1', t2'] = t' return (ps, ty, InfixPattern spi a' t1' op' t2')-tcPattern p (ParenPattern spi t) = do- (ps, ty, t') <- tcPattern p t+tcPatternHelper p (ParenPattern spi t) = do+ (ps, ty, t') <- tcPatternHelper p t return (ps, ty, ParenPattern spi t')-tcPattern _ t@(RecordPattern spi _ c fs) = do- m <- getModuleIdent- vEnv <- getValueEnv- (ps, ty) <- liftM (fmap arrowBase) (skol (constrType m c vEnv))- (ps', fs') <- mapAccumM (tcField tcPattern "pattern"- (\t' -> ppPattern 0 t $-$ text "Term:" <+> ppPattern 0 t') ty) ps fs+tcPatternHelper _ t@(RecordPattern spi _ c fs) = do+ m <- lift getModuleIdent+ vEnv <- lift getValueEnv+ (ps, ty) <- fmap arrowBase <$> lift (skol (constrType m c vEnv))+ -- tcField does not support passing "used" variables, thus we do it by hand+ used <- S.get+ (ps', fs') <- lift $ mapAccumM (tcField (tcPatternWith used) "pattern"+ (\t' -> pPrintPrec 0 t $-$ text "Term:" <+> pPrintPrec 0 t') ty) ps fs+ S.put $ foldr Set.insert used $ concatMap bv fs return (ps', ty, RecordPattern spi (predType ty) c fs')-tcPattern p (TuplePattern spi ts) = do- (pss, tys, ts') <- liftM unzip3 $ mapM (tcPattern p) ts+tcPatternHelper p (TuplePattern spi ts) = do+ (pss, tys, ts') <- unzip3 <$> mapM (tcPatternHelper p) ts return (Set.unions pss, tupleType tys, TuplePattern spi ts')-tcPattern p t@(ListPattern spi _ ts) = do- ty <- freshTypeVar- (ps, ts') <- mapAccumM (flip (tcPatternArg p "pattern" (ppPattern 0 t)) ty)+tcPatternHelper p t@(ListPattern spi _ ts) = do+ ty <- lift freshTypeVar+ (ps, ts') <- mapAccumM (flip (ptcPatternArg p "pattern" (pPrintPrec 0 t)) ty) emptyPredSet ts return (ps, listType ty, ListPattern spi (predType $ listType ty) ts')-tcPattern p t@(AsPattern spi v t') = do- vEnv <- getValueEnv- (_, ty) <- inst (varType v vEnv)- (ps, t'') <- tcPattern p t' >>-- unify p "pattern" (ppPattern 0 t) emptyPredSet ty- return (ps, ty, AsPattern spi v t'')-tcPattern p (LazyPattern spi t) = do- (ps, ty, t') <- tcPattern p t+tcPatternHelper p t@(AsPattern spi v t') = do+ vEnv <- lift getValueEnv+ (_, ty) <- lift $ inst (varType v vEnv)+ used <- S.get+ ps <- if Set.member v used+ then return (Set.singleton (Pred qDataId ty))+ else S.put (Set.insert v used) >> return Set.empty+ (ps'', t'') <- tcPatternHelper p t' >>-+ (\ps' ty' -> lift $ unify p "pattern" (pPrintPrec 0 t) ps ty ps' ty')+ return (ps'', ty, AsPattern spi v t'')+tcPatternHelper p (LazyPattern spi t) = do+ (ps, ty, t') <- tcPatternHelper p t return (ps, ty, LazyPattern spi t')-tcPattern p t@(FunctionPattern spi _ f ts) = do- m <- getModuleIdent- vEnv <- getValueEnv- (ps, ty) <- inst (funType m f vEnv)- tcFuncPattern p spi (ppPattern 0 t) f id ps ty ts-tcPattern p (InfixFuncPattern spi a t1 op t2) = do- (ps, ty, t') <- tcPattern p (FunctionPattern spi a op [t1, t2])+tcPatternHelper p t@(FunctionPattern spi _ f ts) = do+ m <- lift getModuleIdent+ vEnv <- lift getValueEnv+ (ps, ty) <- lift $ inst (funType m f vEnv)+ -- insert all+ S.modify (flip (foldr Set.insert) (bv t))+ tcFuncPattern p spi (pPrintPrec 0 t) f id ps ty ts+tcPatternHelper p (InfixFuncPattern spi a t1 op t2) = do+ (ps, ty, t') <- tcPatternHelper p (FunctionPattern spi a op [t1, t2]) let FunctionPattern _ a' op' [t1', t2'] = t' return (ps, ty, InfixFuncPattern spi a' t1' op' t2') -tcFuncPattern :: HasPosition p => p -> SpanInfo -> Doc -> QualIdent+tcFuncPattern :: HasSpanInfo p => p -> SpanInfo -> Doc -> QualIdent -> ([Pattern PredType] -> [Pattern PredType]) -> PredSet -> Type -> [Pattern a]- -> TCM (PredSet, Type, Pattern PredType)+ -> PTCM (PredSet, Type, Pattern PredType) tcFuncPattern _ spi _ f ts ps ty [] =- return (ps, ty, FunctionPattern spi (predType ty) f (ts []))+ return (Set.insert (Pred qDataId ty) ps, ty, FunctionPattern spi (predType ty) f (ts [])) tcFuncPattern p spi doc f ts ps ty (t':ts') = do- (alpha, beta) <-- tcArrow p "functional pattern" (doc $-$ text "Term:" <+> ppPattern 0 t) ty- (ps', t'') <- tcPatternArg p "functional pattern" doc ps alpha t'+ (alpha, beta) <- lift $+ tcArrow p "functional pattern" (doc $-$ text "Term:" <+> pPrintPrec 0 t) ty+ (ps', t'') <- ptcPatternArg p "functional pattern" doc ps alpha t' tcFuncPattern p spi doc f (ts . (t'' :)) ps' beta ts' where t = FunctionPattern spi (predType ty) f (ts []) -tcPatternArg :: HasPosition p => p -> String -> Doc -> PredSet -> Type+ptcPatternArg :: HasSpanInfo p => p -> String -> Doc -> PredSet -> Type+ -> Pattern a -> PTCM (PredSet, Pattern PredType)+ptcPatternArg p what doc ps ty t =+ tcPatternHelper p t >>-+ (\ps' ty' -> lift $+ unify p what (doc $-$ text "Term:" <+> pPrintPrec 0 t) ps ty ps' ty')++tcPatternArg :: HasSpanInfo p => p -> String -> Doc -> PredSet -> Type -> Pattern a -> TCM (PredSet, Pattern PredType) tcPatternArg p what doc ps ty t = tcPattern p t >>-- unify p what (doc $-$ text "Term:" <+> ppPattern 0 t) ps ty+ unify p what (doc $-$ text "Term:" <+> pPrintPrec 0 t) ps ty tcRhs :: Rhs a -> TCM (PredSet, Type, Rhs PredType)-tcRhs (SimpleRhs p e ds) = do+tcRhs (SimpleRhs p li e ds) = do (ps, ds', ps', ty, e') <- withLocalValueEnv $ do (ps, ds') <- tcDecls ds- (ps', ty, e') <- tcExpr p e+ (ps', ty, e') <- tcExpr e return (ps, ds', ps', ty, e')- ps'' <- reducePredSet p "expression" (ppExpr 0 e') (ps `Set.union` ps')- return (ps'', ty, SimpleRhs p e' ds')-tcRhs (GuardedRhs spi es ds) = withLocalValueEnv $ do+ ps'' <- reducePredSet p "expression" (pPrintPrec 0 e') (ps `Set.union` ps')+ return (ps'', ty, SimpleRhs p li e' ds')+tcRhs (GuardedRhs spi li es ds) = withLocalValueEnv $ do (ps, ds') <- tcDecls ds ty <- freshTypeVar (ps', es') <- mapAccumM (tcCondExpr ty) ps es- return (ps', ty, GuardedRhs spi es' ds')+ return (ps', ty, GuardedRhs spi li es' ds') tcCondExpr :: Type -> PredSet -> CondExpr a -> TCM (PredSet, CondExpr PredType) tcCondExpr ty ps (CondExpr p g e) = do- (ps', g') <- tcExpr p g >>- unify p "guard" (ppExpr 0 g) ps boolType- (ps'', e') <- tcExpr p e >>- unify p "guarded expression" (ppExpr 0 e) ps' ty+ (ps', g') <- tcExpr g >>- unify p "guard" (pPrintPrec 0 g) ps boolType+ (ps'', e') <- tcExpr e >>- unify p "guarded expression" (pPrintPrec 0 e) ps' ty return (ps'', CondExpr p g' e') -tcExpr :: HasPosition p => p -> Expression a- -> TCM (PredSet, Type, Expression PredType)-tcExpr _ (Literal spi _ l) = do+tcExpr :: Expression a -> TCM (PredSet, Type, Expression PredType)+tcExpr (Literal spi _ l) = do (ps, ty) <- tcLiteral True l return (ps, ty, Literal spi (predType ty) l)-tcExpr _ (Variable spi _ v) = do+tcExpr (Variable spi _ v) = do m <- getModuleIdent vEnv <- getValueEnv- (ps, ty) <- if isAnonId (unqualify v) then freshPredType []+ (ps, ty) <- if isAnonId (unqualify v) then freshPredType [qDataId] else inst (funType m v vEnv) return (ps, ty, Variable spi (predType ty) v)-tcExpr _ (Constructor spi _ c) = do+tcExpr (Constructor spi _ c) = do m <- getModuleIdent vEnv <- getValueEnv (ps, ty) <- inst (constrType m c vEnv) return (ps, ty, Constructor spi (predType ty) c)-tcExpr p (Paren spi e) = do- (ps, ty, e') <- tcExpr p e+tcExpr (Paren spi e) = do+ (ps, ty, e') <- tcExpr e return (ps, ty, Paren spi e')-tcExpr p (Typed spi e qty) = do+tcExpr (Typed spi e qty) = do pty <- expandPoly qty (ps, ty) <- inst (typeScheme pty)- (ps', e') <- tcExpr p e >>-- unifyDecl p "explicitly typed expression" (ppExpr 0 e) emptyPredSet ty+ (ps', e') <- tcExpr e >>-+ unifyDecl spi "explicitly typed expression" (pPrintPrec 0 e) emptyPredSet ty fvs <- computeFvEnv theta <- getTypeSubst let (gps, lps) = splitPredSet fvs ps'@@ -1120,124 +1165,127 @@ unlessM (checkTypeSig pty tySc) $ do m <- getModuleIdent report $- errTypeSigTooGeneral p m (text "Expression:" <+> ppExpr 0 e) qty tySc+ errTypeSigTooGeneral m (text "Expression:" <+> pPrintPrec 0 e) qty tySc return (ps `Set.union` gps, ty, Typed spi e' qty)-tcExpr _ e@(Record spi _ c fs) = do+tcExpr e@(Record spi _ c fs) = do m <- getModuleIdent vEnv <- getValueEnv- (ps, ty) <- liftM (fmap arrowBase) (inst (constrType m c vEnv))- (ps', fs') <- mapAccumM (tcField tcExpr "construction"- (\e' -> ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e') ty) ps fs- return (ps', ty, Record spi (predType ty) c fs')-tcExpr p e@(RecordUpdate spi e1 fs) = do- (ps, ty, e1') <- tcExpr p e1- (ps', fs') <- mapAccumM (tcField tcExpr "update"- (\e' -> ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e') ty) ps fs+ (ps, ty) <- fmap arrowBase <$> inst (constrType m c vEnv)+ (ps', fs') <- mapAccumM (tcField (const tcExpr) "construction"+ (\e' -> pPrintPrec 0 e $-$ text "Term:" <+> pPrintPrec 0 e') ty) ps fs+ let missing = map (qualifyLike c) (constrLabels m c vEnv)+ \\ map (\(Field _ qid _) -> qid) fs'+ pss <- mapM (tcMissingField spi ty) missing+ return (Set.unions (ps':pss), ty, Record spi (predType ty) c fs')+tcExpr e@(RecordUpdate spi e1 fs) = do+ (ps, ty, e1') <- tcExpr e1+ (ps', fs') <- mapAccumM (tcField (const tcExpr) "update"+ (\e' -> pPrintPrec 0 e $-$ text "Term:" <+> pPrintPrec 0 e') ty) ps fs return (ps', ty, RecordUpdate spi e1' fs')-tcExpr p (Tuple spi es) = do- (pss, tys, es') <- liftM unzip3 $ mapM (tcExpr p) es+tcExpr (Tuple spi es) = do+ (pss, tys, es') <- liftM unzip3 $ mapM (tcExpr) es return (Set.unions pss, tupleType tys, Tuple spi es')-tcExpr p e@(List spi _ es) = do+tcExpr e@(List spi _ es) = do ty <- freshTypeVar (ps, es') <-- mapAccumM (flip (tcArg p "expression" (ppExpr 0 e)) ty) emptyPredSet es+ mapAccumM (flip (tcArg spi "expression" (pPrintPrec 0 e)) ty) emptyPredSet es return (ps, listType ty, List spi (predType $ listType ty) es')-tcExpr p (ListCompr spi e qs) = do+tcExpr (ListCompr spi e qs) = do (ps, qs', ps', ty, e') <- withLocalValueEnv $ do- (ps, qs') <- mapAccumM (tcQual p) emptyPredSet qs- (ps', ty, e') <- tcExpr p e+ (ps, qs') <- mapAccumM (tcQual spi) emptyPredSet qs+ (ps', ty, e') <- tcExpr e return (ps, qs', ps', ty, e')- ps'' <- reducePredSet p "expression" (ppExpr 0 e') (ps `Set.union` ps')+ ps'' <- reducePredSet spi "expression" (pPrintPrec 0 e') (ps `Set.union` ps') return (ps'', listType ty, ListCompr spi e' qs')-tcExpr p e@(EnumFrom spi e1) = do+tcExpr e@(EnumFrom spi e1) = do (ps, ty) <- freshEnumType- (ps', e1') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps ty e1+ (ps', e1') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps ty e1 return (ps', listType ty, EnumFrom spi e1')-tcExpr p e@(EnumFromThen spi e1 e2) = do+tcExpr e@(EnumFromThen spi e1 e2) = do (ps, ty) <- freshEnumType- (ps', e1') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps ty e1- (ps'', e2') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps' ty e2+ (ps', e1') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps ty e1+ (ps'', e2') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps' ty e2 return (ps'', listType ty, EnumFromThen spi e1' e2')-tcExpr p e@(EnumFromTo spi e1 e2) = do+tcExpr e@(EnumFromTo spi e1 e2) = do (ps, ty) <- freshEnumType- (ps', e1') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps ty e1- (ps'', e2') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps' ty e2+ (ps', e1') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps ty e1+ (ps'', e2') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps' ty e2 return (ps'', listType ty, EnumFromTo spi e1' e2')-tcExpr p e@(EnumFromThenTo spi e1 e2 e3) = do+tcExpr e@(EnumFromThenTo spi e1 e2 e3) = do (ps, ty) <- freshEnumType- (ps', e1') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps ty e1- (ps'', e2') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps' ty e2- (ps''', e3') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps'' ty e3+ (ps', e1') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps ty e1+ (ps'', e2') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps' ty e2+ (ps''', e3') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps'' ty e3 return (ps''', listType ty, EnumFromThenTo spi e1' e2' e3')-tcExpr p e@(UnaryMinus spi e1) = do+tcExpr e@(UnaryMinus spi e1) = do (ps, ty) <- freshNumType- (ps', e1') <- tcArg p "unary negation" (ppExpr 0 e) ps ty e1+ (ps', e1') <- tcArg spi "unary negation" (pPrintPrec 0 e) ps ty e1 return (ps', ty, UnaryMinus spi e1')-tcExpr p e@(Apply spi e1 e2) = do- (ps, (alpha, beta), e1') <- tcExpr p e1 >>=-- tcArrow p "application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1)- (ps', e2') <- tcArg p "application" (ppExpr 0 e) ps alpha e2+tcExpr e@(Apply spi e1 e2) = do+ (ps, (alpha, beta), e1') <- tcExpr e1 >>=-+ tcArrow spi "application" (pPrintPrec 0 e $-$ text "Term:" <+> pPrintPrec 0 e1)+ (ps', e2') <- tcArg spi "application" (pPrintPrec 0 e) ps alpha e2 return (ps', beta, Apply spi e1' e2')-tcExpr p e@(InfixApply spi e1 op e2) = do+tcExpr e@(InfixApply spi e1 op e2) = do (ps, (alpha, beta, gamma), op') <- tcInfixOp op >>=-- tcBinary p "infix application" (ppExpr 0 e $-$ text "Operator:" <+> ppOp op)- (ps', e1') <- tcArg p "infix application" (ppExpr 0 e) ps alpha e1- (ps'', e2') <- tcArg p "infix application" (ppExpr 0 e) ps' beta e2+ tcBinary spi "infix application" (pPrintPrec 0 e $-$ text "Operator:" <+> pPrint op)+ (ps', e1') <- tcArg spi "infix application" (pPrintPrec 0 e) ps alpha e1+ (ps'', e2') <- tcArg spi "infix application" (pPrintPrec 0 e) ps' beta e2 return (ps'', gamma, InfixApply spi e1' op' e2')-tcExpr p e@(LeftSection spi e1 op) = do+tcExpr e@(LeftSection spi e1 op) = do (ps, (alpha, beta), op') <- tcInfixOp op >>=-- tcArrow p "left section" (ppExpr 0 e $-$ text "Operator:" <+> ppOp op)- (ps', e1') <- tcArg p "left section" (ppExpr 0 e) ps alpha e1+ tcArrow spi "left section" (pPrintPrec 0 e $-$ text "Operator:" <+> pPrint op)+ (ps', e1') <- tcArg spi "left section" (pPrintPrec 0 e) ps alpha e1 return (ps', beta, LeftSection spi e1' op')-tcExpr p e@(RightSection spi op e1) = do+tcExpr e@(RightSection spi op e1) = do (ps, (alpha, beta, gamma), op') <- tcInfixOp op >>=-- tcBinary p "right section" (ppExpr 0 e $-$ text "Operator:" <+> ppOp op)- (ps', e1') <- tcArg p "right section" (ppExpr 0 e) ps beta e1+ tcBinary spi "right section" (pPrintPrec 0 e $-$ text "Operator:" <+> pPrint op)+ (ps', e1') <- tcArg spi "right section" (pPrintPrec 0 e) ps beta e1 return (ps', TypeArrow alpha gamma, RightSection spi op' e1')-tcExpr p (Lambda spi ts e) = do+tcExpr (Lambda spi ts e) = do (pss, tys, ts', ps, ty, e')<- withLocalValueEnv $ do bindLambdaVars ts- (pss, tys, ts') <- liftM unzip3 $ mapM (tcPattern p) ts- (ps, ty, e') <- tcExpr p e+ (pss, tys, ts') <- liftM unzip3 $ mapM (tcPattern spi) ts+ (ps, ty, e') <- tcExpr e return (pss, tys, ts', ps, ty, e')- ps' <- reducePredSet p "expression" (ppExpr 0 e') (Set.unions $ ps : pss)+ ps' <- reducePredSet spi "expression" (pPrintPrec 0 e') (Set.unions $ ps : pss) return (ps', foldr TypeArrow ty tys, Lambda spi ts' e')-tcExpr p (Let spi ds e) = do+tcExpr (Let spi li ds e) = do (ps, ds', ps', ty, e') <- withLocalValueEnv $ do (ps, ds') <- tcDecls ds- (ps', ty, e') <- tcExpr p e+ (ps', ty, e') <- tcExpr e return (ps, ds', ps', ty, e')- ps'' <- reducePredSet p "expression" (ppExpr 0 e') (ps `Set.union` ps')- return (ps'', ty, Let spi ds' e')-tcExpr p (Do spi sts e) = do+ ps'' <- reducePredSet spi "expression" (pPrintPrec 0 e') (ps `Set.union` ps')+ return (ps'', ty, Let spi li ds' e')+tcExpr (Do spi li sts e) = do (sts', ty, ps', e') <- withLocalValueEnv $ do ((ps, mTy), sts') <-- mapAccumM (uncurry (tcStmt p)) (emptyPredSet, Nothing) sts+ mapAccumM (uncurry (tcStmt spi)) (emptyPredSet, Nothing) sts ty <- liftM (maybe id TypeApply mTy) freshTypeVar- (ps', e') <- tcExpr p e >>- unify p "statement" (ppExpr 0 e) ps ty+ (ps', e') <- tcExpr e >>- unify spi "statement" (pPrintPrec 0 e) ps ty return (sts', ty, ps', e')- return (ps', ty, Do spi sts' e')-tcExpr p e@(IfThenElse spi e1 e2 e3) = do- (ps, e1') <- tcArg p "expression" (ppExpr 0 e) emptyPredSet boolType e1- (ps', ty, e2') <- tcExpr p e2- (ps'', e3') <- tcArg p "expression" (ppExpr 0 e) (ps `Set.union` ps') ty e3+ return (ps', ty, Do spi li sts' e')+tcExpr e@(IfThenElse spi e1 e2 e3) = do+ (ps, e1') <- tcArg spi "expression" (pPrintPrec 0 e) emptyPredSet boolType e1+ (ps', ty, e2') <- tcExpr e2+ (ps'', e3') <- tcArg spi "expression" (pPrintPrec 0 e) (ps `Set.union` ps') ty e3 return (ps'', ty, IfThenElse spi e1' e2' e3')-tcExpr p (Case spi ct e as) = do- (ps, tyLhs, e') <- tcExpr p e+tcExpr (Case spi li ct e as) = do+ (ps, tyLhs, e') <- tcExpr e tyRhs <- freshTypeVar (ps', as') <- mapAccumM (tcAlt tyLhs tyRhs) ps as- return (ps', tyRhs, Case spi ct e' as')+ return (ps', tyRhs, Case spi li ct e' as') -tcArg :: HasPosition p => p -> String -> Doc -> PredSet -> Type -> Expression a+tcArg :: HasSpanInfo p => p -> String -> Doc -> PredSet -> Type -> Expression a -> TCM (PredSet, Expression PredType) tcArg p what doc ps ty e =- tcExpr p e >>- unify p what (doc $-$ text "Term:" <+> ppExpr 0 e) ps ty+ tcExpr e >>- unify p what (doc $-$ text "Term:" <+> pPrintPrec 0 e) ps ty tcAlt :: Type -> Type -> PredSet -> Alt a -> TCM (PredSet, Alt PredType) tcAlt tyLhs tyRhs ps a@(Alt p t rhs) = tcAltern tyLhs p t rhs >>-- unify p "case alternative" (ppAlt a) ps tyRhs+ unify p "case alternative" (pPrint a) ps tyRhs tcAltern :: Type -> SpanInfo -> Pattern a -> Rhs a -> TCM (PredSet, Type, Alt PredType)@@ -1245,48 +1293,86 @@ (ps, t', ps', ty', rhs') <- withLocalValueEnv $ do bindLambdaVars t (ps, t') <-- tcPatternArg p "case pattern" (ppAlt (Alt p t rhs)) emptyPredSet tyLhs t+ tcPatternArg p "case pattern" (pPrint (Alt p t rhs)) emptyPredSet tyLhs t (ps', ty', rhs') <- tcRhs rhs return (ps, t', ps', ty', rhs')- ps'' <- reducePredSet p "alternative" (ppAlt (Alt p t' rhs'))+ ps'' <- reducePredSet p "alternative" (pPrint (Alt p t' rhs')) (ps `Set.union` ps') return (ps'', ty', Alt p t' rhs') -tcQual :: HasPosition p => p -> PredSet -> Statement a+tcQual :: HasSpanInfo p => p -> PredSet -> Statement a -> TCM (PredSet, Statement PredType) tcQual p ps (StmtExpr spi e) = do- (ps', e') <- tcExpr p e >>- unify p "guard" (ppExpr 0 e) ps boolType+ (ps', e') <- tcExpr e >>- unify p "guard" (pPrintPrec 0 e) ps boolType return (ps', StmtExpr spi e')-tcQual _ ps (StmtDecl spi ds) = do+tcQual _ ps (StmtDecl spi li ds) = do (ps', ds') <- tcDecls ds- return (ps `Set.union` ps', StmtDecl spi ds')+ return (ps `Set.union` ps', StmtDecl spi li ds') tcQual p ps q@(StmtBind spi t e) = do alpha <- freshTypeVar- (ps', e') <- tcArg p "generator" (ppStmt q) ps (listType alpha) e+ (ps', e') <- tcArg p "generator" (pPrint q) ps (listType alpha) e bindLambdaVars t- (ps'', t') <- tcPatternArg p "generator" (ppStmt q) ps' alpha t+ (ps'', t') <- tcPatternArg p "generator" (pPrint q) ps' alpha t return (ps'', StmtBind spi t' e') -tcStmt :: HasPosition p => p -> PredSet -> Maybe Type -> Statement a+tcStmt :: HasSpanInfo p => p -> PredSet -> Maybe Type -> Statement a -> TCM ((PredSet, Maybe Type), Statement PredType) tcStmt p ps mTy (StmtExpr spi e) = do (ps', ty) <- maybe freshMonadType (return . (,) emptyPredSet) mTy alpha <- freshTypeVar- (ps'', e') <- tcExpr p e >>-- unify p "statement" (ppExpr 0 e) (ps `Set.union` ps') (applyType ty [alpha])+ (ps'', e') <- tcExpr e >>-+ unify p "statement" (pPrintPrec 0 e) (ps `Set.union` ps') (applyType ty [alpha]) return ((ps'', Just ty), StmtExpr spi e')-tcStmt _ ps mTy (StmtDecl spi ds) = do+tcStmt _ ps mTy (StmtDecl spi li ds) = do (ps', ds') <- tcDecls ds- return ((ps `Set.union` ps', mTy), StmtDecl spi ds')+ return ((ps `Set.union` ps', mTy), StmtDecl spi li ds') tcStmt p ps mTy st@(StmtBind spi t e) = do- (ps', ty) <- maybe freshMonadType (return . (,) emptyPredSet) mTy+ failable <- checkFailableBind t+ let freshMType = if failable then freshMonadFailType else freshMonadType+ (ps', ty) <- maybe freshMType (return . (,) emptyPredSet) mTy alpha <- freshTypeVar (ps'', e') <-- tcArg p "statement" (ppStmt st) (ps `Set.union` ps') (applyType ty [alpha]) e+ tcArg p "statement" (pPrint st) (ps `Set.union` ps') (applyType ty [alpha]) e bindLambdaVars t- (ps''', t') <- tcPatternArg p "statement" (ppStmt st) ps'' alpha t+ (ps''', t') <- tcPatternArg p "statement" (pPrint st) ps'' alpha t return ((ps''', Just ty), StmtBind spi t' e') +checkFailableBind :: Pattern a -> TCM Bool+checkFailableBind (ConstructorPattern _ _ idt ps ) = do+ tcEnv <- getTyConsEnv+ case qualLookupTypeInfo idt tcEnv of+ [RenamingType _ _ _ ] -> or <$> mapM checkFailableBind ps -- or [] == False+ [DataType _ _ cs]+ | length cs == 1 -> or <$> mapM checkFailableBind ps+ | otherwise -> return True+ _ -> return True+checkFailableBind (InfixPattern _ _ p1 idt p2) = do+ tcEnv <- getTyConsEnv+ case qualLookupTypeInfo idt tcEnv of+ [RenamingType _ _ _ ] -> (||) <$> checkFailableBind p1+ <*> checkFailableBind p2+ [DataType _ _ cs]+ | length cs == 1 -> (||) <$> checkFailableBind p1+ <*> checkFailableBind p2+ | otherwise -> return True+ _ -> return True+checkFailableBind (RecordPattern _ _ idt fs ) = do+ tcEnv <- getTyConsEnv+ case qualLookupTypeInfo idt tcEnv of+ [RenamingType _ _ _ ] -> or <$> mapM (checkFailableBind . fieldContent) fs+ [DataType _ _ cs]+ | length cs == 1 -> or <$> mapM (checkFailableBind . fieldContent) fs+ | otherwise -> return True+ _ -> return True+ where fieldContent (Field _ _ c) = c+checkFailableBind (TuplePattern _ ps ) =+ or <$> mapM checkFailableBind ps+checkFailableBind (AsPattern _ _ p ) = checkFailableBind p+checkFailableBind (ParenPattern _ p ) = checkFailableBind p+checkFailableBind (LazyPattern _ _ ) = return False+checkFailableBind (VariablePattern _ _ _ ) = return False+checkFailableBind _ = return True+ tcInfixOp :: InfixOp a -> TCM (PredSet, Type, InfixOp PredType) tcInfixOp (InfixOp _ op) = do m <- getModuleIdent@@ -1302,7 +1388,7 @@ -- The first unification in 'tcField' cannot fail; it serves only for -- instantiating the type variables in the field label's type. -tcField :: (Position -> a b -> TCM (PredSet, Type, a PredType))+tcField :: (SpanInfo -> a b -> TCM (PredSet, Type, a PredType)) -> String -> (a b -> Doc) -> Type -> PredSet -> Field (a b) -> TCM (PredSet, Field (a PredType)) tcField check what doc ty ps (Field p l x) = do@@ -1311,14 +1397,22 @@ (ps', ty') <- inst (labelType m l vEnv) let TypeArrow ty1 ty2 = ty' _ <- unify p "field label" empty emptyPredSet ty emptyPredSet ty1- (ps'', x') <- check (spanInfo2Pos p) x >>-+ (ps'', x') <- check p x >>- unify p ("record " ++ what) (doc x) (ps `Set.union` ps') ty2 return (ps'', Field p l x') --- The function 'tcArrow' checks that its argument can be used as--- an arrow type a -> b and returns the pair (a,b).+tcMissingField :: HasSpanInfo p => p -> Type -> QualIdent -> TCM PredSet+tcMissingField p ty l = do+ m <- getModuleIdent+ vEnv <- getValueEnv+ (ps, ty') <- inst (labelType m l vEnv)+ let TypeArrow _ ty2 = ty'+ let ps' = Set.singleton (Pred qDataId ty2)+ unify p "field label" empty ps ty' ps' (TypeArrow ty ty2) -tcArrow :: HasPosition p => p -> String -> Doc -> Type -> TCM (Type, Type)+-- | Checks that it's argument can be used as an arrow type @a -> b@ and returns+-- the pair @(a, b)@.+tcArrow :: HasSpanInfo p => p -> String -> Doc -> Type -> TCM (Type, Type) tcArrow p what doc ty = do theta <- getTypeSubst unaryArrow (subst theta ty)@@ -1337,7 +1431,7 @@ -- The function 'tcBinary' checks that its argument can be used as an arrow type -- a -> b -> c and returns the triple (a,b,c). -tcBinary :: HasPosition p => p -> String -> Doc -> Type+tcBinary :: HasSpanInfo p => p -> String -> Doc -> Type -> TCM (Type, Type, Type) tcBinary p what doc ty = tcArrow p what doc ty >>= uncurry binaryArrow where@@ -1354,7 +1448,7 @@ -- Unification: The unification uses Robinson's algorithm. -unify :: HasPosition p => p -> String -> Doc -> PredSet -> Type -> PredSet+unify :: HasSpanInfo p => p -> String -> Doc -> PredSet -> Type -> PredSet -> Type -> TCM PredSet unify p what doc ps1 ty1 ps2 ty2 = do theta <- getTypeSubst@@ -1424,12 +1518,12 @@ -- restricted by the current predicate set after the reduction and thus -- may cause a further extension of the current type substitution. -reducePredSet :: HasPosition p => p -> String -> Doc -> PredSet -> TCM PredSet+reducePredSet :: HasSpanInfo p => p -> String -> Doc -> PredSet -> TCM PredSet reducePredSet p what doc ps = do m <- getModuleIdent clsEnv <- getClassEnv theta <- getTypeSubst- inEnv <- (fmap $ fmap $ subst theta) <$> getInstEnv+ inEnv <- fmap (fmap (subst theta)) <$> getInstEnv let ps' = subst theta ps (ps1, ps2) = partitionPredSet $ minPredSet clsEnv $ reducePreds inEnv ps' theta' <-@@ -1449,7 +1543,7 @@ fmap (expandAliasType tys . snd3) (lookupInstInfo (qcls, tc) $ fst inEnv) _ -> Nothing -reportMissingInstance :: HasPosition p => ModuleIdent -> p -> String -> Doc+reportMissingInstance :: HasSpanInfo p => ModuleIdent -> p -> String -> Doc -> InstEnv' -> TypeSubst -> Pred -> TCM TypeSubst reportMissingInstance m p what doc inEnv theta (Pred qcls ty) = case subst theta ty of@@ -1492,7 +1586,7 @@ -- types that satisfies all constraints for the ambiguous type variable. An -- error is reported if no such type exists. -applyDefaults :: HasPosition p => p -> String -> Doc -> Set.Set Int -> PredSet+applyDefaults :: HasSpanInfo p => p -> String -> Doc -> Set.Set Int -> PredSet -> Type -> TCM PredSet applyDefaults p what doc fvs ps ty = do m <- getModuleIdent@@ -1553,6 +1647,12 @@ freshMonadType :: TCM (PredSet, Type) freshMonadType = freshPredType [qMonadId] +freshMonadFailType :: TCM (PredSet, Type)+freshMonadFailType = freshPredType [qMonadFailId]++freshDataType :: TCM (PredSet, Type)+freshDataType = freshPredType [qDataId]+ freshConstrained :: [Type] -> TCM Type freshConstrained = freshVar . TypeConstrained @@ -1690,52 +1790,52 @@ -- --------------------------------------------------------------------------- errPolymorphicVar :: Ident -> Message-errPolymorphicVar v = posMessage v $ hsep $ map text+errPolymorphicVar v = spanInfoMessage v $ hsep $ map text ["Variable", idName v, "has a polymorphic type"] -errTypeSigTooGeneral :: HasPosition a => a -> ModuleIdent -> Doc -> QualTypeExpr+errTypeSigTooGeneral :: ModuleIdent -> Doc -> QualTypeExpr -> TypeScheme -> Message-errTypeSigTooGeneral p m what qty tySc = posMessage p $ vcat+errTypeSigTooGeneral m what qty tySc = spanInfoMessage qty $ vcat [ text "Type signature too general", what , text "Inferred type:" <+> ppTypeScheme m tySc- , text "Type signature:" <+> ppQualTypeExpr qty+ , text "Type signature:" <+> pPrint qty ] -errMethodTypeTooSpecific :: HasPosition a => a -> ModuleIdent -> Doc -> PredType+errMethodTypeTooSpecific :: HasSpanInfo a => a -> ModuleIdent -> Doc -> PredType -> TypeScheme -> Message-errMethodTypeTooSpecific p m what pty tySc = posMessage p $ vcat+errMethodTypeTooSpecific p m what pty tySc = spanInfoMessage p $ vcat [ text "Method type too specific", what , text "Inferred type:" <+> ppTypeScheme m tySc , text "Expected type:" <+> ppPredType m pty ] -errNonFunctionType :: HasPosition a => a -> String -> Doc -> ModuleIdent -> Type+errNonFunctionType :: HasSpanInfo a => a -> String -> Doc -> ModuleIdent -> Type -> Message-errNonFunctionType p what doc m ty = posMessage p $ vcat+errNonFunctionType p what doc m ty = spanInfoMessage p $ vcat [ text "Type error in" <+> text what, doc , text "Type:" <+> ppType m ty , text "Cannot be applied" ] -errNonBinaryOp :: HasPosition a => a -> String -> Doc -> ModuleIdent -> Type+errNonBinaryOp :: HasSpanInfo a => a -> String -> Doc -> ModuleIdent -> Type -> Message-errNonBinaryOp p what doc m ty = posMessage p $ vcat+errNonBinaryOp p what doc m ty = spanInfoMessage p $ vcat [ text "Type error in" <+> text what, doc , text "Type:" <+> ppType m ty , text "Cannot be used as binary operator" ] -errTypeMismatch :: HasPosition a => a -> String -> Doc -> ModuleIdent -> Type+errTypeMismatch :: HasSpanInfo a => a -> String -> Doc -> ModuleIdent -> Type -> Type -> Doc -> Message-errTypeMismatch p what doc m ty1 ty2 reason = posMessage p $ vcat+errTypeMismatch p what doc m ty1 ty2 reason = spanInfoMessage p $ vcat [ text "Type error in" <+> text what, doc , text "Inferred type:" <+> ppType m ty2 , text "Expected type:" <+> ppType m ty1 , reason ] -errSkolemFieldLabel :: HasPosition a => a -> Ident -> Message-errSkolemFieldLabel p l = posMessage p $ hsep $ map text+errSkolemFieldLabel :: HasSpanInfo a => a -> Ident -> Message+errSkolemFieldLabel p l = spanInfoMessage p $ hsep $ map text ["Existential type escapes with type of record selector", escName l] errRecursiveType :: ModuleIdent -> Int -> Type -> Doc@@ -1748,25 +1848,25 @@ , text "are incompatible" ] -errIncompatibleLabelTypes :: HasPosition a => a -> ModuleIdent -> Ident -> Type+errIncompatibleLabelTypes :: HasSpanInfo a => a -> ModuleIdent -> Ident -> Type -> Type -> Message-errIncompatibleLabelTypes p m l ty1 ty2 = posMessage p $ sep+errIncompatibleLabelTypes p m l ty1 ty2 = spanInfoMessage p $ sep [ text "Labeled types" <+> ppIdent l <+> text "::" <+> ppType m ty1 , nest 10 $ text "and" <+> ppIdent l <+> text "::" <+> ppType m ty2 , text "are incompatible" ] -errMissingInstance :: HasPosition a => ModuleIdent -> a -> String -> Doc -> Pred+errMissingInstance :: HasSpanInfo a => ModuleIdent -> a -> String -> Doc -> Pred -> Message-errMissingInstance m p what doc pr = posMessage p $ vcat+errMissingInstance m p what doc pr = spanInfoMessage p $ vcat [ text "Missing instance for" <+> ppPred m pr , text "in" <+> text what , doc ] -errAmbiguousTypeVariable :: HasPosition a => ModuleIdent -> a -> String -> Doc+errAmbiguousTypeVariable :: HasSpanInfo a => ModuleIdent -> a -> String -> Doc -> PredSet -> Type -> Int -> Message-errAmbiguousTypeVariable m p what doc ps ty tv = posMessage p $ vcat+errAmbiguousTypeVariable m p what doc ps ty tv = spanInfoMessage p $ vcat [ text "Ambiguous type variable" <+> ppType m (TypeVariable tv) , text "in type" <+> ppPredType m (PredType ps ty) , text "inferred for" <+> text what
src/Checks/TypeSyntaxCheck.hs view
@@ -26,8 +26,7 @@ import Control.Monad (unless, when) import qualified Control.Monad.State as S (State, runState, gets, modify) import Data.List (nub)-import qualified Data.Map as Map-import Data.Maybe (fromMaybe, isNothing)+import Data.Maybe (isNothing) import Curry.Base.Ident import Curry.Base.Position@@ -37,7 +36,7 @@ import Curry.Syntax.Pretty import Base.Expr (Expr (fv))-import Base.Messages (Message, posMessage, internalError)+import Base.Messages (Message, spanInfoMessage, internalError) import Base.TopEnv import Base.Utils (findMultiples, findDouble) @@ -55,20 +54,19 @@ -- type classes are added to this environment and the declarations are checked -- within this environment. -typeSyntaxCheck :: [KnownExtension] -> TCEnv -> Module a- -> ((Module a, [KnownExtension]), [Message])-typeSyntaxCheck exts tcEnv mdl@(Module _ _ m _ _ ds) =+typeSyntaxCheck :: TCEnv -> Module a -> (Module a, [Message])+typeSyntaxCheck tcEnv mdl@(Module _ _ _ m _ _ ds) = case findMultiples $ map getIdent tcds of [] -> if length dfds <= 1 then runTSCM (checkModule mdl) state- else ((mdl, exts), [errMultipleDefaultDeclarations dfps])- tss -> ((mdl, exts), map errMultipleDeclarations tss)+ else (mdl, [errMultipleDefaultDeclarations dfps])+ tss -> (mdl, map errMultipleDeclarations tss) where tcds = filter isTypeOrClassDecl ds dfds = filter isDefaultDecl ds- dfps = map (\(DefaultDecl p _) -> spanInfo2Pos p) dfds+ dfps = map (\(DefaultDecl p _) -> p) dfds tEnv = foldr (bindType m) (fmap toTypeKind tcEnv) tcds- state = TSCState m tEnv exts Map.empty 1 []+ state = TSCState m tEnv 1 [] -- Type Syntax Check Monad type TSCM = S.State TSCState@@ -77,8 +75,6 @@ data TSCState = TSCState { moduleIdent :: ModuleIdent , typeEnv :: TypeEnv- , extensions :: [KnownExtension]- , renameEnv :: RenameEnv , nextId :: Integer , errors :: [Message] }@@ -92,31 +88,6 @@ getTypeEnv :: TSCM TypeEnv getTypeEnv = S.gets typeEnv -hasExtension :: KnownExtension -> TSCM Bool-hasExtension ext = S.gets (elem ext . extensions)--enableExtension :: KnownExtension -> TSCM ()-enableExtension e = S.modify $ \s -> s { extensions = e : extensions s }--getExtensions :: TSCM [KnownExtension]-getExtensions = S.gets extensions--getRenameEnv :: TSCM RenameEnv-getRenameEnv = S.gets renameEnv--modifyRenameEnv :: (RenameEnv -> RenameEnv) -> TSCM ()-modifyRenameEnv f = S.modify $ \s -> s { renameEnv = f $ renameEnv s }--withLocalEnv :: TSCM a -> TSCM a-withLocalEnv act = do- oldEnv <- getRenameEnv- res <- act- modifyRenameEnv $ const oldEnv- return res--resetEnv :: TSCM ()-resetEnv = modifyRenameEnv $ const Map.empty- newId :: TSCM Integer newId = do curId <- S.gets nextId@@ -144,214 +115,58 @@ bindType m (TypeDecl _ tc _ _) = bindTypeKind m tc (Alias qtc) where qtc = qualifyWith m tc-bindType m (ClassDecl _ _ cls _ ds) = bindTypeKind m cls (Class qcls ms)+bindType m (ClassDecl _ _ _ cls _ ds) = bindTypeKind m cls (Class qcls ms) where qcls = qualifyWith m cls ms = concatMap methods ds bindType _ _ = id --- As preparation for the kind check, type variables within type declarations--- have to be renamed since existentially quantified type variable may shadow--- a universally quantified variable from the left hand side of a type--- declaration.---- TODO: This renaming may be used to support scoped type variables in future.---- TODO: In the long run, this renaming may be merged with the syntax check--- renaming and moved into a separate module.--type RenameEnv = Map.Map Ident Ident--class Rename a where- rename :: a -> TSCM a--renameTypeSig :: (Expr a, Rename a) => a -> TSCM a-renameTypeSig x = withLocalEnv $ do- env <- getRenameEnv- bindVars (filter (`notElem` Map.keys env) $ fv x)- rename x--renameReset :: Rename a => a -> TSCM a-renameReset x = withLocalEnv $ resetEnv >> rename x--instance Rename a => Rename [a] where- rename = mapM rename--instance Rename (Decl a) where- rename (InfixDecl p fix pr ops) = return $ InfixDecl p fix pr ops- rename (DataDecl p tc tvs cs clss) = withLocalEnv $ do- bindVars tvs- DataDecl p tc <$> rename tvs <*> rename cs <*> pure clss- rename (ExternalDataDecl p tc tvs) = withLocalEnv $ do- bindVars tvs- ExternalDataDecl p tc <$> rename tvs- rename (NewtypeDecl p tc tvs nc clss) = withLocalEnv $ do- bindVars tvs- NewtypeDecl p tc <$> rename tvs <*> rename nc <*> pure clss- rename (TypeDecl p tc tvs ty) = withLocalEnv $ do- bindVars tvs- TypeDecl p tc <$> rename tvs <*> rename ty- rename (TypeSig p fs qty) = TypeSig p fs <$> renameTypeSig qty- rename (FunctionDecl p a f eqs) = FunctionDecl p a f <$> renameReset eqs- rename (ExternalDecl p fs) = return $ ExternalDecl p fs- rename (PatternDecl p ts rhs) = PatternDecl p ts <$> renameReset rhs- rename (FreeDecl p fvs) = return $ FreeDecl p fvs- rename (DefaultDecl p tys) = DefaultDecl p <$> mapM renameTypeSig tys- rename (ClassDecl p cx cls tv ds) = withLocalEnv $ do- bindVar tv- ClassDecl p <$> rename cx <*> pure cls <*> rename tv <*> rename ds- rename (InstanceDecl p cx cls ty ds) = withLocalEnv $ do- bindVars (fv ty)- InstanceDecl p <$> rename cx <*> pure cls <*> rename ty <*> renameReset ds--instance Rename ConstrDecl where- rename (ConstrDecl p c tys) = withLocalEnv $ do- ConstrDecl p <$> pure c <*> rename tys- rename (ConOpDecl p ty1 op ty2) = withLocalEnv $ do- ConOpDecl p <$> rename ty1 <*> pure op <*> rename ty2- rename (RecordDecl p c fs) = withLocalEnv $ do- RecordDecl p <$> pure c <*> rename fs--instance Rename FieldDecl where- rename (FieldDecl p ls ty) = FieldDecl p ls <$> rename ty--instance Rename NewConstrDecl where- rename (NewConstrDecl p c ty) = NewConstrDecl p c <$> rename ty- rename (NewRecordDecl p c (l, ty)) = NewRecordDecl p c . (,) l <$> rename ty--instance Rename Constraint where- rename (Constraint spi cls ty) = Constraint spi cls <$> rename ty--instance Rename QualTypeExpr where- rename (QualTypeExpr spi cx ty) = QualTypeExpr spi <$> rename cx <*> rename ty--instance Rename TypeExpr where- rename (ConstructorType spi tc) = return $ ConstructorType spi tc- rename (ApplyType spi ty1 ty2) = ApplyType spi <$> rename ty1 <*> rename ty2- rename (VariableType spi tv) = VariableType spi <$> rename tv- rename (TupleType spi tys) = TupleType spi <$> rename tys- rename (ListType spi ty) = ListType spi <$> rename ty- rename (ArrowType spi ty1 ty2) = ArrowType spi <$> rename ty1 <*> rename ty2- rename (ParenType spi ty) = ParenType spi <$> rename ty- rename (ForallType spi vs ty) = do- bindVars vs- ForallType spi <$> mapM rename vs <*> rename ty--instance Rename (Equation a) where- rename (Equation p lhs rhs) = Equation p lhs <$> rename rhs--instance Rename (Rhs a) where- rename (SimpleRhs spi e ds) = SimpleRhs spi <$> rename e <*> rename ds- rename (GuardedRhs spi es ds) = GuardedRhs spi <$> rename es <*> rename ds--instance Rename (CondExpr a) where- rename (CondExpr spi c e) = CondExpr spi <$> rename c <*> rename e--instance Rename (Expression a) where- rename (Literal spi a l) = return $ Literal spi a l- rename (Variable spi a v) = return $ Variable spi a v- rename (Constructor spi a c) = return $ Constructor spi a c- rename (Paren spi e) = Paren spi <$> rename e- rename (Typed spi e qty) = Typed spi <$> rename e <*> renameTypeSig qty- rename (Record spi a c fs) = Record spi a c <$> rename fs- rename (RecordUpdate spi e fs) = RecordUpdate spi <$> rename e <*> rename fs- rename (Tuple spi es) = Tuple spi <$> rename es- rename (List spi a es) = List spi a <$> rename es- rename (ListCompr spi e stmts) = ListCompr spi <$> rename e <*> rename stmts- rename (EnumFrom spi e) = EnumFrom spi <$> rename e- rename (EnumFromThen spi e1 e2) = EnumFromThen spi <$> rename e1 <*> rename e2- rename (EnumFromTo spi e1 e2) = EnumFromTo spi <$> rename e1 <*> rename e2- rename (EnumFromThenTo spi e1 e2 e3) =- EnumFromThenTo spi <$> rename e1 <*> rename e2 <*> rename e3- rename (UnaryMinus spi e) = UnaryMinus spi <$> rename e- rename (Apply spi e1 e2) = Apply spi <$> rename e1 <*> rename e2- rename (InfixApply spi e1 op e2) =- flip (InfixApply spi) op <$> rename e1 <*> rename e2- rename (LeftSection spi e op) = flip (LeftSection spi) op <$> rename e- rename (RightSection spi op e) = RightSection spi op <$> rename e- rename (Lambda spi ts e) = Lambda spi ts <$> rename e- rename (Let spi ds e) = Let spi <$> rename ds <*> rename e- rename (Do spi stmts e) = Do spi <$> rename stmts <*> rename e- rename (IfThenElse spi c e1 e2) =- IfThenElse spi <$> rename c <*> rename e1 <*> rename e2- rename (Case spi ct e alts) = Case spi ct <$> rename e <*> rename alts--instance Rename (Statement a) where- rename (StmtExpr spi e) = StmtExpr spi <$> rename e- rename (StmtDecl spi ds) = StmtDecl spi <$> rename ds- rename (StmtBind spi t e) = StmtBind spi t <$> rename e--instance Rename (Alt a) where- rename (Alt spi t rhs) = Alt spi t <$> rename rhs--instance Rename a => Rename (Field a) where- rename (Field spi l x) = Field spi l <$> rename x--instance Rename Ident where- rename tv | isAnonId tv = renameIdent tv <$> newId- | otherwise = fromMaybe tv <$> lookupVar tv--bindVar :: Ident -> TSCM ()-bindVar tv = do- k <- newId- modifyRenameEnv $ Map.insert tv (renameIdent tv k)--bindVars :: [Ident] -> TSCM ()-bindVars = mapM_ bindVar--lookupVar :: Ident -> TSCM (Maybe Ident)-lookupVar tv = do- env <- getRenameEnv- return $ Map.lookup tv env- -- When type declarations are checked, the compiler will allow anonymous -- type variables on the left hand side of the declaration, but not on -- the right hand side. Function and pattern declarations must be -- traversed because they can contain local type signatures. -checkModule :: Module a -> TSCM (Module a, [KnownExtension])-checkModule (Module spi ps m es is ds) = do+checkModule :: Module a -> TSCM (Module a)+checkModule (Module spi li ps m es is ds) = do ds' <- mapM checkDecl ds- ds'' <- rename ds'- exts <- getExtensions- return (Module spi ps m es is ds'', exts)+ return $ Module spi li ps m es is ds' checkDecl :: Decl a -> TSCM (Decl a)-checkDecl (DataDecl p tc tvs cs clss) = do+checkDecl (DataDecl p tc tvs cs clss) = do checkTypeLhs tvs cs' <- mapM (checkConstrDecl tvs) cs- mapM_ checkClass clss+ mapM_ (checkClass False) clss return $ DataDecl p tc tvs cs' clss-checkDecl (NewtypeDecl p tc tvs nc clss) = do+checkDecl (NewtypeDecl p tc tvs nc clss) = do checkTypeLhs tvs nc' <- checkNewConstrDecl tvs nc- mapM_ checkClass clss+ mapM_ (checkClass False) clss return $ NewtypeDecl p tc tvs nc' clss-checkDecl (TypeDecl p tc tvs ty) = do+checkDecl (TypeDecl p tc tvs ty) = do checkTypeLhs tvs ty' <- checkClosedType tvs ty return $ TypeDecl p tc tvs ty'-checkDecl (TypeSig p vs qty) =+checkDecl (TypeSig p vs qty) = TypeSig p vs <$> checkQualType qty-checkDecl (FunctionDecl a p f eqs) =- FunctionDecl a p f <$> mapM checkEquation eqs-checkDecl (PatternDecl p t rhs) =- PatternDecl p t <$> checkRhs rhs-checkDecl (DefaultDecl p tys) = DefaultDecl p <$> mapM checkType tys-checkDecl (ClassDecl p cx cls clsvar ds) = do+checkDecl (FunctionDecl a p f eqs) = FunctionDecl a p f <$>+ mapM checkEquation eqs+checkDecl (PatternDecl p t rhs) = PatternDecl p t <$> checkRhs rhs+checkDecl (DefaultDecl p tys) = DefaultDecl p <$>+ mapM (checkClosedType []) tys+checkDecl (ClassDecl p li cx cls clsvar ds) = do checkTypeVars "class declaration" [clsvar] cx' <- checkClosedContext [clsvar] cx checkSimpleContext cx' ds' <- mapM checkDecl ds mapM_ (checkClassMethod clsvar) ds'- return $ ClassDecl p cx' cls clsvar ds'-checkDecl (InstanceDecl p cx qcls inst ds) = do- checkClass qcls+ return $ ClassDecl p li cx' cls clsvar ds'+checkDecl (InstanceDecl p li cx qcls inst ds) = do+ checkClass True qcls QualTypeExpr _ cx' inst' <- checkQualType $ QualTypeExpr NoSpanInfo cx inst checkSimpleContext cx' checkInstanceType p inst'- InstanceDecl p cx' qcls inst' <$> mapM checkDecl ds-checkDecl d = return d+ InstanceDecl p li cx' qcls inst' <$> mapM checkDecl ds+checkDecl d = return d checkConstrDecl :: [Ident] -> ConstrDecl -> TSCM ConstrDecl checkConstrDecl tvs (ConstrDecl p c tys) = do@@ -390,10 +205,9 @@ checkClassMethod :: Ident -> Decl a -> TSCM () checkClassMethod tv (TypeSig spi _ qty) = do- unless (tv `elem` fv qty) $ report $ errAmbiguousType p tv+ unless (tv `elem` fv qty) $ report $ errAmbiguousType spi tv let QualTypeExpr _ cx _ = qty- when (tv `elem` fv cx) $ report $ errConstrainedClassVariable p tv- where p = spanInfo2Pos spi+ when (tv `elem` fv cx) $ report $ errConstrainedClassVariable spi tv checkClassMethod _ _ = ok checkInstanceType :: SpanInfo -> InstanceType -> TSCM ()@@ -403,7 +217,7 @@ not (isTypeSyn (typeConstr inst) tEnv) && not (any isAnonId $ typeVariables inst) && isNothing (findDouble $ fv inst)) $- report $ errIllegalInstanceType (spanInfo2Pos p) inst+ report $ errIllegalInstanceType p inst checkTypeLhs :: [Ident] -> TSCM () checkTypeLhs = checkTypeVars "left hand side of type declaration"@@ -416,7 +230,7 @@ checkTypeVars _ [] = ok checkTypeVars what (tv : tvs) = do unless (isAnonId tv) $ do- isTypeConstrOrClass <- (not . null . lookupTypeKind tv) <$> getTypeEnv+ isTypeConstrOrClass <- not . null . lookupTypeKind tv <$> getTypeEnv when isTypeConstrOrClass $ report $ errNoVariable tv what when (tv `elem` tvs) $ report $ errNonLinear tv what checkTypeVars what tvs@@ -429,10 +243,10 @@ checkEquation (Equation p lhs rhs) = Equation p lhs <$> checkRhs rhs checkRhs :: Rhs a -> TSCM (Rhs a)-checkRhs (SimpleRhs spi e ds) = SimpleRhs spi <$> checkExpr e- <*> mapM checkDecl ds-checkRhs (GuardedRhs spi es ds) = GuardedRhs spi <$> mapM checkCondExpr es- <*> mapM checkDecl ds+checkRhs (SimpleRhs spi li e ds) =+ SimpleRhs spi li <$> checkExpr e <*> mapM checkDecl ds+checkRhs (GuardedRhs spi li es ds) =+ GuardedRhs spi li <$> mapM checkCondExpr es <*> mapM checkDecl ds checkCondExpr :: CondExpr a -> TSCM (CondExpr a) checkCondExpr (CondExpr spi g e) = CondExpr spi <$> checkExpr g <*> checkExpr e@@ -466,24 +280,24 @@ checkExpr (InfixApply spi e1 op e2) = InfixApply spi <$> checkExpr e1 <*> return op <*> checkExpr e2-checkExpr (LeftSection spi e op) =- flip (LeftSection spi) op <$> checkExpr e-checkExpr (RightSection spi op e) = RightSection spi op <$> checkExpr e-checkExpr (Lambda spi ts e) = Lambda spi ts <$> checkExpr e-checkExpr (Let spi ds e) = Let spi <$> mapM checkDecl ds- <*> checkExpr e-checkExpr (Do spi sts e) = Do spi <$> mapM checkStmt sts- <*> checkExpr e-checkExpr (IfThenElse spi e1 e2 e3) = IfThenElse spi <$> checkExpr e1+checkExpr (LeftSection spi e op) = flip (LeftSection spi) op <$>+ checkExpr e+checkExpr (RightSection spi op e) = RightSection spi op <$> checkExpr e+checkExpr (Lambda spi ts e) = Lambda spi ts <$> checkExpr e+checkExpr (Let spi li ds e) = Let spi li <$> mapM checkDecl ds+ <*> checkExpr e+checkExpr (Do spi li sts e) = Do spi li <$> mapM checkStmt sts+ <*> checkExpr e+checkExpr (IfThenElse spi e1 e2 e3) = IfThenElse spi <$> checkExpr e1 <*> checkExpr e2 <*> checkExpr e3-checkExpr (Case spi ct e alts) = Case spi ct <$> checkExpr e- <*> mapM checkAlt alts+checkExpr (Case spi li ct e alts) = Case spi li ct <$> checkExpr e+ <*> mapM checkAlt alts checkStmt :: Statement a -> TSCM (Statement a)-checkStmt (StmtExpr spi e) = StmtExpr spi <$> checkExpr e-checkStmt (StmtBind spi t e) = StmtBind spi t <$> checkExpr e-checkStmt (StmtDecl spi ds) = StmtDecl spi <$> mapM checkDecl ds+checkStmt (StmtExpr spi e) = StmtExpr spi <$> checkExpr e+checkStmt (StmtBind spi t e) = StmtBind spi t <$> checkExpr e+checkStmt (StmtDecl spi li ds) = StmtDecl spi li <$> mapM checkDecl ds checkAlt :: Alt a -> TSCM (Alt a) checkAlt (Alt spi t rhs) = Alt spi t <$> checkRhs rhs@@ -513,7 +327,7 @@ checkConstraint :: Constraint -> TSCM Constraint checkConstraint c@(Constraint spi qcls ty) = do- checkClass qcls+ checkClass False qcls ty' <- checkType ty unless (isVariableType $ rootType ty') $ report $ errIllegalConstraint c return $ Constraint spi qcls ty'@@ -521,16 +335,22 @@ rootType (ApplyType _ ty' _) = ty' rootType ty' = ty' -checkClass :: QualIdent -> TSCM ()-checkClass qcls = do+checkClass :: Bool -> QualIdent -> TSCM ()+checkClass isInstDecl qcls = do m <- getModuleIdent tEnv <- getTypeEnv case qualLookupTypeKind qcls tEnv of [] -> report $ errUndefinedClass qcls- [Class _ _] -> ok+ [Class c _]+ | c == qDataId -> when (isInstDecl && m /= preludeMIdent) $ report $+ errIllegalDataInstance qcls+ | otherwise -> ok [_] -> report $ errUndefinedClass qcls tks -> case qualLookupTypeKind (qualQualify m qcls) tEnv of- [Class _ _] -> ok+ [Class c _]+ | c == qDataId -> when (isInstDecl && m /= preludeMIdent) $ report $+ errIllegalDataInstance qcls+ | otherwise -> ok [_] -> report $ errUndefinedClass qcls _ -> report $ errAmbiguousIdent qcls $ map origName tks @@ -557,9 +377,9 @@ _ -> report (errAmbiguousIdent tc $ map origName tks) >> return c checkType (ApplyType spi ty1 ty2) = ApplyType spi <$> checkType ty1 <*> checkType ty2-checkType v@(VariableType spi tv)- | isAnonId tv = return v- | otherwise = checkType $ ConstructorType spi (qualify tv)+checkType (VariableType spi tv)+ | isAnonId tv = (VariableType spi . renameIdent tv) <$> newId+ | otherwise = checkType $ ConstructorType spi (qualify tv) checkType (TupleType spi tys) = TupleType spi <$> mapM checkType tys checkType (ListType spi ty) = ListType spi <$> checkType ty checkType (ArrowType spi ty1 ty2) = ArrowType spi <$> checkType ty1@@ -578,13 +398,6 @@ checkClosed tvs (ParenType _ ty) = checkClosed tvs ty checkClosed tvs (ForallType _ vs ty) = checkClosed (tvs ++ vs) ty -checkUsedExtension :: Position -> String -> KnownExtension -> TSCM ()-checkUsedExtension pos msg ext = do- enabled <- hasExtension ext- unless enabled $ do- report $ errMissingLanguageExtension pos msg ext- enableExtension ext- -- --------------------------------------------------------------------------- -- Auxiliary definitions -- ---------------------------------------------------------------------------@@ -592,11 +405,11 @@ getIdent :: Decl a -> Ident getIdent (DataDecl _ tc _ _ _) = tc getIdent (ExternalDataDecl _ tc _) = tc-getIdent (NewtypeDecl _ tc _ _ _) = tc-getIdent (TypeDecl _ tc _ _) = tc-getIdent (ClassDecl _ _ cls _ _) = cls-getIdent _ =- internalError "Checks.TypeSyntaxCheck.getIdent: no type or class declaration"+getIdent (NewtypeDecl _ tc _ _ _) = tc+getIdent (TypeDecl _ tc _ _) = tc+getIdent (ClassDecl _ _ _ cls _ _) = cls+getIdent _ = internalError+ "Checks.TypeSyntaxCheck.getIdent: no type or class declaration" isTypeSyn :: QualIdent -> TypeEnv -> Bool isTypeSyn tc tEnv = case qualLookupTypeKind tc tEnv of@@ -607,27 +420,21 @@ -- Error messages -- --------------------------------------------------------------------------- -errMultipleDefaultDeclarations :: [Position] -> Message-errMultipleDefaultDeclarations ps = posMessage (head ps) $+errMultipleDefaultDeclarations :: [SpanInfo] -> Message+errMultipleDefaultDeclarations spis = spanInfoMessage (head spis) $ text "More than one default declaration:" $+$- nest 2 (vcat $ map showPos ps)- where showPos = text . showLine+ nest 2 (vcat $ map showPos spis)+ where showPos = text . showLine . getPosition errMultipleDeclarations :: [Ident] -> Message-errMultipleDeclarations is = posMessage i $+errMultipleDeclarations is = spanInfoMessage i $ text "Multiple declarations of" <+> text (escName i) <+> text "at:" $+$ nest 2 (vcat $ map showPos is) where i = head is showPos = text . showLine . getPosition -errMissingLanguageExtension :: Position -> String -> KnownExtension -> Message-errMissingLanguageExtension p what ext = posMessage p $- text what <+> text "are not supported in standard Curry." $+$- nest 2 (text "Use flag -X" <+> text (show ext)- <+> text "to enable this extension.")- errUndefined :: String -> QualIdent -> Message-errUndefined what qident = posMessage qident $ hsep $ map text+errUndefined what qident = spanInfoMessage qident $ hsep $ map text ["Undefined", what, qualName qident] errUndefinedClass :: QualIdent -> Message@@ -637,48 +444,55 @@ errUndefinedType = errUndefined "type" errAmbiguousIdent :: QualIdent -> [QualIdent] -> Message-errAmbiguousIdent qident qidents = posMessage qident $+errAmbiguousIdent qident qidents = spanInfoMessage qident $ text "Ambiguous identifier" <+> text (escQualName qident) $+$ text "It could refer to:" $+$ nest 2 (vcat (map (text . qualName) qidents)) -errAmbiguousType :: Position -> Ident -> Message-errAmbiguousType p ident = posMessage p $ hsep $ map text+errAmbiguousType :: SpanInfo -> Ident -> Message+errAmbiguousType spi ident = spanInfoMessage spi $ hsep $ map text [ "Method type does not mention class variable", idName ident ] -errConstrainedClassVariable :: Position -> Ident -> Message-errConstrainedClassVariable p ident = posMessage p $ hsep $ map text+errConstrainedClassVariable :: SpanInfo -> Ident -> Message+errConstrainedClassVariable spi ident = spanInfoMessage spi $ hsep $ map text [ "Method context must not constrain class variable", idName ident ] errNonLinear :: Ident -> String -> Message-errNonLinear tv what = posMessage tv $ hsep $ map text+errNonLinear tv what = spanInfoMessage tv $ hsep $ map text [ "Type variable", idName tv, "occurs more than once in", what ] errNoVariable :: Ident -> String -> Message-errNoVariable tv what = posMessage tv $ hsep $ map text $- [ "Type constructor or type class identifier", idName tv, "used in", what ]+errNoVariable tv what = spanInfoMessage tv $ hsep $ map text+ ["Type constructor or type class identifier", idName tv, "used in", what] errUnboundVariable :: Ident -> Message-errUnboundVariable tv = posMessage tv $ hsep $ map text+errUnboundVariable tv = spanInfoMessage tv $ hsep $ map text [ "Unbound type variable", idName tv ] errIllegalConstraint :: Constraint -> Message-errIllegalConstraint c@(Constraint _ qcls _) = posMessage qcls $ vcat- [ text "Illegal class constraint" <+> ppConstraint c+errIllegalConstraint c@(Constraint _ qcls _) = spanInfoMessage qcls $ vcat+ [ text "Illegal class constraint" <+> pPrint c , text "Constraints must be of the form C u or C (u t1 ... tn)," , text "where C is a type class, u is a type variable and t1, ..., tn are types." ] errIllegalSimpleConstraint :: Constraint -> Message-errIllegalSimpleConstraint c@(Constraint _ qcls _) = posMessage qcls $ vcat- [ text "Illegal class constraint" <+> ppConstraint c+errIllegalSimpleConstraint c@(Constraint _ qcls _) = spanInfoMessage qcls $ vcat+ [ text "Illegal class constraint" <+> pPrint c , text "Constraints in class and instance declarations must be of" , text "the form C u, where C is a type class and u is a type variable." ] -errIllegalInstanceType :: Position -> InstanceType -> Message-errIllegalInstanceType p inst = posMessage p $ vcat+errIllegalInstanceType :: SpanInfo -> InstanceType -> Message+errIllegalInstanceType spi inst = spanInfoMessage spi $ vcat [ text "Illegal instance type" <+> ppInstanceType inst , text "The instance type must be of the form (T u_1 ... u_n)," , text "where T is not a type synonym and u_1, ..., u_n are" , text "mutually distinct, non-anonymous type variables."+ ]++errIllegalDataInstance :: QualIdent -> Message+errIllegalDataInstance qcls = spanInfoMessage qcls $ vcat+ [ text "Illegal instance of" <+> ppQIdent qcls+ , text "Instances of this class cannot be defined."+ , text "Instead, they are automatically derived if possible." ]
src/Checks/WarnCheck.hs view
@@ -21,28 +21,34 @@ import Prelude hiding ((<>)) #endif +import Control.Applicative+ ((<|>)) import Control.Monad- (filterM, foldM_, guard, liftM, liftM2, when, unless)+ (filterM, foldM_, guard, liftM, liftM2, when, unless, void) import Control.Monad.State.Strict (State, execState, gets, modify) import qualified Data.IntSet as IntSet (IntSet, empty, insert, notMember, singleton, union, unions)-import qualified Data.Map as Map (empty, insert, lookup)+import qualified Data.Map as Map (empty, insert, lookup, (!)) import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import Data.List ((\\), intersect, intersectBy, nub, sort, unionBy) import Data.Char (isLower, isUpper, toLower, toUpper, isAlpha)+import qualified Data.Set.Extra as Set+import Data.Tuple.Extra+ (snd3) import Curry.Base.Ident import Curry.Base.Position import Curry.Base.Pretty import Curry.Base.SpanInfo import Curry.Syntax-import Curry.Syntax.Pretty (ppDecl, ppPattern, ppExpr, ppIdent)+import Curry.Syntax.Utils (typeVariables)+import Curry.Syntax.Pretty (pPrint) -import Base.CurryTypes (ppTypeScheme)-import Base.Messages (Message, posMessage, internalError)+import Base.CurryTypes (ppTypeScheme, fromPred, toPredSet)+import Base.Messages (Message, spanInfoMessage, internalError) import Base.NestEnv ( NestEnv, emptyEnv, localNestEnv, nestEnv, unnestEnv , qualBindNestEnv, qualInLocalNestEnv, qualLookupNestEnv , qualModifyNestEnv)@@ -66,6 +72,7 @@ -- - overlapping case alternatives -- - non-adjacent function rules -- - wrong case mode+-- - redundant context warnCheck :: WarnOpts -> CaseMode -> AliasEnv -> ValueEnv -> TCEnv -> ClassEnv -> Module a -> [Message] warnCheck wOpts cOpts aEnv valEnv tcEnv clsEnv mdl@@ -76,7 +83,8 @@ checkMissingTypeSignatures ds checkModuleAlias is checkCaseMode ds- where Module _ _ mid es is ds = fmap (const ()) mdl+ checkRedContext ds+ where Module _ _ _ mid es is ds = fmap (const ()) mdl type ScopeEnv = NestEnv IdInfo @@ -196,16 +204,16 @@ impName (ImportTypeWith _ t _) = t warnMultiplyImportedModule :: ModuleIdent -> Message-warnMultiplyImportedModule mid = posMessage mid $ hsep $ map text+warnMultiplyImportedModule mid = spanInfoMessage mid $ hsep $ map text ["Module", moduleName mid, "is imported more than once"] warnMultiplyImportedSymbol :: ModuleIdent -> Ident -> Message-warnMultiplyImportedSymbol mid ident = posMessage ident $ hsep $ map text+warnMultiplyImportedSymbol mid ident = spanInfoMessage ident $ hsep $ map text [ "Symbol", escName ident, "from module", moduleName mid , "is imported more than once" ] warnMultiplyHiddenSymbol :: ModuleIdent -> Ident -> Message-warnMultiplyHiddenSymbol mid ident = posMessage ident $ hsep $ map text+warnMultiplyHiddenSymbol mid ident = spanInfoMessage ident $ hsep $ map text [ "Symbol", escName ident, "from module", moduleName mid , "is hidden more than once" ] @@ -244,28 +252,28 @@ check (_ , env) _ = return (mkIdent "", env) warnDisjoinedFunctionRules :: Ident -> Position -> Message-warnDisjoinedFunctionRules ident pos = posMessage ident $ hsep (map text+warnDisjoinedFunctionRules ident pos = spanInfoMessage ident $ hsep (map text [ "Rules for function", escName ident, "are disjoined" ]) <+> parens (text "first occurrence at" <+> text (showLine pos)) checkDecl :: Decl () -> WCM ()-checkDecl (DataDecl _ _ vs cs _) = inNestedScope $ do+checkDecl (DataDecl _ _ vs cs _) = inNestedScope $ do mapM_ insertTypeVar vs mapM_ checkConstrDecl cs reportUnusedTypeVars vs-checkDecl (NewtypeDecl _ _ vs nc _) = inNestedScope $ do+checkDecl (NewtypeDecl _ _ vs nc _) = inNestedScope $ do mapM_ insertTypeVar vs checkNewConstrDecl nc reportUnusedTypeVars vs-checkDecl (TypeDecl _ _ vs ty) = inNestedScope $ do+checkDecl (TypeDecl _ _ vs ty) = inNestedScope $ do mapM_ insertTypeVar vs checkTypeExpr ty reportUnusedTypeVars vs-checkDecl (FunctionDecl p _ f eqs) = checkFunctionDecl p f eqs-checkDecl (PatternDecl _ p rhs) = checkPattern p >> checkRhs rhs-checkDecl (DefaultDecl _ tys) = mapM_ checkTypeExpr tys-checkDecl (ClassDecl _ _ _ _ ds) = mapM_ checkDecl ds-checkDecl (InstanceDecl p cx cls ty ds) = do+checkDecl (FunctionDecl p _ f eqs) = checkFunctionDecl p f eqs+checkDecl (PatternDecl _ p rhs) = checkPattern p >> checkRhs rhs+checkDecl (DefaultDecl _ tys) = mapM_ checkTypeExpr tys+checkDecl (ClassDecl _ _ _ _ _ ds) = mapM_ checkDecl ds+checkDecl (InstanceDecl p _ cx cls ty ds) = do checkOrphanInstance p cx cls ty checkMissingMethodImplementations p cls ds mapM_ checkDecl ds@@ -322,12 +330,15 @@ checkFunctionPatternMatch :: SpanInfo -> Ident -> [Equation ()] -> WCM () checkFunctionPatternMatch spi f eqs = do let pats = map (\(Equation _ lhs _) -> snd (flatLhs lhs)) eqs- (nonExhaustive, overlapped, nondet) <- checkPatternMatching pats+ let guards = map eq2Guards eqs+ (nonExhaustive, overlapped, nondet) <- checkPatternMatching pats guards unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $- warnMissingPattern p ("an equation for " ++ escName f) nonExhaustive+ warnMissingPattern spi ("an equation for " ++ escName f) nonExhaustive when (nondet || not (null overlapped)) $ warnFor WarnOverlapping $ report $- warnNondetOverlapping p ("Function " ++ escName f)- where p = spanInfo2Pos spi+ warnNondetOverlapping spi ("Function " ++ escName f)+ where eq2Guards :: Equation () -> [CondExpr ()]+ eq2Guards (Equation _ _ (GuardedRhs _ _ conds _)) = conds+ eq2Guards _ = [] -- Check an equation for warnings. -- This is done in a seperate scope as the left-hand-side may introduce@@ -368,11 +379,11 @@ -- Because local declarations may introduce new variables, we need -- another scope nesting. checkRhs :: Rhs () -> WCM ()-checkRhs (SimpleRhs _ e ds) = inNestedScope $ do+checkRhs (SimpleRhs _ _ e ds) = inNestedScope $ do checkLocalDeclGroup ds checkExpr e reportUnusedVars-checkRhs (GuardedRhs _ ce ds) = inNestedScope $ do+checkRhs (GuardedRhs _ _ ce ds) = inNestedScope $ do checkLocalDeclGroup ds mapM_ checkCondExpr ce reportUnusedVars@@ -407,16 +418,16 @@ mapM_ (insertPattern False) ps checkExpr e reportUnusedVars-checkExpr (Let _ ds e) = inNestedScope $ do+checkExpr (Let _ _ ds e) = inNestedScope $ do checkLocalDeclGroup ds checkExpr e reportUnusedVars-checkExpr (Do _ sts e) = checkStatements sts e+checkExpr (Do _ _ sts e) = checkStatements sts e checkExpr (IfThenElse _ e1 e2 e3) = mapM_ checkExpr [e1, e2, e3]-checkExpr (Case _ ct e alts) = do+checkExpr (Case spi _ ct e alts) = do checkExpr e mapM_ checkAlt alts- checkCaseAlts ct alts+ checkCaseAlts spi ct alts checkExpr _ = ok checkStatements :: [Statement ()] -> Expression () -> WCM ()@@ -426,9 +437,9 @@ reportUnusedVars checkStatement :: Statement () -> WCM ()-checkStatement (StmtExpr _ e) = checkExpr e-checkStatement (StmtDecl _ ds) = checkLocalDeclGroup ds-checkStatement (StmtBind _ p e) = do+checkStatement (StmtExpr _ e) = checkExpr e+checkStatement (StmtDecl _ _ ds) = checkLocalDeclGroup ds+checkStatement (StmtBind _ p e) = do checkPattern p >> insertPattern False p checkExpr e @@ -452,11 +463,12 @@ let ocls = getOrigName m cls tcEnv otc = getOrigName m tc tcEnv unless (isLocalIdent m ocls || isLocalIdent m otc) $ report $- warnOrphanInstance (spanInfo2Pos p) $ ppDecl $ InstanceDecl p cx cls ty []+ warnOrphanInstance p $ pPrint $+ InstanceDecl p WhitespaceLayout cx cls ty [] where tc = typeConstr ty -warnOrphanInstance :: Position -> Doc -> Message-warnOrphanInstance p doc = posMessage p $ text "Orphan instance:" <+> doc+warnOrphanInstance :: SpanInfo -> Doc -> Message+warnOrphanInstance spi doc = spanInfoMessage spi $ text "Orphan instance:" <+> doc -- ----------------------------------------------------------------------------- -- Check for missing method implementations@@ -469,12 +481,12 @@ clsEnv <- gets classEnv let ocls = getOrigName m cls tcEnv ms = classMethods ocls clsEnv- mapM_ (report . warnMissingMethodImplementation (spanInfo2Pos p)) $+ mapM_ (report . warnMissingMethodImplementation p) $ filter ((null fs ||) . not . flip (hasDefaultImpl ocls) clsEnv) $ ms \\ fs where fs = map unRenameIdent $ concatMap impls ds -warnMissingMethodImplementation :: Position -> Ident -> Message-warnMissingMethodImplementation p f = posMessage p $ hsep $ map text+warnMissingMethodImplementation :: SpanInfo -> Ident -> Message+warnMissingMethodImplementation spi f = spanInfoMessage spi $ hsep $ map text ["No explicit implementation for method", escName f] -- -----------------------------------------------------------------------------@@ -502,7 +514,7 @@ _ -> internalError $ "Checks.WarnCheck.getTyScheme: " ++ show q warnMissingTypeSignature :: ModuleIdent -> Ident -> TypeScheme -> Message-warnMissingTypeSignature mid i tys = posMessage i $ fsep+warnMissingTypeSignature mid i tys = spanInfoMessage i $ fsep [ text "Top-level binding with no type signature:" , nest 2 $ text (showIdent i) <+> text "::" <+> ppTypeScheme mid tys ]@@ -524,14 +536,14 @@ unless (null aliasClash) $ mapM_ (report . warnAliasNameClash ) aliasClash warnModuleNameClash :: ModuleIdent -> Message-warnModuleNameClash mid = posMessage mid $ hsep $ map text+warnModuleNameClash mid = spanInfoMessage mid $ hsep $ map text ["The module alias", escModuleName mid , "overlaps with the current module name"] warnAliasNameClash :: [ModuleIdent] -> Message warnAliasNameClash [] = internalError "WarnCheck.warnAliasNameClash: empty list"-warnAliasNameClash mids = posMessage (head mids) $ text+warnAliasNameClash mids = spanInfoMessage (head mids) $ text "Overlapping module aliases" $+$ nest 2 (vcat (map myppAlias mids)) where myppAlias mid = ppLine (getPosition mid) <> text ":" <+> text (escModuleName mid)@@ -540,23 +552,27 @@ -- Check for overlapping/unreachable and non-exhaustive case alternatives -- ----------------------------------------------------------------------------- -checkCaseAlts :: CaseType -> [Alt ()] -> WCM ()-checkCaseAlts _ [] = ok-checkCaseAlts ct alts@(Alt spi _ _ : _) = do+checkCaseAlts :: SpanInfo -> CaseType -> [Alt ()] -> WCM ()+checkCaseAlts _ _ [] = ok+checkCaseAlts spi ct alts = do+ let spis = map (\(Alt s _ _) -> s) alts let pats = map (\(Alt _ pat _) -> [pat]) alts- (nonExhaustive, overlapped, nondet) <- checkPatternMatching pats+ let guards = map alt2Guards alts+ (nonExhaustive, overlapped, nondet) <- checkPatternMatching pats guards case ct of Flex -> do unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $- warnMissingPattern p "an fcase alternative" nonExhaustive+ warnMissingPattern spi "an fcase alternative" nonExhaustive when (nondet || not (null overlapped)) $ warnFor WarnOverlapping $ report- $ warnNondetOverlapping p "An fcase expression"+ $ warnNondetOverlapping spi "An fcase expression" Rigid -> do unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $- warnMissingPattern p "a case alternative" nonExhaustive- unless (null overlapped) $ warnFor WarnOverlapping $ report $- warnUnreachablePattern p overlapped- where p = spanInfo2Pos spi+ warnMissingPattern spi "a case alternative" nonExhaustive+ unless (null overlapped) $ void $ mapM (warnFor WarnOverlapping . report) $+ map (\(i, pat) -> warnUnreachablePattern (spis !! i) pat) overlapped+ where alt2Guards :: Alt () -> [CondExpr ()]+ alt2Guards (Alt _ _ (GuardedRhs _ _ conds _)) = conds+ alt2Guards _ = [] -- ----------------------------------------------------------------------------- -- Check for non-exhaustive and overlapping patterns.@@ -574,19 +590,19 @@ -- matching in function declarations and (f)case expressions. -- ----------------------------------------------------------------------------- -checkPatternMatching :: [[Pattern ()]]- -> WCM ([ExhaustivePats], [[Pattern ()]], Bool)-checkPatternMatching pats = do+checkPatternMatching :: [[Pattern ()]] -> [[CondExpr ()]]+ -> WCM ([ExhaustivePats], [OverlappingPats], Bool)+checkPatternMatching pats guards = do -- 1. We simplify the patterns by removing syntactic sugar temporarily -- for a simpler implementation. simplePats <- mapM (mapM simplifyPat) pats -- 2. We compute missing and used pattern matching alternatives- (missing, used, nondet) <- processEqs (zip [1..] simplePats)+ (missing, used, nondet) <- processEqs (zip3 [0..] simplePats guards) -- 3. If any, we report the missing patterns, whereby we re-add the syntactic -- sugar removed in step (1) for a more precise output. nonExhaustive <- mapM tidyExhaustivePats missing- let overlap = [ eqn | (i, eqn) <- zip [1..] pats, i `IntSet.notMember` used]- return (nonExhaustive , overlap, nondet)+ let overlap = [(i, eqn) | (i, eqn) <- zip [0..] pats, i `IntSet.notMember` used]+ return (nonExhaustive, overlap, nondet) -- |Simplify a 'Pattern' until it only consists of -- * Variables@@ -649,23 +665,38 @@ -- number of possible patterns. Missing literals are therefore converted -- into the form @ ... x ... with x `notElem` [l1, ..., ln]@. type EqnPats = [Pattern ()]+type EqnGuards = [CondExpr ()] type EqnNo = Int-type EqnInfo = (EqnNo, EqnPats)+type EqnInfo = (EqnNo, EqnPats, EqnGuards) type ExhaustivePats = (EqnPats, [(Ident, [Literal])])+type OverlappingPats = (EqnNo, EqnPats) type EqnSet = IntSet.IntSet -- |Compute the missing pattern by inspecting the first patterns and -- categorize them as literal, constructor or variable patterns. processEqs :: [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool) processEqs [] = return ([], IntSet.empty, False)-processEqs eqs@((n, ps):_)- | null ps = return ([], IntSet.singleton n, length eqs > 1)- | any isLitPat firstPats = processLits eqs- | any isConPat firstPats = processCons eqs- | all isVarPat firstPats = processVars eqs- | otherwise = internalError "Checks.WarnCheck.processEqs"+processEqs eqs@((n, ps, gs):eqs')+ | null ps = if guardsExhaustive then return ([], IntSet.singleton n, length eqs > 1)+ else do -- Current expression is guarded, thus potentially+ -- non-exhaustive. Therefore process remaining expressions.+ (missing', used', _) <- processEqs eqs'+ return (missing', IntSet.insert n used', length eqs > 1)+ | any isLitPat firstPats = processLits eqs+ | any isConPat firstPats = processCons eqs+ | all isVarPat firstPats = processVars eqs+ | otherwise = internalError "Checks.WarnCheck.processEqs" where firstPats = map firstPat eqs+ guardsExhaustive = null gs || any guardAlwaysTrue gs+ guardAlwaysTrue :: CondExpr () -> Bool+ guardAlwaysTrue (CondExpr _ e _) = case e of+ Constructor _ _ q -> qidAlwaysTrue q+ Variable _ _ q -> qidAlwaysTrue q+ _ -> False+ qidAlwaysTrue :: QualIdent -> Bool+ qidAlwaysTrue q = elem (idName $ qidIdent q) ["True", "success", "otherwise"]+ -- |Literal patterns are checked by extracting the matched literals -- and constructing a pattern for any missing case.@@ -688,7 +719,7 @@ defaults = [ shiftPat q' | q' <- qs, isVarPat (firstPat q') ] -- Pattern for all non-matched literals defaultPat = ( VariablePattern NoSpanInfo () newVar :- replicate (length (snd q) - 1) wildPat+ replicate (length (snd3 q) - 1) wildPat , [(newVar, usedLits)] ) newVar = mkIdent "x"@@ -735,7 +766,7 @@ -- default alternatives (variable pattern) defaults = [ shiftPat q' | q' <- qs, isVarPat (firstPat q') ] -- Pattern for a non-matched constructors- defaultPat c = (mkPattern c : replicate (length (snd q) - 1) wildPat, [])+ defaultPat c = (mkPattern c : replicate (length (snd3 q) - 1) wildPat, []) mkPattern c = ConstructorPattern NoSpanInfo () (qualifyLike (fst $ head used_cons) (constrIdent c)) (replicate (length $ constrTypes c) wildPat)@@ -755,17 +786,17 @@ makeCon c a ps = let (args, rest) = splitAt a ps in ConstructorPattern NoSpanInfo () c args : rest-- removeFirstCon c a (n, p:ps)- | isVarPat p = (n, replicate a wildPat ++ ps)- | isCon c p = (n, patArgs p ++ ps)+ + removeFirstCon c a (n, p:ps, gs)+ | isVarPat p = (n, replicate a wildPat ++ ps, gs)+ | isCon c p = (n, patArgs p ++ ps, gs) removeFirstCon _ _ _ = internalError "Checks.WarnCheck.removeFirstCon" -- |Variable patterns are exhaustive, so they are checked by simply -- checking the following patterns. processVars :: [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool) processVars [] = error "WarnCheck.processVars"-processVars eqs@((n, _) : _) = do+processVars eqs@((n, _, _) : _) = do let ovlp = length eqs > 1 (missing, used, nd) <- processEqs (map shiftPat eqs) return ( map (\(xs, ys) -> (wildPat : xs, ys)) missing@@ -795,14 +826,17 @@ getTyCons tc = do tc' <- unAlias tc tcEnv <- gets tyConsEnv- return $ case lookupTypeInfo (unqualify tc) tcEnv of- [DataType _ _ cs] -> cs- [RenamingType _ _ nc] -> [nc]- _ -> case qualLookupTypeInfo tc' tcEnv of- [DataType _ _ cs] -> cs- [RenamingType _ _ nc] -> [nc]- err -> internalError $ "Checks.WarnCheck.getTyCons: " ++- show tc ++ ' ' : show err ++ '\n' : show tcEnv+ let getTyCons' :: [TypeInfo] -> Either String [DataConstr]+ getTyCons' ti = case ti of+ [DataType _ _ cs] -> Right cs+ [RenamingType _ _ nc] -> Right $ [nc]+ _ -> Left $ "Checks.WarnCheck.getTyCons: " ++ show tc ++ ' ' : show ti ++ '\n' : show tcEnv+ csResult = getTyCons' (qualLookupTypeInfo tc tcEnv)+ <|> getTyCons' (qualLookupTypeInfo tc' tcEnv)+ <|> getTyCons' (lookupTypeInfo (unqualify tc) tcEnv) -- Fall back on unqualified lookup if qualified doesn't work+ case csResult of+ Right cs -> return cs+ Left err -> internalError err -- |Resugar the exhaustive patterns previously desugared at 'simplifyPat'. tidyExhaustivePats :: ExhaustivePats -> WCM ExhaustivePats@@ -842,13 +876,13 @@ -- |Get the first pattern of a list. firstPat :: EqnInfo -> Pattern ()-firstPat (_, [] ) = internalError "Checks.WarnCheck.firstPat: empty list"-firstPat (_, (p:_)) = p+firstPat (_, [], _) = internalError "Checks.WarnCheck.firstPat: empty list"+firstPat (_, (p:_), _) = p -- |Drop the first pattern of a list. shiftPat :: EqnInfo -> EqnInfo-shiftPat (_, [] ) = internalError "Checks.WarnCheck.shiftPat: empty list"-shiftPat (n, (_:ps)) = (n, ps)+shiftPat (_, [], _ ) = internalError "Checks.WarnCheck.shiftPat: empty list"+shiftPat (n, (_:ps), gs) = (n, ps, gs) -- |Wildcard pattern. wildPat :: Pattern ()@@ -905,8 +939,8 @@ -- |Warning message for non-exhaustive patterns. -- To shorten the output only the first 'maxPattern' are printed, -- additional pattern are abbreviated by dots.-warnMissingPattern :: Position -> String -> [ExhaustivePats] -> Message-warnMissingPattern p loc pats = posMessage p+warnMissingPattern :: SpanInfo -> String -> [ExhaustivePats] -> Message+warnMissingPattern spi loc pats = spanInfoMessage spi $ text "Pattern matches are non-exhaustive" $+$ text "In" <+> text loc <> char ':' $+$ nest 2 (text "Patterns not matched:" $+$ nest 2 (vcat (ppExPats pats)))@@ -918,31 +952,27 @@ ppExPat (ps, cs) | null cs = ppPats | otherwise = ppPats <+> text "with" <+> hsep (map ppCons cs)- where ppPats = hsep (map (ppPattern 2) ps)- ppCons (i, lits) = ppIdent i <+> text "`notElem`"- <+> ppExpr 0 (List NoSpanInfo () (map (Literal NoSpanInfo ()) lits))+ where ppPats = hsep (map (pPrintPrec 2) ps)+ ppCons (i, lits) = pPrint i <+> text "`notElem`"+ <+> pPrintPrec 0 (List NoSpanInfo () (map (Literal NoSpanInfo ()) lits)) -- |Warning message for unreachable patterns. -- To shorten the output only the first 'maxPattern' are printed, -- additional pattern are abbreviated by dots.-warnUnreachablePattern :: Position -> [[Pattern a]] -> Message-warnUnreachablePattern p pats = posMessage p+warnUnreachablePattern :: SpanInfo -> [Pattern a] -> Message+warnUnreachablePattern spi pats = spanInfoMessage spi $ text "Pattern matches are potentially unreachable" $+$ text "In a case alternative:"- $+$ nest 2 (vcat (ppExPats pats) <+> text "->" <+> text "...")+ $+$ nest 2 (ppPat pats <+> text "->" <+> text "...") where- ppExPats ps- | length ps > maxPattern = ppPats ++ [text "..."]- | otherwise = ppPats- where ppPats = map ppPat (take maxPattern ps)- ppPat ps = hsep (map (ppPattern 2) ps)+ ppPat ps = hsep (map (pPrintPrec 2) ps) -- |Maximum number of missing patterns to be shown. maxPattern :: Int maxPattern = 4 -warnNondetOverlapping :: Position -> String -> Message-warnNondetOverlapping p loc = posMessage p $+warnNondetOverlapping :: SpanInfo -> String -> Message+warnNondetOverlapping spi loc = spanInfoMessage spi $ text loc <+> text "is potentially non-deterministic due to overlapping rules" -- -----------------------------------------------------------------------------@@ -951,10 +981,6 @@ checkShadowing x = warnFor WarnNameShadowing $ shadowsVar x >>= maybe ok (report . warnShadowing x) -checkTypeShadowing :: Ident -> WCM ()-checkTypeShadowing x = warnFor WarnNameShadowing $- shadowsTypeVar x >>= maybe ok (report . warnTypeShadowing x)- reportUnusedVars :: WCM () reportUnusedVars = reportAllUnusedVars WarnUnusedBindings @@ -977,26 +1003,26 @@ -- sides. insertDecl :: Decl a -> WCM ()-insertDecl (DataDecl _ d _ cs _) = do+insertDecl (DataDecl _ d _ cs _) = do insertTypeConsId d mapM_ insertConstrDecl cs-insertDecl (ExternalDataDecl _ d _) = insertTypeConsId d-insertDecl (NewtypeDecl _ d _ nc _) = do+insertDecl (ExternalDataDecl _ d _) = insertTypeConsId d+insertDecl (NewtypeDecl _ d _ nc _) = do insertTypeConsId d insertNewConstrDecl nc-insertDecl (TypeDecl _ t _ ty) = do+insertDecl (TypeDecl _ t _ ty) = do insertTypeConsId t insertTypeExpr ty-insertDecl (FunctionDecl _ _ f _) = do+insertDecl (FunctionDecl _ _ f _) = do cons <- isConsId f unless cons $ insertVar f-insertDecl (ExternalDecl _ vs) = mapM_ (insertVar . varIdent) vs-insertDecl (PatternDecl _ p _) = insertPattern False p-insertDecl (FreeDecl _ vs) = mapM_ (insertVar . varIdent) vs-insertDecl (ClassDecl _ _ cls _ ds) = do+insertDecl (ExternalDecl _ vs) = mapM_ (insertVar . varIdent) vs+insertDecl (PatternDecl _ p _) = insertPattern False p+insertDecl (FreeDecl _ vs) = mapM_ (insertVar . varIdent) vs+insertDecl (ClassDecl _ _ _ cls _ ds) = do insertTypeConsId cls mapM_ insertVar $ concatMap methods ds-insertDecl _ = ok+insertDecl _ = ok insertTypeExpr :: TypeExpr -> WCM () insertTypeExpr (VariableType _ _) = ok@@ -1116,9 +1142,6 @@ shadowsVar :: Ident -> WCM (Maybe Ident) shadowsVar v = gets (shadows $ commonId v) -shadowsTypeVar :: Ident -> WCM (Maybe Ident)-shadowsTypeVar v = gets (shadows $ typeId v)- visitId :: Ident -> WCM () visitId v = modifyScope (qualModifyNestEnv visitVariable (commonId v)) @@ -1163,7 +1186,7 @@ isUnref :: WcState -> QualIdent -> Bool isUnref s qid = let sc = scope s- in (any (not . variableVisited) (qualLookupNestEnv qid sc))+ in any (not . variableVisited) (qualLookupNestEnv qid sc) && qualInLocalNestEnv qid sc isVar :: QualIdent -> WcState -> Bool@@ -1229,12 +1252,12 @@ checkCaseModeDecl (FreeDecl _ vs) = mapM_ (checkCaseModeID isVarName . varIdent) vs checkCaseModeDecl (DefaultDecl _ tys) = mapM_ checkTypeExpr tys-checkCaseModeDecl (ClassDecl _ cx cls tv ds) = do+checkCaseModeDecl (ClassDecl _ _ cx cls tv ds) = do checkCaseModeContext cx checkCaseModeID isClassDeclName cls checkCaseModeID isVarName tv mapM_ checkCaseModeDecl ds-checkCaseModeDecl (InstanceDecl _ cx _ inst ds) = do+checkCaseModeDecl (InstanceDecl _ _ cx _ inst ds) = do checkCaseModeContext cx checkCaseModeTypeExpr inst mapM_ checkCaseModeDecl ds@@ -1311,10 +1334,10 @@ mapM_ checkCaseModePattern ts checkCaseModeRhs :: Rhs a -> WCM ()-checkCaseModeRhs (SimpleRhs _ e ds) = do+checkCaseModeRhs (SimpleRhs _ _ e ds) = do checkCaseModeExpr e mapM_ checkCaseModeDecl ds-checkCaseModeRhs (GuardedRhs _ es ds) = do+checkCaseModeRhs (GuardedRhs _ _ es ds) = do mapM_ checkCaseModeCondExpr es mapM_ checkCaseModeDecl ds @@ -1382,25 +1405,25 @@ checkCaseModeExpr (Lambda _ ts e) = do mapM_ checkCaseModePattern ts checkCaseModeExpr e-checkCaseModeExpr (Let _ ds e) = do+checkCaseModeExpr (Let _ _ ds e) = do mapM_ checkCaseModeDecl ds checkCaseModeExpr e-checkCaseModeExpr (Do _ stms e) = do+checkCaseModeExpr (Do _ _ stms e) = do mapM_ checkCaseModeStatement stms checkCaseModeExpr e checkCaseModeExpr (IfThenElse _ e1 e2 e3) = do checkCaseModeExpr e1 checkCaseModeExpr e2 checkCaseModeExpr e3-checkCaseModeExpr (Case _ _ e as) = do+checkCaseModeExpr (Case _ _ _ e as) = do mapM_ checkCaseModeAlt as checkCaseModeExpr e checkCaseModeExpr _ = ok checkCaseModeStatement :: Statement a -> WCM ()-checkCaseModeStatement (StmtExpr _ e) = checkCaseModeExpr e-checkCaseModeStatement (StmtDecl _ ds) = mapM_ checkCaseModeDecl ds-checkCaseModeStatement (StmtBind _ t e) = do+checkCaseModeStatement (StmtExpr _ e) = checkCaseModeExpr e+checkCaseModeStatement (StmtDecl _ _ ds) = mapM_ checkCaseModeDecl ds+checkCaseModeStatement (StmtBind _ t e) = do checkCaseModePattern t checkCaseModeExpr e @@ -1443,11 +1466,151 @@ isDataDeclName _ _ = True -- ---------------------------------------------------------------------------+-- Warn for redundant context+-- ---------------------------------------------------------------------------++--traverse the AST for QualTypeExpr/Context and check for redundancy+checkRedContext :: [Decl a] -> WCM ()+checkRedContext = warnFor WarnRedundantContext . mapM_ checkRedContextDecl++getRedPredSet :: ModuleIdent -> ClassEnv -> TCEnv -> PredSet -> PredSet+getRedPredSet m cenv tcEnv ps =+ Set.map (pm Map.!) $ Set.difference qps $ minPredSet cenv qps --or fromJust $ Map.lookup+ where (qps, pm) = Set.foldr qualifyAndAddPred (Set.empty, Map.empty) ps+ qualifyAndAddPred p@(Pred qid ty) (ps', pm') =+ let qp = Pred (getOrigName m qid tcEnv) ty+ in (Set.insert qp ps', Map.insert qp p pm')++getPredFromContext :: Context -> ([Ident], PredSet)+getPredFromContext cx =+ let vs = concatMap (\(Constraint _ _ ty) -> typeVariables ty) cx+ in (vs, toPredSet vs cx)++checkRedContext' :: (Pred -> Message) -> PredSet -> WCM ()+checkRedContext' f ps = do+ m <- gets moduleId+ cenv <- gets classEnv+ tcEnv <- gets tyConsEnv+ mapM_ (report . f) (getRedPredSet m cenv tcEnv ps)++checkRedContextDecl :: Decl a -> WCM ()+checkRedContextDecl (TypeSig _ ids (QualTypeExpr _ cx _)) =+ checkRedContext' (warnRedContext (warnRedFuncString ids) vs) ps+ where (vs, ps) = getPredFromContext cx+checkRedContextDecl (FunctionDecl _ _ _ eqs) = mapM_ checkRedContextEq eqs+checkRedContextDecl (PatternDecl _ _ rhs) = checkRedContextRhs rhs+checkRedContextDecl (ClassDecl _ _ cx i _ ds) = do+ checkRedContext'+ (warnRedContext (text ("class declaration " ++ escName i)) vs)+ ps+ mapM_ checkRedContextDecl ds+ where (vs, ps) = getPredFromContext cx+checkRedContextDecl (InstanceDecl _ _ cx qid _ ds) = do+ checkRedContext'+ (warnRedContext (text ("instance declaration " ++ escQualName qid)) vs)+ ps+ mapM_ checkRedContextDecl ds+ where (vs, ps) = getPredFromContext cx+checkRedContextDecl _ = return ()++checkRedContextEq :: Equation a -> WCM ()+checkRedContextEq (Equation _ _ rhs) = checkRedContextRhs rhs++checkRedContextRhs :: Rhs a -> WCM ()+checkRedContextRhs (SimpleRhs _ _ e ds) = do+ checkRedContextExpr e+ mapM_ checkRedContextDecl ds+checkRedContextRhs (GuardedRhs _ _ cs ds) = do+ mapM_ checkRedContextCond cs+ mapM_ checkRedContextDecl ds++checkRedContextCond :: CondExpr a -> WCM ()+checkRedContextCond (CondExpr _ e1 e2) = do+ checkRedContextExpr e1+ checkRedContextExpr e2++checkRedContextExpr :: Expression a -> WCM ()+checkRedContextExpr (Paren _ e) = checkRedContextExpr e+checkRedContextExpr (Typed _ e (QualTypeExpr _ cx _)) = do+ checkRedContextExpr e+ checkRedContext' (warnRedContext (text "type signature") vs) ps+ where (vs, ps) = getPredFromContext cx+checkRedContextExpr (Record _ _ _ fs) = mapM_ checkRedContextFieldExpr fs+checkRedContextExpr (RecordUpdate _ e fs) = do+ checkRedContextExpr e+ mapM_ checkRedContextFieldExpr fs+checkRedContextExpr (Tuple _ es) = mapM_ checkRedContextExpr es+checkRedContextExpr (List _ _ es) = mapM_ checkRedContextExpr es+checkRedContextExpr (ListCompr _ e sts) = do+ checkRedContextExpr e+ mapM_ checkRedContextStmt sts+checkRedContextExpr (EnumFrom _ e) = checkRedContextExpr e+checkRedContextExpr (EnumFromThen _ e1 e2) = do+ checkRedContextExpr e1+ checkRedContextExpr e2+checkRedContextExpr (EnumFromTo _ e1 e2) = do+ checkRedContextExpr e1+ checkRedContextExpr e2+checkRedContextExpr (EnumFromThenTo _ e1 e2 e3) = do+ checkRedContextExpr e1+ checkRedContextExpr e2+ checkRedContextExpr e3+checkRedContextExpr (UnaryMinus _ e) = checkRedContextExpr e+checkRedContextExpr (Apply _ e1 e2) = do+ checkRedContextExpr e1+ checkRedContextExpr e2+checkRedContextExpr (InfixApply _ e1 _ e2) = do+ checkRedContextExpr e1+ checkRedContextExpr e2+checkRedContextExpr (LeftSection _ e _) = checkRedContextExpr e+checkRedContextExpr (RightSection _ _ e) = checkRedContextExpr e+checkRedContextExpr (Lambda _ _ e) = checkRedContextExpr e+checkRedContextExpr (Let _ _ ds e) = do+ mapM_ checkRedContextDecl ds+ checkRedContextExpr e+checkRedContextExpr (IfThenElse _ e1 e2 e3) = do+ checkRedContextExpr e1+ checkRedContextExpr e2+ checkRedContextExpr e3+checkRedContextExpr (Case _ _ _ e as) = do+ checkRedContextExpr e+ mapM_ checkRedContextAlt as+checkRedContextExpr _ = return ()++checkRedContextStmt :: Statement a -> WCM ()+checkRedContextStmt (StmtExpr _ e) = checkRedContextExpr e+checkRedContextStmt (StmtDecl _ _ ds) = mapM_ checkRedContextDecl ds+checkRedContextStmt (StmtBind _ _ e) = checkRedContextExpr e++checkRedContextAlt :: Alt a -> WCM ()+checkRedContextAlt (Alt _ _ rhs) = checkRedContextRhs rhs++checkRedContextFieldExpr :: Field (Expression a) -> WCM ()+checkRedContextFieldExpr (Field _ _ e) = checkRedContextExpr e++-- --------------------------------------------------------------------------- -- Warnings messages -- --------------------------------------------------------------------------- +warnRedFuncString :: [Ident] -> Doc+warnRedFuncString is = text "type signature for function" <>+ text (if length is == 1 then [] else "s") <+>+ csep (map (text . escName) is)++-- Doc description -> TypeVars -> Pred -> Warning+warnRedContext :: Doc -> [Ident] -> Pred -> Message+warnRedContext d vs p@(Pred qid _) = spanInfoMessage qid $+ text "Redundant context in" <+> d <> colon <+>+ quotes (pPrint $ fromPred vs p) -- idents use ` ' as quotes not ' '++-- seperate a list by ', '+csep :: [Doc] -> Doc+csep [] = empty+csep [x] = x+csep (x:xs) = x <> comma <+> csep xs+ warnCaseMode :: Ident -> CaseMode -> Message-warnCaseMode i@(Ident _ name _ ) c = posMessage i $+warnCaseMode i@(Ident _ name _ ) c = spanInfoMessage i $ text "Wrong case mode in symbol" <+> text (escName i) <+> text "due to selected case mode" <+> text (escapeCaseMode c) <> comma <+> text "try renaming to" <+> text (caseSuggestion name) <+> text "instead"@@ -1465,19 +1628,14 @@ escapeCaseMode CaseModeGoedel = "`goedel`" warnUnrefTypeVar :: Ident -> Message-warnUnrefTypeVar v = posMessage v $ hsep $ map text+warnUnrefTypeVar v = spanInfoMessage v $ hsep $ map text [ "Unreferenced type variable", escName v ] warnUnrefVar :: Ident -> Message-warnUnrefVar v = posMessage v $ hsep $ map text+warnUnrefVar v = spanInfoMessage v $ hsep $ map text [ "Unused declaration of variable", escName v ] warnShadowing :: Ident -> Ident -> Message-warnShadowing x v = posMessage x $+warnShadowing x v = spanInfoMessage x $ text "Shadowing symbol" <+> text (escName x)- <> comma <+> text "bound at:" <+> ppPosition (getPosition v)--warnTypeShadowing :: Ident -> Ident -> Message-warnTypeShadowing x v = posMessage x $- text "Shadowing type variable" <+> text (escName x) <> comma <+> text "bound at:" <+> ppPosition (getPosition v)
src/CompilerOpts.hs view
@@ -18,8 +18,9 @@ -} module CompilerOpts ( Options (..), CppOpts (..), PrepOpts (..), WarnOpts (..), DebugOpts (..)- , CaseMode (..), CymakeMode (..), Verbosity (..), TargetType (..)- , WarnFlag (..), KnownExtension (..), DumpLevel (..), dumpLevel+ , OptimizationOpts(..), CaseMode (..), CymakeMode (..), Verbosity (..)+ , TargetType (..), WarnFlag (..), KnownExtension (..), DumpLevel (..)+ , dumpLevel , defaultOptions, defaultPrepOpts, defaultWarnOpts, defaultDebugOpts , getCompilerOpts, updateOpts, usage ) where@@ -33,7 +34,7 @@ import System.FilePath ( addTrailingPathSeparator, normalise , splitSearchPath ) -import Curry.Files.Filenames (currySubdir)+import Curry.Files.Filenames (defaultOutDir) import Curry.Syntax.Extension -- -----------------------------------------------------------------------------@@ -43,24 +44,26 @@ -- |Compiler options data Options = Options -- general- { optMode :: CymakeMode -- ^ modus operandi- , optVerbosity :: Verbosity -- ^ verbosity level+ { optMode :: CymakeMode -- ^ modus operandi+ , optVerbosity :: Verbosity -- ^ verbosity level -- compilation- , optForce :: Bool -- ^ force (re-)compilation of target- , optLibraryPaths :: [FilePath] -- ^ directories to search in- -- for libraries- , optImportPaths :: [FilePath] -- ^ directories to search in- -- for imports- , optHtmlDir :: Maybe FilePath -- ^ output directory for HTML- , optUseSubdir :: Bool -- ^ use subdir for output?- , optInterface :: Bool -- ^ create a FlatCurry interface file?- , optPrepOpts :: PrepOpts -- ^ preprocessor options- , optWarnOpts :: WarnOpts -- ^ warning options- , optTargetTypes :: [TargetType] -- ^ what to generate- , optExtensions :: [KnownExtension] -- ^ enabled language extensions- , optDebugOpts :: DebugOpts -- ^ debug options- , optCaseMode :: CaseMode -- ^ case mode- , optCppOpts :: CppOpts -- ^ C preprocessor options+ , optForce :: Bool -- ^ force (re-)compilation of target+ , optLibraryPaths :: [FilePath] -- ^ directories to search in+ -- for libraries+ , optImportPaths :: [FilePath] -- ^ directories to search in+ -- for imports+ , optOutDir :: FilePath -- ^ output directory for FlatCurry, ...+ , optHtmlDir :: Maybe FilePath -- ^ output directory for HTML+ , optUseOutDir :: Bool -- ^ use subdir for output?+ , optInterface :: Bool -- ^ create a FlatCurry interface file?+ , optPrepOpts :: PrepOpts -- ^ preprocessor options+ , optWarnOpts :: WarnOpts -- ^ warning options+ , optTargetTypes :: [TargetType] -- ^ what to generate+ , optExtensions :: [KnownExtension] -- ^ enabled language extensions+ , optDebugOpts :: DebugOpts -- ^ debug options+ , optCaseMode :: CaseMode -- ^ case mode+ , optCppOpts :: CppOpts -- ^ C preprocessor options+ , optOptimizations :: OptimizationOpts -- ^ Optimization options } deriving Show -- |C preprocessor options@@ -100,24 +103,32 @@ , dbDumpSimple :: Bool -- ^ print more readable environments } deriving Show +data OptimizationOpts = OptimizationOpts+ { optDesugarNewtypes :: Bool -- ^ Desugar newtypes+ , optInlineDictionaries :: Bool -- ^ Inline type class dictionaries+ , optRemoveUnusedImports :: Bool -- ^ Remove unused imports in IL+ } deriving Show+ -- | Default compiler options defaultOptions :: Options defaultOptions = Options- { optMode = ModeMake- , optVerbosity = VerbStatus- , optForce = False- , optLibraryPaths = []- , optImportPaths = []- , optHtmlDir = Nothing- , optUseSubdir = True- , optInterface = True- , optPrepOpts = defaultPrepOpts- , optWarnOpts = defaultWarnOpts- , optTargetTypes = []- , optExtensions = []- , optDebugOpts = defaultDebugOpts- , optCaseMode = CaseModeFree- , optCppOpts = defaultCppOpts+ { optMode = ModeMake+ , optVerbosity = VerbStatus+ , optForce = False+ , optLibraryPaths = []+ , optImportPaths = []+ , optOutDir = defaultOutDir+ , optHtmlDir = Nothing+ , optUseOutDir = True+ , optInterface = True+ , optPrepOpts = defaultPrepOpts+ , optWarnOpts = defaultWarnOpts+ , optTargetTypes = []+ , optExtensions = []+ , optDebugOpts = defaultDebugOpts+ , optCaseMode = CaseModeFree+ , optCppOpts = defaultCppOpts+ , optOptimizations = defaultOptimizationOpts } -- | Default C preprocessor options@@ -153,6 +164,13 @@ , dbDumpSimple = False } +defaultOptimizationOpts :: OptimizationOpts+defaultOptimizationOpts = OptimizationOpts+ { optDesugarNewtypes = False+ , optInlineDictionaries = True+ , optRemoveUnusedImports = True+ }+ -- |Modus operandi of the program data CymakeMode = ModeHelp -- ^ Show help information and exit@@ -179,11 +197,11 @@ | Comments -- ^ Source code comments | Parsed -- ^ Parsed source code | FlatCurry -- ^ FlatCurry+ | AnnotatedFlatCurry -- ^ Annotated FlatCurry | TypedFlatCurry -- ^ Typed FlatCurry- | TypeAnnotatedFlatCurry -- ^ Type-annotated FlatCurry- | AbstractCurry -- ^ AbstractCurry- | UntypedAbstractCurry -- ^ Untyped AbstractCurry- | Html -- ^ HTML documentation+ | AbstractCurry -- ^ AbstractCurry+ | UntypedAbstractCurry -- ^ Untyped AbstractCurry+ | Html -- ^ HTML documentation | AST -- ^ Abstract-Syntax-Tree after checks | ShortAST -- ^ Abstract-Syntax-Tree with shortened decls deriving (Eq, Show)@@ -200,7 +218,8 @@ | WarnMissingSignatures -- ^ Warn for missing type signatures | WarnMissingMethods -- ^ Warn for missing method implementations | WarnOrphanInstances -- ^ Warn for orphan instances- | WarnIrregularCaseMode+ | WarnIrregularCaseMode -- ^ Warn for irregular case mode+ | WarnRedundantContext -- ^ Warn for redundant context in type signatures deriving (Eq, Bounded, Enum, Show) -- |Warning flags enabled by default@@ -209,7 +228,7 @@ [ WarnMultipleImports , WarnDisjoinedRules --, WarnUnusedGlobalBindings , WarnUnusedBindings , WarnNameShadowing , WarnOverlapping , WarnIncompletePatterns, WarnMissingSignatures, WarnMissingMethods- , WarnIrregularCaseMode+ , WarnIrregularCaseMode , WarnRedundantContext ] -- |Description and flag of warnings flags@@ -237,6 +256,8 @@ , "orphan instances" ) , ( WarnIrregularCaseMode , "irregular-case-mode" , "irregular case mode")+ , ( WarnRedundantContext , "redundant-context"+ , "redundant context") ] -- |Dump level@@ -340,6 +361,10 @@ onDebugOpts f (opts, errs) = (opts { optDebugOpts = f (optDebugOpts opts) }, errs) +onOptimOpts :: (OptimizationOpts -> OptimizationOpts) -> OptErr -> OptErr+onOptimOpts f (opts, errs)+ = (opts { optOptimizations = f (optOptimizations opts) }, errs)+ withArg :: ((a -> b) -> OptErr -> OptErr) -> (String -> a -> b) -> String -> OptErr -> OptErr withArg lift f arg = lift (f arg)@@ -405,13 +430,16 @@ map (normalise . addTrailingPathSeparator) (splitSearchPath arg) }) "dir[:dir]") "search for imports in dir[:dir]"+ , Option "o" ["outdir"]+ (ReqArg (withArg onOpts $ \ arg opts -> opts { optOutDir = arg }) "dir")+ "write compilation artifacts (FlatCurry, ...) into directory `dir'" , Option [] ["htmldir"] (ReqArg (withArg onOpts $ \ arg opts -> opts { optHtmlDir = Just arg }) "dir") "write HTML documentation into directory `dir'"- , Option "" ["no-subdir"]- (NoArg (onOpts $ \ opts -> opts { optUseSubdir = False }))- ("disable writing to `" ++ currySubdir ++ "' subdirectory")+ , Option "" ["no-outdir", "no-subdir"]+ (NoArg (onOpts $ \ opts -> opts { optUseOutDir = False }))+ ("disable writing to `" ++ defaultOutDir ++ "' subdirectory") , Option "" ["no-intf"] (NoArg (onOpts $ \ opts -> opts { optInterface = False })) "do not create an interface file"@@ -434,7 +462,7 @@ "generate FlatCurry code" , targetOption TypedFlatCurry "typed-flat" "generate typed FlatCurry code"- , targetOption TypeAnnotatedFlatCurry "type-annotated-flat"+ , targetOption AnnotatedFlatCurry "type-annotated-flat" "generate type-annotated FlatCurry code" , targetOption AbstractCurry "acy" "generate typed AbstractCurry"@@ -462,10 +490,11 @@ (NoArg (onOpts $ \ opts -> opts { optExtensions = nub $ kielExtensions ++ optExtensions opts })) "enable extended Curry functionalities"- , mkOptDescr onOpts "c" ["case-mode"] "mode" "case mode" caseModeDescriptions- , mkOptDescr onOpts "X" [] "ext" "language extension" extDescriptions- , mkOptDescr onWarnOpts "W" [] "opt" "warning option" warnDescriptions- , mkOptDescr onDebugOpts "d" [] "opt" "debug option" debugDescriptions+ , mkOptDescr onOpts "c" ["case-mode"] "mode" "case mode" caseModeDescriptions+ , mkOptDescr onOpts "X" [] "ext" "language extension" extDescriptions+ , mkOptDescr onWarnOpts "W" [] "opt" "warning option" warnDescriptions+ , mkOptDescr onDebugOpts "d" [] "opt" "debug option" debugDescriptions+ , mkOptDescr onOptimOpts "O" [] "opt" "optimization option" optimizeDescriptions , Option "" ["cpp"] (NoArg (onCppOpts $ \ opts -> opts { cppRun = True })) "run C preprocessor"@@ -480,7 +509,7 @@ = onCppOpts (addCppDefinition s v) optErr | otherwise = addErr (cppDefinitionErr arg) optErr- where (s, v) = fmap (drop 1) $ break ('=' ==) arg+ where (s, v) = drop 1 <$> break ('=' ==) arg addCppDefinition :: String -> String -> CppOpts -> CppOpts addCppDefinition s v opts =@@ -490,9 +519,9 @@ cppDefinitionErr = (++) "Invalid format for option '-D': " targetOption :: TargetType -> String -> String -> OptDescr (OptErr -> OptErr)-targetOption ty flag desc+targetOption ty flag = Option "" [flag] (NoArg (onOpts $ \ opts -> opts { optTargetTypes =- nub $ ty : optTargetTypes opts })) desc+ nub $ ty : optTargetTypes opts })) verbDescriptions :: OptErrTable Options verbDescriptions = map toDescr verbosities@@ -562,11 +591,27 @@ = (name , "dump code after " ++ desc , \ opts -> opts { dbDumpLevels = addFlag flag (dbDumpLevels opts)}) +optimizeDescriptions :: OptErrTable OptimizationOpts+optimizeDescriptions =+ [ ( "desugar-newtypes" , "desugars newtypes in FlatCurry"+ , \ opts -> opts { optDesugarNewtypes = True })+ , ( "inline-dictionaries" , "inlines type class dictionaries"+ , \ opts -> opts { optInlineDictionaries = True })+ , ( "remove-unused-imports" , "removes unused imports"+ , \ opts -> opts { optRemoveUnusedImports = True })+ , ( "no-desugar-newtypes" , "prevents desugaring of newtypes in FlatCurry"+ , \ opts -> opts { optDesugarNewtypes = False })+ , ( "no-inline-dictionaries" , "prevents inlining of type class dictionaries"+ , \ opts -> opts { optInlineDictionaries = False })+ , ( "no-remove-unused-imports", "prevents removing of unused imports"+ , \ opts -> opts { optRemoveUnusedImports = False })+ ]+ addFlag :: Eq a => a -> [a] -> [a] addFlag o opts = nub $ o : opts removeFlag :: Eq a => a -> [a] -> [a]-removeFlag o opts = filter (/= o) opts+removeFlag o = filter (/= o) -- |Update the 'Options' record by the parsed and processed arguments updateOpts :: Options -> [String] -> (Options, [String], [String])
+ src/Curry/AbstractCurry.hs view
@@ -0,0 +1,30 @@+{- |+ Module : $Header$+ Description : Library to support meta-programming in Curry+ Copyright : Michael Hanus , 2004+ Martin Engelke , 2005+ Björn Peemöller, 2013+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This library contains a definition for representing Curry programs+ in Haskell by the type 'CurryProg' and I/O actions to read Curry programs+ and transform them into this abstract representation as well as+ write them to a file.++ Note that this defines a slightly new format for AbstractCurry+ in comparison to the first proposal of 2003.++ /Assumption:/ An AbstractCurry program @Prog@ is stored in a file with+ the file extension @acy@, i.e. in a file @Prog.acy@.+-}+module Curry.AbstractCurry+ ( module Curry.AbstractCurry.Type+ , module Curry.AbstractCurry.Files+ ) where++import Curry.AbstractCurry.Type+import Curry.AbstractCurry.Files
+ src/Curry/AbstractCurry/Files.hs view
@@ -0,0 +1,61 @@+{- |+ Module : $Header$+ Description : Library to support meta-programming in Curry+ Copyright : (c) Michael Hanus , 2004+ Martin Engelke , 2005+ Björn Peemöller, 2014+ Finn Teegen , 2016+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This library contains I/O actions to read Curry programs+ and transform them into this abstract representation as well as+ write them to a file.+-}+module Curry.AbstractCurry.Files+ ( readCurry, writeCurry, showCurry+ ) where++import qualified Control.Exception as C (catch)+import Data.List (intercalate)++import Curry.Files.PathUtils ( writeModule, readModule+ , addVersion, checkVersion)++import Curry.AbstractCurry.Type++-- ---------------------------------------------------------------------------+-- Reading and writing AbstractCurry terms+-- ---------------------------------------------------------------------------++-- |Read an AbstractCurry file and return the corresponding AbstractCurry+-- program term of type 'CurryProg'+readCurry :: FilePath -> IO (Maybe CurryProg)+readCurry fn = do+ mbSrc <- readModule fn+ return $ case mbSrc of+ Nothing -> Nothing+ Just src -> case checkVersion version src of+ Left _ -> Nothing+ Right ac -> Just (read ac)++-- |Write an AbstractCurry program term into a file.+writeCurry :: FilePath -> CurryProg -> IO ()+writeCurry fn p = C.catch (writeModule fn $ addVersion version $ showCurry p)+ ioError++-- |Show an AbstractCurry program in a nicer way+showCurry :: CurryProg -> String+showCurry (CurryProg mname imps dflt clss insts types funcs ops)+ = "CurryProg " ++ show mname ++ "\n"+ ++ show imps ++ "\n"+ ++ showsPrec 11 dflt "\n"+ ++ wrapList clss+ ++ wrapList insts+ ++ wrapList types+ ++ wrapList funcs+ ++ wrapList ops+ where wrapList xs = " [" ++ intercalate ",\n " (map show xs) ++ "]\n"
+ src/Curry/AbstractCurry/Type.hs view
@@ -0,0 +1,329 @@+{- |+ Module : $Header$+ Description : Library to support meta-programming in Curry+ Copyright : Michael Hanus , 2004+ Martin Engelke , 2005+ Björn Peemöller, 2015+ Finn Teegen , 2016+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This library contains a definition for representing Curry programs+ in Haskell by the type 'CurryProg' and I/O actions to read Curry programs+ and transform them into this abstract representation as well as+ write them to a file.++ Note that this defines a slightly new format for AbstractCurry+ in comparison to the first proposal of 2003.+-}+module Curry.AbstractCurry.Type+ ( CurryProg (..), MName, QName, CVisibility (..), CTVarIName+ , CDefaultDecl (..), CClassDecl (..), CInstanceDecl (..)+ , CTypeDecl (..), CConsDecl (..), CFieldDecl (..)+ , CConstraint, CContext (..), CTypeExpr (..), CQualTypeExpr (..)+ , COpDecl (..), CFixity (..), Arity, CFuncDecl (..), CRhs (..), CRule (..)+ , CLocalDecl (..), CVarIName, CExpr (..), CCaseType (..), CStatement (..)+ , CPattern (..), CLiteral (..), CField, version+ ) where++-- ---------------------------------------------------------------------------+-- Abstract syntax+-- ---------------------------------------------------------------------------++-- |Current version of AbstractCurry+version :: String+version = "AbstractCurry 3.0"++-- |A module name.+type MName = String++-- |A qualified name.+-- In AbstractCurry all names are qualified to avoid name clashes.+-- The first component is the module name and the second component the+-- unqualified name as it occurs in the source program.+type QName = (MName, String)++-- |Data type to specify the visibility of various entities.+data CVisibility+ = Public -- ^ exported entity+ | Private -- ^ private entity+ deriving (Eq, Read, Show)++-- |A Curry module in the intermediate form. A value of this type has the form+-- @+-- CurryProg modname imports dfltdecl clsdecls instdecls typedecls funcdecls opdecls+-- @+-- where+-- [@modname@] Name of this module+-- [@imports@] List of modules names that are imported+-- [@dfltdecl@] Optional default declaration+-- [@clsdecls@] Class declarations+-- [@instdecls@] Instance declarations+-- [@typedecls@] Type declarations+-- [@funcdecls@] Function declarations+-- [@opdecls@] Operator precedence declarations+data CurryProg = CurryProg MName [MName] (Maybe CDefaultDecl) [CClassDecl]+ [CInstanceDecl] [CTypeDecl] [CFuncDecl] [COpDecl]+ deriving (Eq, Read, Show)++-- |Default declaration.+data CDefaultDecl = CDefaultDecl [CTypeExpr]+ deriving (Eq, Read, Show)++-- |Definitions of type classes.+-- A type class definition of the form+-- @+-- class cx => c a where { ...;f :: t;... }+-- @+-- is represented by the Curry term+-- @+-- (CClass c v cx tv [...(CFunc f ar v t [...,CRule r,...])...])+-- @+-- where @tv@ is the index of the type variable @a@ and @v@ is the+-- visibility of the type class resp. method.+-- /Note:/ The type variable indices are unique inside each class+-- declaration and are usually numbered from 0.+-- The methods' types share the type class' type variable index+-- as the class variable has to occur in a method's type signature.+-- The list of rules for a method's declaration may be empty if+-- no default implementation is provided. The arity @ar@ is+-- determined by a given default implementation or 0.+-- Regardless of whether typed or untyped abstract curry is generated,+-- the methods' declarations are always typed.+data CClassDecl = CClass QName CVisibility CContext CTVarIName [CFuncDecl]+ deriving (Eq, Read, Show)++-- |Definitions of instances.+-- An instance definition of the form+-- @+-- instance cx => c ty where { ...;fundecl;... }+-- @+-- is represented by the Curry term+-- @+-- (CInstance c cx ty [...fundecl...])+-- @+-- /Note:/ The type variable indices are unique inside each instance+-- declaration and are usually numbered from 0.+-- The methods' types use the instance's type variable indices+-- (if typed abstract curry is generated).+data CInstanceDecl = CInstance QName CContext CTypeExpr [CFuncDecl]+ deriving (Eq, Read, Show)++-- |Definitions of algebraic data types and type synonyms.+-- A data type definition of the form+-- @+-- data t x1...xn = ...| forall y1...ym . cx => c t1....tkc |...+-- deriving (d1,...,dp)+-- @+-- is represented by the Curry term+-- @+-- (CType t v [i1,...,in] [...(CCons [l1,...,lm] cx c kc v [t1,...,tkc])...]+-- [d1,...,dp])+-- @+-- where each @ij@ is the index of the type variable @xj@, each @lj@ is the+-- index of the existentially quantified type variable @yj@ and @v@ is the+-- visibility of the type resp. constructor.+-- /Note:/ The type variable indices are unique inside each type declaration+-- and are usually numbered from 0.+-- Thus, a data type declaration consists of the name of the data type,+-- a list of type parameters and a list of constructor declarations.+data CTypeDecl+ -- |algebraic data type+ = CType QName CVisibility [CTVarIName] [CConsDecl] [QName]+ -- |type synonym+ | CTypeSyn QName CVisibility [CTVarIName] CTypeExpr+ -- |renaming type, may have only exactly one type expression+ -- in the constructor declaration and no existentially type variables and+ -- no context+ | CNewType QName CVisibility [CTVarIName] CConsDecl [QName]+ deriving (Eq, Read, Show)++-- |The type for representing type variables.+-- They are represented by @(i,n)@ where @i@ is a type variable index+-- which is unique inside a function and @n@ is a name (if possible,+-- the name written in the source program).+type CTVarIName = (Int, String)++-- |A constructor declaration consists of the name of the constructor+-- and a list of the argument types of the constructor.+-- The arity equals the number of types.+data CConsDecl+ = CCons QName CVisibility [CTypeExpr]+ | CRecord QName CVisibility [CFieldDecl]+ deriving (Eq, Read, Show)++-- |A record field declaration consists of the name of the+-- the label, the visibility and its corresponding type.+data CFieldDecl = CField QName CVisibility CTypeExpr+ deriving (Eq, Read, Show)++-- |The type for representing a class constraint.+type CConstraint = (QName, CTypeExpr)++-- |The type for representing a context.+data CContext = CContext [CConstraint]+ deriving (Eq, Read, Show)++-- |Type expression.+-- A type expression is either a type variable, a function type,+-- a type constructor or a type application.+data CTypeExpr+ -- |Type variable+ = CTVar CTVarIName+ -- |Function type @t1 -> t2@+ | CFuncType CTypeExpr CTypeExpr+ -- |Type constructor+ | CTCons QName+ -- |Type application+ | CTApply CTypeExpr CTypeExpr+ deriving (Eq, Read, Show)++-- |Qualified type expression.+data CQualTypeExpr = CQualType CContext CTypeExpr+ deriving (Eq, Read, Show)++-- |Labeled record fields+type CField a = (QName, a)++-- |Operator precedence declaration.+-- An operator precedence declaration @fix p n@ in Curry corresponds to the+-- AbstractCurry term @(COp n fix p)@.+data COpDecl = COp QName CFixity Int+ deriving (Eq, Read, Show)++-- |Fixity declarations of infix operators+data CFixity+ = CInfixOp -- ^ non-associative infix operator+ | CInfixlOp -- ^ left-associative infix operator+ | CInfixrOp -- ^ right-associative infix operator+ deriving (Eq, Read, Show)++-- |Function arity+type Arity = Int++-- |Data type for representing function declarations.+-- A function declaration in FlatCurry is a term of the form+-- @+-- (CFunc name arity visibility type (CRules eval [CRule rule1,...,rulek]))+-- @+-- and represents the function @name@ with definition+-- @+-- name :: type+-- rule1+-- ...+-- rulek+-- @+-- /Note:/ The variable indices are unique inside each rule.+-- External functions are represented as+-- @+-- (CFunc name arity type (CExternal s))+-- @+-- where s is the external name associated to this function.+-- Thus, a function declaration consists of the name, arity, type, and+-- a list of rules.+-- If the list of rules is empty, the function is considered+-- to be externally defined.+data CFuncDecl = CFunc QName Arity CVisibility CQualTypeExpr [CRule]+ deriving (Eq, Read, Show)++-- |The general form of a function rule. It consists of a list of patterns+-- (left-hand side), a list of guards (@success@ if not present in the+-- source text) with their corresponding right-hand sides, and+-- a list of local declarations.+data CRule = CRule [CPattern] CRhs+ deriving (Eq, Read, Show)++-- |Right-hand-side of a 'CRule' or an @case@ expression+data CRhs+ = CSimpleRhs CExpr [CLocalDecl] -- @expr where decls@+ | CGuardedRhs [(CExpr, CExpr)] [CLocalDecl] -- @| cond = expr where decls@+ deriving (Eq, Read, Show)++-- | Local (let/where) declarations+data CLocalDecl+ = CLocalFunc CFuncDecl -- ^ local function declaration+ | CLocalPat CPattern CRhs -- ^ local pattern declaration+ | CLocalVars [CVarIName] -- ^ local free variable declarations+ deriving (Eq, Read, Show)++-- |Variable names.+-- Object variables occurring in expressions are represented by @(Var i)@+-- where @i@ is a variable index.+type CVarIName = (Int, String)++-- |Pattern expressions.+data CPattern+ -- |pattern variable (unique index / name)+ = CPVar CVarIName+ -- |literal (Integer/Float/Char constant)+ | CPLit CLiteral+ -- |application @(m.c e1 ... en)@ of n-ary constructor @m.c@+ -- (@CPComb (m,c) [e1,...,en]@)+ | CPComb QName [CPattern]+ -- |as-pattern (extended Curry)+ | CPAs CVarIName CPattern+ -- |functional pattern (extended Curry)+ | CPFuncComb QName [CPattern]+ -- |lazy pattern (extended Curry)+ | CPLazy CPattern+ -- |record pattern (extended curry)+ | CPRecord QName [CField CPattern]+ deriving (Eq, Read, Show)++-- | Curry expressions.+data CExpr+ -- |variable (unique index / name)+ = CVar CVarIName+ -- |literal (Integer/Float/Char/String constant)+ | CLit CLiteral+ -- |a defined symbol with module and name, i.e., a function or a constructor+ | CSymbol QName+ -- |application (e1 e2)+ | CApply CExpr CExpr+ -- |lambda abstraction+ | CLambda [CPattern] CExpr+ -- |local let declarations+ | CLetDecl [CLocalDecl] CExpr+ -- |do block+ | CDoExpr [CStatement]+ -- |list comprehension+ | CListComp CExpr [CStatement]+ -- |case expression+ | CCase CCaseType CExpr [(CPattern, CRhs)]+ -- |typed expression+ | CTyped CExpr CQualTypeExpr+ -- |record construction (extended Curry)+ | CRecConstr QName [CField CExpr]+ -- |record update (extended Curry)+ | CRecUpdate CExpr [CField CExpr]+ deriving (Eq, Read, Show)++-- |Literals occurring in an expression or a pattern,+-- either an integer, a float, a character, or a string constant.+-- /Note:/ The constructor definition of 'CIntc' differs from the original+-- PAKCS definition. It uses Haskell type 'Integer' instead of 'Int'+-- to provide an unlimited range of integer numbers. Furthermore,+-- float values are represented with Haskell type 'Double' instead of+-- 'Float' to gain double precision.+data CLiteral+ = CIntc Integer -- ^ Int literal+ | CFloatc Double -- ^ Float literal+ | CCharc Char -- ^ Char literal+ | CStringc String -- ^ String literal+ deriving (Eq, Read, Show)++-- |Statements in do expressions and list comprehensions.+data CStatement+ = CSExpr CExpr -- ^ an expression (I/O action or boolean)+ | CSPat CPattern CExpr -- ^ a pattern definition+ | CSLet [CLocalDecl] -- ^ a local let declaration+ deriving (Eq, Read, Show)++-- |Type of case expressions+data CCaseType+ = CRigid -- ^ rigid case expression+ | CFlex -- ^ flexible case expression+ deriving (Eq, Read, Show)
+ src/Curry/Base/Ident.hs view
@@ -0,0 +1,1036 @@+{- |+ Module : $Header$+ Description : Identifiers+ Copyright : (c) 1999 - 2004, Wolfgang Lux+ 2011 - 2013, Björn Peemöller+ 2016 , Finn Teegen+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This module provides the implementation of identifiers and some+ utility functions for identifiers.++ Identifiers comprise the name of the denoted entity and an /id/,+ which can be used for renaming identifiers, e.g., in order to resolve+ name conflicts between identifiers from different scopes. An+ identifier with an /id/ @0@ is considered as not being renamed+ and, hence, its /id/ will not be shown.++ Qualified identifiers may optionally be prefixed by a module name.+-}+{-# LANGUAGE CPP #-}+module Curry.Base.Ident+ ( -- * Module identifiers+ ModuleIdent (..), mkMIdent, moduleName, escModuleName+ , fromModuleName, isValidModuleName, addPositionModuleIdent, mIdentLength++ -- * Local identifiers+ , Ident (..), mkIdent, showIdent, escName, identSupply+ , globalScope, hasGlobalScope, isRenamed, renameIdent, unRenameIdent+ , updIdentName, addPositionIdent, isInfixOp, identLength++ -- * Qualified identifiers+ , QualIdent (..), qualName, escQualName, isQInfixOp, qualify+ , qualifyWith, qualQualify, qualifyLike, isQualified, unqualify, qualUnqualify+ , localIdent, isLocalIdent, updQualIdent, qIdentLength++ -- * Predefined simple identifiers+ -- ** Identifiers for modules+ , emptyMIdent, mainMIdent, preludeMIdent+ -- ** Identifiers for types+ , arrowId, unitId, boolId, charId, intId, floatId, listId, ioId, successId+ -- ** Identifiers for type classes+ , eqId, ordId, enumId, boundedId, readId, showId+ , numId, fractionalId+ , monadId, monadFailId+ , dataId+ -- ** Identifiers for constructors+ , trueId, falseId, nilId, consId, tupleId, isTupleId, tupleArity+ -- ** Identifiers for values+ , mainId, minusId, fminusId, applyId, errorId, failedId, idId+ , succId, predId, toEnumId, fromEnumId, enumFromId, enumFromThenId+ , enumFromToId, enumFromThenToId+ , maxBoundId, minBoundId+ , lexId, readsPrecId, readParenId+ , showsPrecId, showParenId, showStringId+ , andOpId, eqOpId, leqOpId, ltOpId, orOpId, appendOpId, dotOpId+ , aValueId, dataEqId+ , anonId, isAnonId++ -- * Predefined qualified identifiers+ -- ** Identifiers for types+ , qArrowId, qUnitId, qBoolId, qCharId, qIntId, qFloatId, qListId, qIOId+ , qSuccessId, isPrimTypeId+ -- ** Identifiers for type classes+ , qEqId, qOrdId, qEnumId, qBoundedId, qReadId, qShowId+ , qNumId, qFractionalId+ , qMonadId, qMonadFailId+ , qDataId+ -- ** Identifiers for constructors+ , qTrueId, qFalseId, qNilId, qConsId, qTupleId, isQTupleId, qTupleArity+ -- ** Identifiers for values+ , qApplyId, qErrorId, qFailedId, qIdId+ , qFromEnumId, qEnumFromId, qEnumFromThenId, qEnumFromToId, qEnumFromThenToId+ , qMaxBoundId, qMinBoundId+ , qLexId, qReadsPrecId, qReadParenId+ , qShowsPrecId, qShowParenId, qShowStringId+ , qAndOpId, qEqOpId, qLeqOpId, qLtOpId, qOrOpId, qAppendOpId, qDotOpId+ , qAValueId, qDataEqId++ -- * Extended functionality+ -- ** Functional patterns+ , fpSelectorId, isFpSelectorId, isQualFpSelectorId+ -- ** Records+ , recSelectorId, qualRecSelectorId, recUpdateId, qualRecUpdateId+ , recordExt, recordExtId, isRecordExtId, fromRecordExtId+ , labelExt, labelExtId, isLabelExtId, fromLabelExtId+ , renameLabel, mkLabelIdent+ ) where++import Prelude hiding ((<>))+import Data.Char (isAlpha, isAlphaNum)+import Data.Function (on)+import Data.List (intercalate, isInfixOf, isPrefixOf)+import Data.Maybe (isJust, fromMaybe)+import Data.Binary+import Control.Monad++import Curry.Base.Position+import Curry.Base.Span hiding (file)+import Curry.Base.SpanInfo+import Curry.Base.Pretty++-- ---------------------------------------------------------------------------+-- Module identifier+-- ---------------------------------------------------------------------------++-- | Module identifier+data ModuleIdent = ModuleIdent+ { midSpanInfo :: SpanInfo -- ^ source code 'SpanInfo'+ , midQualifiers :: [String] -- ^ hierarchical idenfiers+ } deriving (Read, Show)++instance Eq ModuleIdent where+ (==) = (==) `on` midQualifiers++instance Ord ModuleIdent where+ compare = compare `on` midQualifiers++instance HasSpanInfo ModuleIdent where+ getSpanInfo = midSpanInfo+ setSpanInfo spi a = a { midSpanInfo = spi }+ updateEndPos i =+ setEndPosition (incr (getPosition i) (mIdentLength i - 1)) i++instance HasPosition ModuleIdent where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance Pretty ModuleIdent where+ pPrint = hcat . punctuate dot . map text . midQualifiers++instance Binary ModuleIdent where+ put (ModuleIdent sp qs) = put sp >> put qs+ get = liftM2 ModuleIdent get get++mIdentLength :: ModuleIdent -> Int+mIdentLength a = length (concat (midQualifiers a))+ + length (midQualifiers a)++-- |Construct a 'ModuleIdent' from a list of 'String's forming the+-- the hierarchical module name.+mkMIdent :: [String] -> ModuleIdent+mkMIdent = ModuleIdent NoSpanInfo++-- |Retrieve the hierarchical name of a module+moduleName :: ModuleIdent -> String+moduleName = intercalate "." . midQualifiers++-- |Show the name of an 'ModuleIdent' escaped by ticks+escModuleName :: ModuleIdent -> String+escModuleName m = '`' : moduleName m ++ "'"++-- |Add a source code 'Position' to a 'ModuleIdent'+addPositionModuleIdent :: Position -> ModuleIdent -> ModuleIdent+addPositionModuleIdent = setPosition++-- |Check whether a 'String' is a valid module name.+--+-- Valid module names must satisfy the following conditions:+--+-- * The name must not be empty+-- * The name must consist of one or more single identifiers,+-- seperated by dots+-- * Each single identifier must be non-empty, start with a letter and+-- consist of letter, digits, single quotes or underscores only+isValidModuleName :: String -> Bool+isValidModuleName [] = False -- Module names may not be empty+isValidModuleName qs = all isModuleIdentifier $ splitIdentifiers qs+ where+ -- components of a module identifier may not be null+ isModuleIdentifier [] = False+ -- components of a module identifier must start with a letter and consist+ -- of letter, digits, underscores or single quotes+ isModuleIdentifier (c:cs) = isAlpha c && all isIdent cs+ isIdent c = isAlphaNum c || c `elem` "'_"++-- |Resemble the hierarchical module name from a 'String' by splitting+-- the 'String' at inner dots.+--+-- /Note:/ This function does not check the 'String' to be a valid module+-- identifier, use isValidModuleName for this purpose.+fromModuleName :: String -> ModuleIdent+fromModuleName = mkMIdent . splitIdentifiers++-- Auxiliary function to split a hierarchical module identifier at the dots+splitIdentifiers :: String -> [String]+splitIdentifiers s = let (pref, rest) = break (== '.') s in+ pref : case rest of+ [] -> []+ (_:s') -> splitIdentifiers s'++-- ---------------------------------------------------------------------------+-- Simple identifier+-- ---------------------------------------------------------------------------++-- |Simple identifier+data Ident = Ident+ { idSpanInfo :: SpanInfo -- ^ Source code 'SpanInfo'+ , idName :: String -- ^ Name of the identifier+ , idUnique :: Integer -- ^ Unique number of the identifier+ } deriving (Read, Show)++instance Eq Ident where+ Ident _ m i == Ident _ n j = (m, i) == (n, j)++instance Ord Ident where+ Ident _ m i `compare` Ident _ n j = (m, i) `compare` (n, j)++instance HasSpanInfo Ident where+ getSpanInfo = idSpanInfo+ setSpanInfo spi a = a { idSpanInfo = spi }+ updateEndPos i@(Ident (SpanInfo _ [_,ss]) _ _) =+ setEndPosition (end ss) i+ updateEndPos i =+ setEndPosition (incr (getPosition i) (identLength i - 1)) i++instance HasPosition Ident where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance Pretty Ident where+ pPrint (Ident _ x n) | n == globalScope = text x+ | otherwise = text x <> dot <> integer n++instance Binary Ident where+ put (Ident sp qs i) = put sp >> put qs >> put i+ get = liftM3 Ident get get get++identLength :: Ident -> Int+identLength a = length (idName a)++-- |Global scope for renaming+globalScope :: Integer+globalScope = 0++-- |Construct an 'Ident' from a 'String'+mkIdent :: String -> Ident+mkIdent x = Ident NoSpanInfo x globalScope++-- |Infinite list of different 'Ident's+identSupply :: [Ident]+identSupply = [ mkNewIdent c i | i <- [0 ..] :: [Integer], c <- ['a'..'z'] ]+ where mkNewIdent c 0 = mkIdent [c]+ mkNewIdent c n = mkIdent $ c : show n++-- |Show function for an 'Ident'+showIdent :: Ident -> String+showIdent (Ident _ x n) | n == globalScope = x+ | otherwise = x ++ '.' : show n++-- |Show the name of an 'Ident' escaped by ticks+escName :: Ident -> String+escName i = '`' : idName i ++ "'"++-- |Has the identifier global scope?+hasGlobalScope :: Ident -> Bool+hasGlobalScope = (== globalScope) . idUnique++-- |Is the 'Ident' renamed?+isRenamed :: Ident -> Bool+isRenamed = (/= globalScope) . idUnique++-- |Rename an 'Ident' by changing its unique number+renameIdent :: Ident -> Integer -> Ident+renameIdent ident n = ident { idUnique = n }++-- |Revert the renaming of an 'Ident' by resetting its unique number+unRenameIdent :: Ident -> Ident+unRenameIdent ident = renameIdent ident globalScope++-- |Change the name of an 'Ident' using a renaming function+updIdentName :: (String -> String) -> Ident -> Ident+updIdentName f (Ident p n i) = Ident p (f n) i++-- |Add a 'Position' to an 'Ident'+addPositionIdent :: Position -> Ident -> Ident+addPositionIdent = setPosition++-- |Check whether an 'Ident' identifies an infix operation+isInfixOp :: Ident -> Bool+isInfixOp (Ident _ ('<' : c : cs) _) =+ last (c : cs) /= '>' || not (isAlphaNum c) && c `notElem` "_(["+isInfixOp (Ident _ (c : _) _) = not (isAlphaNum c) && c `notElem` "_(["+isInfixOp Ident{} = False -- error "Zero-length identifier"++-- ---------------------------------------------------------------------------+-- Qualified identifier+-- ---------------------------------------------------------------------------++-- |Qualified identifier+data QualIdent = QualIdent+ { qidSpanInfo :: SpanInfo -- ^ Source code 'SpanInfo'+ , qidModule :: Maybe ModuleIdent -- ^ optional module identifier+ , qidIdent :: Ident -- ^ identifier itself+ } deriving (Read, Show)++instance Eq QualIdent where+ QualIdent _ m i == QualIdent _ n j = (m, i) == (n, j)++instance Ord QualIdent where+ QualIdent _ m i `compare` QualIdent _ n j = (m, i) `compare` (n, j)++instance HasSpanInfo QualIdent where+ getSpanInfo = qidSpanInfo+ setSpanInfo spi a = a { qidSpanInfo = spi }+ updateEndPos i@(QualIdent (SpanInfo _ [_,ss]) _ _) =+ setEndPosition (end ss) i+ updateEndPos i =+ setEndPosition (incr (getPosition i) (qIdentLength i - 1)) i++instance HasPosition QualIdent where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance Pretty QualIdent where+ pPrint = text . qualName++instance Binary QualIdent where+ put (QualIdent sp mid idt) = put sp >> put mid >> put idt+ get = liftM3 QualIdent get get get++qIdentLength :: QualIdent -> Int+qIdentLength (QualIdent _ (Just m) i) = identLength i + mIdentLength m+qIdentLength (QualIdent _ Nothing i) = identLength i++-- |show function for qualified identifiers)=+qualName :: QualIdent -> String+qualName (QualIdent _ Nothing x) = idName x+qualName (QualIdent _ (Just m) x) = moduleName m ++ "." ++ idName x++-- |Show the name of an 'QualIdent' escaped by ticks+escQualName :: QualIdent -> String+escQualName qn = '`' : qualName qn ++ "'"++-- |Check whether an 'QualIdent' identifies an infix operation+isQInfixOp :: QualIdent -> Bool+isQInfixOp = isInfixOp . qidIdent++-- ---------------------------------------------------------------------------+-- The functions \texttt{qualify} and \texttt{qualifyWith} convert an+-- unqualified identifier into a qualified identifier (without and with a+-- given module prefix, respectively).+-- ---------------------------------------------------------------------------++-- | Convert an 'Ident' to a 'QualIdent'+qualify :: Ident -> QualIdent+qualify i = QualIdent (fromSrcSpan (getSrcSpan i)) Nothing i++-- | Convert an 'Ident' to a 'QualIdent' with a given 'ModuleIdent'+qualifyWith :: ModuleIdent -> Ident -> QualIdent+qualifyWith mid i = updateEndPos $+ QualIdent (fromSrcSpan (getSrcSpan mid)) (Just mid) i++-- | Convert an 'QualIdent' to a new 'QualIdent' with a given 'ModuleIdent'.+-- If the original 'QualIdent' already contains an 'ModuleIdent' it+-- remains unchanged.+qualQualify :: ModuleIdent -> QualIdent -> QualIdent+qualQualify m (QualIdent _ Nothing x) = qualifyWith m x+qualQualify _ x = x++-- |Qualify an 'Ident' with the 'ModuleIdent' of the given 'QualIdent',+-- if present.+qualifyLike :: QualIdent -> Ident -> QualIdent+qualifyLike (QualIdent _ Nothing _) x = qualify x+qualifyLike (QualIdent _ (Just m) _) x = qualifyWith m x++-- | Check whether a 'QualIdent' contains a 'ModuleIdent'+isQualified :: QualIdent -> Bool+isQualified = isJust . qidModule++-- | Remove the qualification of an 'QualIdent'+unqualify :: QualIdent -> Ident+unqualify = qidIdent++-- | Remove the qualification with a specific 'ModuleIdent'. If the+-- original 'QualIdent' has no 'ModuleIdent' or a different one, it+-- remains unchanged.+qualUnqualify :: ModuleIdent -> QualIdent -> QualIdent+qualUnqualify _ qid@(QualIdent _ Nothing _) = qid+qualUnqualify m (QualIdent spi (Just m') x) = QualIdent spi m'' x+ where m'' | m == m' = Nothing+ | otherwise = Just m'++-- | Extract the 'Ident' of an 'QualIdent' if it is local to the+-- 'ModuleIdent', i.e. if the 'Ident' is either unqualified or qualified+-- with the given 'ModuleIdent'.+localIdent :: ModuleIdent -> QualIdent -> Maybe Ident+localIdent _ (QualIdent _ Nothing x) = Just x+localIdent m (QualIdent _ (Just m') x)+ | m == m' = Just x+ | otherwise = Nothing++-- |Check whether the given 'QualIdent' is local to the given 'ModuleIdent'.+isLocalIdent :: ModuleIdent -> QualIdent -> Bool+isLocalIdent mid qid = isJust (localIdent mid qid)++-- | Update a 'QualIdent' by applying functions to its components+updQualIdent :: (ModuleIdent -> ModuleIdent) -> (Ident -> Ident)+ -> QualIdent -> QualIdent+updQualIdent f g (QualIdent spi m x) = QualIdent spi (fmap f m) (g x)++-- ---------------------------------------------------------------------------+-- A few identifiers are predefined here.+-- ---------------------------------------------------------------------------+-- | 'ModuleIdent' for the empty module+emptyMIdent :: ModuleIdent+emptyMIdent = ModuleIdent NoSpanInfo []++-- | 'ModuleIdent' for the main module+mainMIdent :: ModuleIdent+mainMIdent = ModuleIdent NoSpanInfo ["main"]++-- | 'ModuleIdent' for the Prelude+preludeMIdent :: ModuleIdent+preludeMIdent = ModuleIdent NoSpanInfo ["Prelude"]++-- ---------------------------------------------------------------------------+-- Identifiers for types+-- ---------------------------------------------------------------------------++-- | 'Ident' for the type '(->)'+arrowId :: Ident+arrowId = mkIdent "(->)"++-- | 'Ident' for the type/value unit ('()')+unitId :: Ident+unitId = mkIdent "()"++-- | 'Ident' for the type 'Bool'+boolId :: Ident+boolId = mkIdent "Bool"++-- | 'Ident' for the type 'Char'+charId :: Ident+charId = mkIdent "Char"++-- | 'Ident' for the type 'Int'+intId :: Ident+intId = mkIdent "Int"++-- | 'Ident' for the type 'Float'+floatId :: Ident+floatId = mkIdent "Float"++-- | 'Ident' for the type '[]'+listId :: Ident+listId = mkIdent "[]"++-- | 'Ident' for the type 'IO'+ioId :: Ident+ioId = mkIdent "IO"++-- | 'Ident' for the type 'Success'+successId :: Ident+successId = mkIdent "Success"++-- | Construct an 'Ident' for an n-ary tuple where n > 1+tupleId :: Int -> Ident+tupleId n+ | n > 1 = mkIdent $ '(' : replicate (n - 1) ',' ++ ")"+ | otherwise = error $ "Curry.Base.Ident.tupleId: wrong arity " ++ show n++-- | Check whether an 'Ident' is an identifier for an tuple type+isTupleId :: Ident -> Bool+isTupleId (Ident _ x _) = n > 1 && x == idName (tupleId n)+ where n = length x - 1++-- | Compute the arity of a tuple identifier+tupleArity :: Ident -> Int+tupleArity i@(Ident _ x _)+ | n > 1 && x == idName (tupleId n) = n+ | otherwise = error $+ "Curry.Base.Ident.tupleArity: no tuple identifier: " ++ showIdent i+ where n = length x - 1++-- ---------------------------------------------------------------------------+-- Identifiers for type classes+-- ---------------------------------------------------------------------------++-- | 'Ident' for the 'Eq' class+eqId :: Ident+eqId = mkIdent "Eq"++-- | 'Ident' for the 'Ord' class+ordId :: Ident+ordId = mkIdent "Ord"++-- | 'Ident' for the 'Enum' class+enumId :: Ident+enumId = mkIdent "Enum"++-- | 'Ident' for the 'Bounded' class+boundedId :: Ident+boundedId = mkIdent "Bounded"++-- | 'Ident' for the 'Read' class+readId :: Ident+readId = mkIdent "Read"++-- | 'Ident' for the 'Show' class+showId :: Ident+showId = mkIdent "Show"++-- | 'Ident' for the 'Num' class+numId :: Ident+numId = mkIdent "Num"++-- | 'Ident' for the 'Fractional' class+fractionalId :: Ident+fractionalId = mkIdent "Fractional"++-- | 'Ident' for the 'Monad' class+monadId :: Ident+monadId = mkIdent "Monad"++-- | 'Ident' for the 'MonadFail' class+monadFailId :: Ident+monadFailId = mkIdent "MonadFail"++-- | 'Ident' for the 'Data' class+dataId :: Ident+dataId = mkIdent "Data"++-- ---------------------------------------------------------------------------+-- Identifiers for constructors+-- ---------------------------------------------------------------------------++-- | 'Ident' for the value 'True'+trueId :: Ident+trueId = mkIdent "True"++-- | 'Ident' for the value 'False'+falseId :: Ident+falseId = mkIdent "False"++-- | 'Ident' for the value '[]'+nilId :: Ident+nilId = mkIdent "[]"++-- | 'Ident' for the function ':'+consId :: Ident+consId = mkIdent ":"++-- ---------------------------------------------------------------------------+-- Identifiers for values+-- ---------------------------------------------------------------------------++-- | 'Ident' for the main function+mainId :: Ident+mainId = mkIdent "main"++-- | 'Ident' for the minus function+minusId :: Ident+minusId = mkIdent "-"++-- | 'Ident' for the minus function for Floats+fminusId :: Ident+fminusId = mkIdent "-."++-- | 'Ident' for the apply function+applyId :: Ident+applyId = mkIdent "apply"++-- | 'Ident' for the error function+errorId :: Ident+errorId = mkIdent "error"++-- | 'Ident' for the failed function+failedId :: Ident+failedId = mkIdent "failed"++-- | 'Ident' for the id function+idId :: Ident+idId = mkIdent "id"++-- | 'Ident' for the maxBound function+maxBoundId :: Ident+maxBoundId = mkIdent "maxBound"++-- | 'Ident' for the minBound function+minBoundId :: Ident+minBoundId = mkIdent "minBound"++-- | 'Ident' for the pred function+predId :: Ident+predId = mkIdent "pred"++-- | 'Ident' for the succ function+succId :: Ident+succId = mkIdent "succ"++-- | 'Ident' for the toEnum function+toEnumId :: Ident+toEnumId = mkIdent "toEnum"++-- | 'Ident' for the fromEnum function+fromEnumId :: Ident+fromEnumId = mkIdent "fromEnum"++-- | 'Ident' for the enumFrom function+enumFromId :: Ident+enumFromId = mkIdent "enumFrom"++-- | 'Ident' for the enumFromThen function+enumFromThenId :: Ident+enumFromThenId = mkIdent "enumFromThen"++-- | 'Ident' for the enumFromTo function+enumFromToId :: Ident+enumFromToId = mkIdent "enumFromTo"++-- | 'Ident' for the enumFromThenTo function+enumFromThenToId :: Ident+enumFromThenToId = mkIdent "enumFromThenTo"++-- | 'Ident' for the lex function+lexId :: Ident+lexId = mkIdent "lex"++-- | 'Ident' for the readsPrec function+readsPrecId :: Ident+readsPrecId = mkIdent "readsPrec"++-- | 'Ident' for the readParen function+readParenId :: Ident+readParenId = mkIdent "readParen"++-- | 'Ident' for the showsPrec function+showsPrecId :: Ident+showsPrecId = mkIdent "showsPrec"++-- | 'Ident' for the showParen function+showParenId :: Ident+showParenId = mkIdent "showParen"++-- | 'Ident' for the showString function+showStringId :: Ident+showStringId = mkIdent "showString"++-- | 'Ident' for the '&&' operator+andOpId :: Ident+andOpId = mkIdent "&&"++-- | 'Ident' for the '==' operator+eqOpId :: Ident+eqOpId = mkIdent "=="++-- | 'Ident' for the '<=' operator+leqOpId :: Ident+leqOpId = mkIdent "<="++-- | 'Ident' for the '<' operator+ltOpId :: Ident+ltOpId = mkIdent "<"++-- | 'Ident' for the '||' operator+orOpId :: Ident+orOpId = mkIdent "||"++-- | 'Ident' for the '++' operator+appendOpId :: Ident+appendOpId = mkIdent "++"++-- | 'Ident' for the '.' operator+dotOpId :: Ident+dotOpId = mkIdent "."++aValueId :: Ident+aValueId = mkIdent "aValue"++dataEqId :: Ident+dataEqId = mkIdent "==="++-- | 'Ident' for anonymous variable+anonId :: Ident+anonId = mkIdent "_"++-- |Check whether an 'Ident' represents an anonymous identifier ('anonId')+isAnonId :: Ident -> Bool+isAnonId = (== anonId) . unRenameIdent++-- ---------------------------------------------------------------------------+-- Qualified Identifiers for types+-- ---------------------------------------------------------------------------++-- | Construct a 'QualIdent' for an 'Ident' using the module prelude+qPreludeIdent :: Ident -> QualIdent+qPreludeIdent = qualifyWith preludeMIdent++-- | 'QualIdent' for the type '(->)'+qArrowId :: QualIdent+qArrowId = qualify arrowId++-- | 'QualIdent' for the type/value unit ('()')+qUnitId :: QualIdent+qUnitId = qualify unitId++-- | 'QualIdent' for the type '[]'+qListId :: QualIdent+qListId = qualify listId++-- | 'QualIdent' for the type 'Bool'+qBoolId :: QualIdent+qBoolId = qPreludeIdent boolId++-- | 'QualIdent' for the type 'Char'+qCharId :: QualIdent+qCharId = qPreludeIdent charId++-- | 'QualIdent' for the type 'Int'+qIntId :: QualIdent+qIntId = qPreludeIdent intId++-- | 'QualIdent' for the type 'Float'+qFloatId :: QualIdent+qFloatId = qPreludeIdent floatId++-- | 'QualIdent' for the type 'IO'+qIOId :: QualIdent+qIOId = qPreludeIdent ioId++-- | 'QualIdent' for the type 'Success'+qSuccessId :: QualIdent+qSuccessId = qPreludeIdent successId++-- | Check whether an 'QualIdent' is an primary type constructor+isPrimTypeId :: QualIdent -> Bool+isPrimTypeId tc = tc `elem` [qArrowId, qUnitId, qListId] || isQTupleId tc++-- ---------------------------------------------------------------------------+-- Qualified Identifiers for type classes+-- ---------------------------------------------------------------------------++-- | 'QualIdent' for the 'Eq' class+qEqId :: QualIdent+qEqId = qPreludeIdent eqId++-- | 'QualIdent' for the 'Ord' class+qOrdId :: QualIdent+qOrdId = qPreludeIdent ordId++-- | 'QualIdent' for the 'Enum' class+qEnumId :: QualIdent+qEnumId = qPreludeIdent enumId++-- | 'QualIdent' for the 'Bounded' class+qBoundedId :: QualIdent+qBoundedId = qPreludeIdent boundedId++-- | 'QualIdent' for the 'Read' class+qReadId :: QualIdent+qReadId = qPreludeIdent readId++-- | 'QualIdent' for the 'Show' class+qShowId :: QualIdent+qShowId = qPreludeIdent showId++-- | 'QualIdent' for the 'Num' class+qNumId :: QualIdent+qNumId = qPreludeIdent numId++-- | 'QualIdent' for the 'Fractional' class+qFractionalId :: QualIdent+qFractionalId = qPreludeIdent fractionalId++-- | 'QualIdent' for the 'Monad' class+qMonadId :: QualIdent+qMonadId = qPreludeIdent monadId++-- | 'QualIdent' for the 'MonadFail' class+qMonadFailId :: QualIdent+qMonadFailId = qPreludeIdent monadFailId++-- | 'QualIdent' for the 'Data' class+qDataId :: QualIdent+qDataId = qPreludeIdent dataId++-- ---------------------------------------------------------------------------+-- Qualified Identifiers for constructors+-- ---------------------------------------------------------------------------++-- | 'QualIdent' for the constructor 'True'+qTrueId :: QualIdent+qTrueId = qPreludeIdent trueId++-- | 'QualIdent' for the constructor 'False'+qFalseId :: QualIdent+qFalseId = qPreludeIdent falseId++-- | 'QualIdent' for the constructor '[]'+qNilId :: QualIdent+qNilId = qualify nilId++-- | 'QualIdent' for the constructor ':'+qConsId :: QualIdent+qConsId = qualify consId++-- | 'QualIdent' for the type of n-ary tuples+qTupleId :: Int -> QualIdent+qTupleId = qualify . tupleId++-- | Check whether an 'QualIdent' is an identifier for an tuple type+isQTupleId :: QualIdent -> Bool+isQTupleId = isTupleId . unqualify++-- | Compute the arity of an qualified tuple identifier+qTupleArity :: QualIdent -> Int+qTupleArity = tupleArity . unqualify++-- ---------------------------------------------------------------------------+-- Qualified Identifiers for values+-- ---------------------------------------------------------------------------++-- | 'QualIdent' for the apply function+qApplyId :: QualIdent+qApplyId = qPreludeIdent applyId++-- | 'QualIdent' for the error function+qErrorId :: QualIdent+qErrorId = qPreludeIdent errorId++-- | 'QualIdent' for the failed function+qFailedId :: QualIdent+qFailedId = qPreludeIdent failedId++-- | 'QualIdent' for the id function+qIdId :: QualIdent+qIdId = qPreludeIdent idId++-- | 'QualIdent' for the maxBound function+qMaxBoundId :: QualIdent+qMaxBoundId = qPreludeIdent maxBoundId++-- | 'QualIdent' for the minBound function+qMinBoundId :: QualIdent+qMinBoundId = qPreludeIdent minBoundId++-- | 'QualIdent' for the fromEnum function+qFromEnumId :: QualIdent+qFromEnumId = qPreludeIdent fromEnumId++-- | 'QualIdent' for the enumFrom function+qEnumFromId :: QualIdent+qEnumFromId = qPreludeIdent enumFromId++-- | 'QualIdent' for the enumFromThen function+qEnumFromThenId :: QualIdent+qEnumFromThenId = qPreludeIdent enumFromThenId++-- | 'QualIdent' for the enumFromTo function+qEnumFromToId :: QualIdent+qEnumFromToId = qPreludeIdent enumFromToId++-- | 'QualIdent' for the enumFromThenTo function+qEnumFromThenToId :: QualIdent+qEnumFromThenToId = qPreludeIdent enumFromThenToId++-- | 'QualIdent' for the lex function+qLexId :: QualIdent+qLexId = qPreludeIdent lexId++-- | 'QualIdent' for the readsPrec function+qReadsPrecId :: QualIdent+qReadsPrecId = qPreludeIdent readsPrecId++-- | 'QualIdent' for the readParen function+qReadParenId :: QualIdent+qReadParenId = qPreludeIdent readParenId++-- | 'QualIdent' for the showsPrec function+qShowsPrecId :: QualIdent+qShowsPrecId = qPreludeIdent showsPrecId++-- | 'QualIdent' for the showParen function+qShowParenId :: QualIdent+qShowParenId = qPreludeIdent showParenId++-- | 'QualIdent' for the showString function+qShowStringId :: QualIdent+qShowStringId = qPreludeIdent showStringId++-- | 'QualIdent' for the '&&' operator+qAndOpId :: QualIdent+qAndOpId = qPreludeIdent andOpId++-- | 'QualIdent' for the '==' operator+qEqOpId :: QualIdent+qEqOpId = qPreludeIdent eqOpId++-- | 'QualIdent' for the '<=' operator+qLeqOpId :: QualIdent+qLeqOpId = qPreludeIdent leqOpId++-- | 'QualIdent' for the '<' operator+qLtOpId :: QualIdent+qLtOpId = qPreludeIdent ltOpId++-- | 'QualIdent' for the '||' operator+qOrOpId :: QualIdent+qOrOpId = qPreludeIdent orOpId++-- | 'QualIdent' for the '.' operator+qDotOpId :: QualIdent+qDotOpId = qPreludeIdent dotOpId++qAValueId :: QualIdent+qAValueId = qPreludeIdent aValueId++qDataEqId :: QualIdent+qDataEqId = qPreludeIdent dataEqId++-- | 'QualIdent' for the '++' operator+qAppendOpId :: QualIdent+qAppendOpId = qPreludeIdent appendOpId++-- ---------------------------------------------------------------------------+-- Micellaneous functions for generating and testing extended identifiers+-- ---------------------------------------------------------------------------++-- Functional patterns++-- | Annotation for function pattern identifiers+fpSelExt :: String+fpSelExt = "_#selFP"++-- | Construct an 'Ident' for a functional pattern+fpSelectorId :: Int -> Ident+fpSelectorId n = mkIdent $ fpSelExt ++ show n++-- | Check whether an 'Ident' is an identifier for a functional pattern+isFpSelectorId :: Ident -> Bool+isFpSelectorId = (fpSelExt `isInfixOf`) . idName++-- | Check whether an 'QualIdent' is an identifier for a function pattern+isQualFpSelectorId :: QualIdent -> Bool+isQualFpSelectorId = isFpSelectorId . unqualify++-- Record selection++-- | Annotation for record selection identifiers+recSelExt :: String+recSelExt = "_#selR@"++-- | Construct an 'Ident' for a record selection pattern+recSelectorId :: QualIdent -- ^ identifier of the record+ -> Ident -- ^ identifier of the label+ -> Ident+recSelectorId = mkRecordId recSelExt++-- | Construct a 'QualIdent' for a record selection pattern+qualRecSelectorId :: ModuleIdent -- ^ default module+ -> QualIdent -- ^ record identifier+ -> Ident -- ^ label identifier+ -> QualIdent+qualRecSelectorId m r l = qualRecordId m r $ recSelectorId r l++-- Record update++-- | Annotation for record update identifiers+recUpdExt :: String+recUpdExt = "_#updR@"++-- | Construct an 'Ident' for a record update pattern+recUpdateId :: QualIdent -- ^ record identifier+ -> Ident -- ^ label identifier+ -> Ident+recUpdateId = mkRecordId recUpdExt++-- | Construct a 'QualIdent' for a record update pattern+qualRecUpdateId :: ModuleIdent -- ^ default module+ -> QualIdent -- ^ record identifier+ -> Ident -- ^ label identifier+ -> QualIdent+qualRecUpdateId m r l = qualRecordId m r $ recUpdateId r l++-- Auxiliary function to construct a selector/update identifier+mkRecordId :: String -> QualIdent -> Ident -> Ident+mkRecordId ann r l = mkIdent $ concat+ [ann, idName (unqualify r), ".", idName l]++-- Auxiliary function to qualify a selector/update identifier+qualRecordId :: ModuleIdent -> QualIdent -> Ident -> QualIdent+qualRecordId m r = qualifyWith (fromMaybe m $ qidModule r)++-- Record tyes++-- | Annotation for record identifiers+recordExt :: String+recordExt = "_#Rec:"++-- | Construct an 'Ident' for a record+recordExtId :: Ident -> Ident+recordExtId r = mkIdent $ recordExt ++ idName r++-- | Check whether an 'Ident' is an identifier for a record+isRecordExtId :: Ident -> Bool+isRecordExtId = (recordExt `isPrefixOf`) . idName++-- | Retrieve the 'Ident' from a record identifier+fromRecordExtId :: Ident -> Ident+fromRecordExtId r+ | p == recordExt = mkIdent r'+ | otherwise = r+ where (p, r') = splitAt (length recordExt) (idName r)++-- Record labels++-- | Annotation for record label identifiers+labelExt :: String+labelExt = "_#Lab:"++-- | Construct an 'Ident' for a record label+labelExtId :: Ident -> Ident+labelExtId l = mkIdent $ labelExt ++ idName l++-- | Check whether an 'Ident' is an identifier for a record label+isLabelExtId :: Ident -> Bool+isLabelExtId = (labelExt `isPrefixOf`) . idName++-- | Retrieve the 'Ident' from a record label identifier+fromLabelExtId :: Ident -> Ident+fromLabelExtId l+ | p == labelExt = mkIdent l'+ | otherwise = l+ where (p, l') = splitAt (length labelExt) (idName l)++-- | Construct an 'Ident' for a record label+mkLabelIdent :: String -> Ident+mkLabelIdent c = renameIdent (mkIdent c) (-1)++-- | Rename an 'Ident' for a record label+renameLabel :: Ident -> Ident+renameLabel l = renameIdent l (-1)
+ src/Curry/Base/LLParseComb.hs view
@@ -0,0 +1,380 @@+{- |+ Module : $Header$+ Description : Parser combinators+ Copyright : (c) 1999-2004, Wolfgang Lux+ 2016 , Jan Tikovsky+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ The parsing combinators implemented in this module are based on the+ LL(1) parsing combinators developed by Swierstra and Duponcheel.+ They have been adapted to using continuation passing style in order to+ work with the lexing combinators described in the previous section.+ In addition, the facilities for error correction are omitted+ in this implementation.++ The two functions 'applyParser' and 'prefixParser' use the specified+ parser for parsing a string. When 'applyParser' is used, an error is+ reported if the parser does not consume the whole string,+ whereas 'prefixParser' discards the rest of the input string in this case.+-}+{-# LANGUAGE CPP #-}++module Curry.Base.LLParseComb+ ( -- * Data types+ Parser++ -- * Parser application+ , fullParser, prefixParser++ -- * Basic parsers+ , position, spanPosition, succeed, failure, symbol++ -- * parser combinators+ , (<?>), (<|>), (<|?>), (<*>), (<\>), (<\\>)+ , (<$>), (<$->), (<*->), (<-*>), (<**>), (<??>), (<.>)+ , opt, choice, flag, optional, option, many, many1, sepBy, sepBy1+ , sepBySp, sepBy1Sp+ , chainr, chainr1, chainl, chainl1, between, ops++ -- * Layout combinators+ , layoutOn, layoutOff, layoutEnd+ ) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative (Applicative, (<*>), (<$>), pure)+#endif+import Control.Monad+import qualified Data.Map as Map+import Data.Maybe+import qualified Data.Set as Set++import Curry.Base.LexComb+import Curry.Base.Position+import Curry.Base.Span (span2Pos, Span, startCol, setDistance)++infixl 5 <\>, <\\>+infixl 4 <$->, <*->, <-*>, <**>, <??>, <.>+infixl 3 <|>, <|?>+infixl 2 <?>, `opt`++-- ---------------------------------------------------------------------------+-- Parser types+-- ---------------------------------------------------------------------------++-- |Parsing function+type ParseFun a s b = (b -> SuccessP s a) -> FailP a -> SuccessP s a++-- |CPS-Parser type+data Parser a s b = Parser+ -- Parsing function for empty word+ (Maybe (ParseFun a s b))+ -- Lookup table (continuations for 'Symbol's recognized by the parser)+ (Map.Map s (Lexer s a -> ParseFun a s b))++instance Symbol s => Functor (Parser a s) where+ fmap f p = succeed f <*> p++instance Symbol s => Applicative (Parser a s) where+ pure = succeed++ -- |Apply the result function of the first parser to the result of the+ -- second parser.+ Parser Nothing ps1 <*> p2 = Parser Nothing+ (fmap (`seqPP` p2) ps1)+ Parser (Just p1) ps1 <*> ~p2@(Parser e2 ps2) = Parser (fmap (seqEE p1) e2)+ (Map.union (fmap (`seqPP` p2) ps1) (fmap (seqEP p1) ps2))++instance Show s => Show (Parser a s b) where+ showsPrec p (Parser e ps) = showParen (p >= 10) $+ showString "Parser " . shows (isJust e) .+ showChar ' ' . shows (Map.keysSet ps)++-- ---------------------------------------------------------------------------+-- Parser application+-- ---------------------------------------------------------------------------++-- |Apply a parser and lexer to a 'String', whereas the 'FilePath' is used+-- to identify the origin of the 'String' in case of parsing errors.+fullParser :: Symbol s => Parser a s a -> Lexer s a -> FilePath -> String+ -> CYM a+fullParser p lexer = parse (lexer (choose p lexer successP failP) failP)+ where successP x pos s+ | isEOF s = returnP x+ | otherwise = failP pos (unexpected s)++-- |Apply a parser and lexer to parse the beginning of a 'String'.+-- The 'FilePath' is used to identify the origin of the 'String' in case of+-- parsing errors.+prefixParser :: Symbol s => Parser a s a -> Lexer s a -> FilePath -> String+ -> CYM a+prefixParser p lexer = parse (lexer (choose p lexer discardP failP) failP)+ where discardP x _ _ = returnP x++-- |Choose the appropriate parsing function w.r.t. to the next 'Symbol'.+choose :: Symbol s => Parser a s b -> Lexer s a -> ParseFun a s b+choose (Parser e ps) lexer success failp pos s = case Map.lookup s ps of+ Just p -> p lexer success failp pos s+ Nothing -> case e of+ Just p -> p success failp pos s+ Nothing -> failp pos (unexpected s)++-- |Fail on an unexpected 'Symbol'+unexpected :: Symbol s => s -> String+unexpected s+ | isEOF s = "Unexpected end-of-file"+ | otherwise = "Unexpected token " ++ show s++-- ---------------------------------------------------------------------------+-- Basic parsers+-- ---------------------------------------------------------------------------++-- |Return the current position without consuming the input+position :: Parser a s Position+position = Parser (Just p) Map.empty+ where p success _ sp = success (span2Pos sp) sp++spanPosition :: Symbol s => Parser a s Span+spanPosition = Parser (Just p) Map.empty+ where p success _ sp s = success (setDistance sp (dist (startCol sp) s)) sp s++-- |Always succeeding parser+succeed :: b -> Parser a s b+succeed x = Parser (Just p) Map.empty+ where p success _ = success x++-- |Always failing parser with a given message+failure :: String -> Parser a s b+failure msg = Parser (Just p) Map.empty+ where p _ failp pos _ = failp pos msg++-- |Create a parser accepting the given 'Symbol'+symbol :: s -> Parser a s s+symbol s = Parser Nothing (Map.singleton s p)+ where p lexer success failp _ s' = lexer (success s') failp++-- ---------------------------------------------------------------------------+-- Parser combinators+-- ---------------------------------------------------------------------------++-- |Behave like the given parser, but use the given 'String' as the error+-- message if the parser fails+(<?>) :: Symbol s => Parser a s b -> String -> Parser a s b+p <?> msg = p <|> failure msg++-- |Deterministic choice between two parsers.+-- The appropriate parser is chosen based on the next 'Symbol'+(<|>) :: Symbol s => Parser a s b -> Parser a s b -> Parser a s b+Parser e1 ps1 <|> Parser e2 ps2+ | isJust e1 && isJust e2 = failure "Ambiguous parser for empty word"+ | not (Set.null common) = failure $ "Ambiguous parser for " ++ show common+ | otherwise = Parser (e1 `mplus` e2) (Map.union ps1 ps2)+ where common = Map.keysSet ps1 `Set.intersection` Map.keysSet ps2++-- |Non-deterministic choice between two parsers.+--+-- The other parsing combinators require that the grammar being parsed+-- is LL(1). In some cases it may be difficult or even+-- impossible to transform a grammar into LL(1) form. As a remedy, we+-- include a non-deterministic version of the choice combinator in+-- addition to the deterministic combinator adapted from the paper. For+-- every symbol from the intersection of the parser's first sets, the+-- combinator '(<|?>)' applies both parsing functions to the input+-- stream and uses that one which processes the longer prefix of the+-- input stream irrespective of whether it succeeds or fails. If both+-- functions recognize the same prefix, we choose the one that succeeds+-- and report an ambiguous parse error if both succeed.+(<|?>) :: Symbol s => Parser a s b -> Parser a s b -> Parser a s b+Parser e1 ps1 <|?> Parser e2 ps2+ | isJust e1 && isJust e2 = failure "Ambiguous parser for empty word"+ | otherwise = Parser (e1 `mplus` e2) (Map.union ps1' ps2)+ where+ ps1' = Map.fromList [ (s, maybe p (try p) (Map.lookup s ps2))+ | (s, p) <- Map.toList ps1+ ]+ try p1 p2 lexer success failp pos s =+ closeP1 p2s `thenP` \p2s' ->+ closeP1 p2f `thenP` \p2f' ->+ parse' p1 (retry p2s') (retry p2f')+ where p2s r1 = parse' p2 (select True r1) (select False r1)+ p2f r1 = parse' p2 (flip (select False) r1) (select False r1)+ parse' p psucc pfail =+ p lexer (successK psucc) (failK pfail) pos s+ successK k x pos' s' = k (pos', success x pos' s')+ failK k pos' msg = k (pos', failp pos' msg)+ retry k (pos',p) = closeP0 p `thenP` curry k pos'+ select suc (pos1, p1) (pos2, p2) = case pos1 `compare` pos2 of+ GT -> p1+ EQ | suc -> failP pos1 $ "Ambiguous parse before " ++ showPosition (span2Pos pos1)+ | otherwise -> p1+ LT -> p2++seqEE :: ParseFun a s (b -> c) -> ParseFun a s b -> ParseFun a s c+seqEE p1 p2 success failp = p1 (\f -> p2 (success . f) failp) failp++seqEP :: ParseFun a s (b -> c) -> (Lexer s a -> ParseFun a s b)+ -> Lexer s a -> ParseFun a s c+seqEP p1 p2 lexer success failp = p1 (\f -> p2 lexer (success . f) failp) failp++seqPP :: Symbol s => (Lexer s a -> ParseFun a s (b -> c)) -> Parser a s b+ -> Lexer s a -> ParseFun a s c+seqPP p1 p2 lexer success failp =+ p1 lexer (\f -> choose p2 lexer (success . f) failp) failp++-- ---------------------------------------------------------------------------+-- The combinators \verb|<\\>| and \verb|<\>| can be used to restrict+-- the first set of a parser. This is useful for combining two parsers+-- with an overlapping first set with the deterministic combinator <|>.+-- ---------------------------------------------------------------------------++-- |Restrict the first parser by the first 'Symbol's of the second+(<\>) :: Symbol s => Parser a s b -> Parser a s c -> Parser a s b+p <\> Parser _ ps = p <\\> Map.keys ps++-- |Restrict a parser by a list of first 'Symbol's+(<\\>) :: Symbol s => Parser a s b -> [s] -> Parser a s b+Parser e ps <\\> xs = Parser e (foldr Map.delete ps xs)++-- ---------------------------------------------------------------------------+-- Other combinators+-- Note that some of these combinators have not been published in the+-- paper, but were taken from the implementation found on the web.+-- ---------------------------------------------------------------------------++-- |Replace the result of the parser with the first argument+(<$->) :: Symbol s => a -> Parser b s c -> Parser b s a+f <$-> p = f <$ p++-- |Apply two parsers in sequence, but return only the result of the first+-- parser+(<*->) :: Symbol s => Parser a s b -> Parser a s c -> Parser a s b+p <*-> q = const <$> p <*> q++-- |Apply two parsers in sequence, but return only the result of the second+-- parser+(<-*>) :: Symbol s => Parser a s b -> Parser a s c -> Parser a s c+p <-*> q = id <$ p <*> q++-- |Apply the parsers in sequence and apply the result function of the second+-- parse to the result of the first+(<**>) :: Symbol s => Parser a s b -> Parser a s (b -> c) -> Parser a s c+p <**> q = flip ($) <$> p <*> q++-- |Same as (<**>), but only applies the function if the second parser+-- succeeded.+(<??>) :: Symbol s => Parser a s b -> Parser a s (b -> b) -> Parser a s b+p <??> q = p <**> (q `opt` id)++-- |Flipped function composition on parsers+(<.>) :: Symbol s => Parser a s (b -> c) -> Parser a s (c -> d)+ -> Parser a s (b -> d)+p1 <.> p2 = p1 <**> ((.) <$> p2)++-- |Try the first parser, but return the second argument if it didn't succeed+opt :: Symbol s => Parser a s b -> b -> Parser a s b+p `opt` x = p <|> succeed x++-- |Choose the first succeeding parser from a non-empty list of parsers+choice :: Symbol s => [Parser a s b] -> Parser a s b+choice = foldr1 (<|>)++-- |Try to apply a given parser and return a boolean value if the parser+-- succeeded.+flag :: Symbol s => Parser a s b -> Parser a s Bool+flag p = True <$-> p `opt` False++-- |Try to apply a parser but forget if it succeeded+optional :: Symbol s => Parser a s b -> Parser a s ()+optional p = void p `opt` ()++-- |Try to apply a parser and return its result in a 'Maybe' type+option :: Symbol s => Parser a s b -> Parser a s (Maybe b)+option p = Just <$> p `opt` Nothing++-- |Repeatedly apply a parser for 0 or more occurences+many :: Symbol s => Parser a s b -> Parser a s [b]+many p = many1 p `opt` []++-- |Repeatedly apply a parser for 1 or more occurences+many1 :: Symbol s => Parser a s b -> Parser a s [b]+many1 p = (:) <$> p <*> many p++-- |Parse a list with is separated by a seperator+sepBy :: Symbol s => Parser a s b -> Parser a s c -> Parser a s [b]+p `sepBy` q = p `sepBy1` q `opt` []++-- |Parse a non-empty list with is separated by a seperator+sepBy1 :: Symbol s => Parser a s b -> Parser a s c -> Parser a s [b]+p `sepBy1` q = (:) <$> p <*> many (q <-*> p)++-- |Parse a list with is separated by a seperator+sepBySp :: Symbol s => Parser a s b -> Parser a s c -> Parser a s ([b], [Span])+p `sepBySp` q = p `sepBy1Sp` q `opt` ([], [])++sepBy1Sp :: Symbol s => Parser a s b -> Parser a s c -> Parser a s ([b], [Span])+p `sepBy1Sp` q = comb <$> p <*> many ((,) <$> spanPosition <*-> q <*> p)+ where comb x xs = let (ss, ys) = unzip xs+ in (x:ys,ss)++-- |@chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.+-- Returns a value produced by a *right* associative application of all+-- functions returned by op. If there are no occurrences of @p@, @x@ is+-- returned.+chainr :: Symbol s+ => Parser a s b -> Parser a s (b -> b -> b) -> b -> Parser a s b+chainr p op x = chainr1 p op `opt` x++-- |Like 'chainr', but parses one or more occurrences of p.+chainr1 :: Symbol s => Parser a s b -> Parser a s (b -> b -> b) -> Parser a s b+chainr1 p op = r where r = p <**> (flip <$> op <*> r `opt` id)++-- |@chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.+-- Returns a value produced by a *left* associative application of all+-- functions returned by op. If there are no occurrences of @p@, @x@ is+-- returned.+chainl :: Symbol s+ => Parser a s b -> Parser a s (b -> b -> b) -> b -> Parser a s b+chainl p op x = chainl1 p op `opt` x++-- |Like 'chainl', but parses one or more occurrences of p.+chainl1 :: Symbol s => Parser a s b -> Parser a s (b -> b -> b) -> Parser a s b+chainl1 p op = foldF <$> p <*> many (flip <$> op <*> p)+ where foldF x [] = x+ foldF x (f:fs) = foldF (f x) fs++-- |Parse an expression between an opening and a closing part.+between :: Symbol s => Parser a s b -> Parser a s c -> Parser a s b+ -> Parser a s c+between open p close = open <-*> p <*-> close++-- |Parse one of the given operators+ops :: Symbol s => [(s, b)] -> Parser a s b+ops [] = failure "Curry.Base.LLParseComb.ops: empty list"+ops [(s, x)] = x <$-> symbol s+ops ((s, x) : rest) = x <$-> symbol s <|> ops rest++-- ---------------------------------------------------------------------------+-- Layout combinators+-- Note that the layout functions grab the next token (and its position).+-- After modifying the layout context, the continuation is called with+-- the same token and an undefined result.+-- ---------------------------------------------------------------------------++-- |Disable layout-awareness for the following+layoutOff :: Symbol s => Parser a s b+layoutOff = Parser (Just off) Map.empty+ where off success _ pos = pushContext (-1) . success undefined pos++-- |Add a new scope for layout+layoutOn :: Symbol s => Parser a s b+layoutOn = Parser (Just on) Map.empty+ where on success _ pos = pushContext (column (span2Pos pos)) . success undefined pos++-- |End the current layout scope (or re-enable layout-awareness if it is+-- currently disabled+layoutEnd :: Symbol s => Parser a s b+layoutEnd = Parser (Just end) Map.empty+ where end success _ pos = popContext . success undefined pos
+ src/Curry/Base/LexComb.hs view
@@ -0,0 +1,179 @@+{- |+ Module : $Header$+ Description : Lexer combinators+ Copyright : (c) 1999 - 2004, Wolfgang Lux+ 2012 - 2013, Björn Peemöller+ 2016 , Jan Tikovsky+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This module provides the basic types and combinators to implement the+ lexers. The combinators use continuation passing code in a monadic style.++ The first argument of the continuation function is the current span,+ and the second is the string to be parsed. The third argument is a flag+ which signals the lexer that it is lexing the beginning of a line and+ therefore has to check for layout tokens. The fourth argument is a stack+ of indentations that is used to handle nested layout groups.+-}+module Curry.Base.LexComb+ ( -- * Types+ Symbol (..), Indent, Context, P, CYM, SuccessP, FailP, Lexer++ -- * Monadic functions+ , parse, applyLexer, returnP, thenP, thenP_, failP, warnP+ , liftP, closeP0, closeP1++ -- * Combinators for layout handling+ , pushContext, popContext++ -- * Conversion of numbers+ , convertSignedIntegral, convertSignedFloating+ , convertIntegral, convertFloating+ ) where++import Data.Char (digitToInt)++import Curry.Base.Monad (CYM, failMessageAt, warnMessageAt)+import Curry.Base.Span ( Distance, Span (..), startCol, fstSpan+ , setDistance)+++infixl 1 `thenP`, `thenP_`++-- |Type class for symbols+class (Ord s, Show s) => Symbol s where+ -- |Does the 'Symbol' represent the end of the input?+ isEOF :: s -> Bool+ -- |Compute the distance of a 'Symbol'+ dist :: Int -> s -> Distance++-- |Type for indentations, necessary for the layout rule+type Indent = Int++-- |Type of context for representing layout grouping+type Context = [Indent]++-- |Basic lexer function+type P a = Span -- ^ Current source code span+ -> String -- ^ 'String' to be parsed+ -> Bool -- ^ Flag whether the beginning of a line should be+ -- parsed, which requires layout checking+ -> Context -- ^ context as a stack of 'Indent's+ -> CYM a++-- |Apply a lexer on a 'String' to lex the content. The second parameter+-- requires a 'FilePath' to use in the 'Span'+parse :: P a -> FilePath -> String -> CYM a+parse p fn s = p (fstSpan fn) s True []++-- ---------------------------------------------------------------------------+-- CPS lexer+-- ---------------------------------------------------------------------------++-- |success continuation+type SuccessP s a = Span -> s -> P a++-- |failure continuation+type FailP a = Span -> String -> P a++-- |A CPS lexer+type Lexer s a = SuccessP s a -> FailP a -> P a++-- |Apply a lexer+applyLexer :: Symbol s => Lexer s [(Span, s)] -> P [(Span, s)]+applyLexer lexer = lexer successP failP+ where successP sp t | isEOF t = returnP [(sp', t)]+ | otherwise = ((sp', t) :) `liftP` lexer successP failP+ where sp' = setDistance sp (dist (startCol sp) t)++-- ---------------------------------------------------------------------------+-- Monadic functions for the lexer.+-- ---------------------------------------------------------------------------++-- |Lift a value into the lexer type+returnP :: a -> P a+returnP x _ _ _ _ = return x++-- |Apply the first lexer and then apply the second one, based on the result+-- of the first lexer.+thenP :: P a -> (a -> P b) -> P b+thenP lexer k sp s bol ctxt+ = lexer sp s bol ctxt >>= \x -> k x sp s bol ctxt++-- |Apply the first lexer and then apply the second one, ignoring the first+-- result.+thenP_ :: P a -> P b -> P b+p1 `thenP_` p2 = p1 `thenP` const p2++-- |Fail to lex on a 'Span', given an error message+failP :: Span -> String -> P a+failP sp msg _ _ _ _ = failMessageAt sp msg++-- |Warn on a 'Span', given a warning message+warnP :: Span -> String -> P a -> P a+warnP warnSpan msg lexer sp s bol ctxt+ = warnMessageAt warnSpan msg >> lexer sp s bol ctxt++-- |Apply a pure function to the lexers result+liftP :: (a -> b) -> P a -> P b+liftP f p = p `thenP` returnP . f++-- |Lift a lexer into the 'P' monad, returning the lexer when evaluated.+closeP0 :: P a -> P (P a)+closeP0 lexer sp s bol ctxt = return (\_ _ _ _ -> lexer sp s bol ctxt)++-- |Lift a lexer-generating function into the 'P' monad, returning the+-- function when evaluated.+closeP1 :: (a -> P b) -> P (a -> P b)+closeP1 f sp s bol ctxt = return (\x _ _ _ _ -> f x sp s bol ctxt)++-- ---------------------------------------------------------------------------+-- Combinators for handling layout.+-- ---------------------------------------------------------------------------++-- |Push an 'Indent' to the context, increasing the levels of indentation+pushContext :: Indent -> P a -> P a+pushContext col cont sp s bol ctxt = cont sp s bol (col : ctxt)++-- |Pop an 'Indent' from the context, decreasing the levels of indentation+popContext :: P a -> P a+popContext cont sp s bol (_ : ctxt) = cont sp s bol ctxt+popContext _ sp _ _ [] = failMessageAt sp $+ "Parse error: popping layout from empty context stack. " +++ "Perhaps you have inserted too many '}'?"++-- ---------------------------------------------------------------------------+-- Conversions from 'String's into numbers.+-- ---------------------------------------------------------------------------++-- |Convert a String into a signed intergral using a given base+convertSignedIntegral :: Num a => a -> String -> a+convertSignedIntegral b ('+':s) = convertIntegral b s+convertSignedIntegral b ('-':s) = - convertIntegral b s+convertSignedIntegral b s = convertIntegral b s++-- |Convert a String into an unsigned intergral using a given base+convertIntegral :: Num a => a -> String -> a+convertIntegral b = foldl op 0+ where m `op` n = b * m + fromIntegral (digitToInt n)++-- |Convert a mantissa, a fraction part and an exponent into a signed+-- floating value+convertSignedFloating :: Fractional a => String -> String -> Int -> a+convertSignedFloating ('+':m) f e = convertFloating m f e+convertSignedFloating ('-':m) f e = - convertFloating m f e+convertSignedFloating m f e = convertFloating m f e++-- |Convert a mantissa, a fraction part and an exponent into an unsigned+-- floating value+convertFloating :: Fractional a => String -> String -> Int -> a+convertFloating m f e+ | e' == 0 = m'+ | e' > 0 = m' * 10 ^ e'+ | otherwise = m' / 10 ^ (- e')+ where m' = convertIntegral 10 (m ++ f)+ e' = e - length f
+ src/Curry/Base/Message.hs view
@@ -0,0 +1,114 @@+{- |+ Module : $Header$+ Description : Monads for message handling+ Copyright : 2009 Holger Siegel+ 2012 - 2015 Björn Peemöller+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ The type message represents a compiler message with an optional source+ code position.+-}+{-# LANGUAGE CPP #-}+module Curry.Base.Message+ ( Message (..), message, posMessage, spanMessage, spanInfoMessage+ , showWarning, showError+ , ppMessage, ppWarning, ppError, ppMessages, ppMessagesWithPreviews+ ) where++#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif++import Curry.Base.Position+import Curry.Base.Pretty+import Curry.Base.Span+import Curry.Base.SpanInfo++-- ---------------------------------------------------------------------------+-- Message+-- ---------------------------------------------------------------------------++-- |Compiler message+data Message = Message+ { msgSpanInfo :: SpanInfo -- ^ span in the source code+ , msgTxt :: Doc -- ^ the message itself+ }++instance Eq Message where+ Message s1 t1 == Message s2 t2 = (s1, show t1) == (s2, show t2)++instance Ord Message where+ Message s1 t1 `compare` Message s2 t2 = compare (s1, show t1) (s2, show t2)++instance Show Message where+ showsPrec _ = shows . ppMessage++instance HasPosition Message where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasSpanInfo Message where+ getSpanInfo = msgSpanInfo+ setSpanInfo spi m = m { msgSpanInfo = spi }++instance Pretty Message where+ pPrint = ppMessage++-- |Construct a 'Message' without a 'SpanInfo'+message :: Doc -> Message+message = Message NoSpanInfo++-- |Construct a message from a position.+posMessage :: HasPosition p => p -> Doc -> Message+posMessage p = spanMessage $ pos2Span $ getPosition p++-- |Construct a message from a span and a text+spanMessage :: Span -> Doc -> Message+spanMessage s = spanInfoMessage $ fromSrcSpan s++-- |Construct a message from an entity with a 'SpanInfo' and a text+spanInfoMessage :: HasSpanInfo s => s -> Doc -> Message+spanInfoMessage s msg = Message (getSpanInfo s) msg++-- |Show a 'Message' as a warning+showWarning :: Message -> String+showWarning = show . ppWarning++-- |Show a 'Message' as an error+showError :: Message -> String+showError = show . ppError++-- |Pretty print a 'Message'+ppMessage :: Message -> Doc+ppMessage = ppAs ""++-- |Pretty print a 'Message' as a warning+ppWarning :: Message -> Doc+ppWarning = ppAs "Warning"++-- |Pretty print a 'Message' as an error+ppError :: Message -> Doc+ppError = ppAs "Error"++-- |Pretty print a 'Message' with a given key+ppAs :: String -> Message -> Doc+ppAs key (Message mbSpanInfo txt) = (hsep $ filter (not . isEmpty) [spanPP, keyPP]) $$ nest 4 txt+ where+ spanPP = ppCompactSpan $ getSrcSpan $ mbSpanInfo+ keyPP = if null key then empty else text key <> colon++-- |Pretty print a list of 'Message's by vertical concatenation+ppMessages :: (Message -> Doc) -> [Message] -> Doc+ppMessages ppFun = foldr (\m ms -> text "" $+$ m $+$ ms) empty . map ppFun++-- |Pretty print a list of 'Message's with previews by vertical concatenation+ppMessagesWithPreviews :: (Message -> Doc) -> [Message] -> IO Doc+ppMessagesWithPreviews ppFun = (fmap $ foldr (\m ms -> text "" $+$ m $+$ ms) empty) . mapM ppFunWithPreview+ where ppFunWithPreview m = do preview <- case m of+ Message (SpanInfo sp _) _ -> ppSpanPreview sp+ _ -> return empty+ return $ ppFun m $+$ preview
+ src/Curry/Base/Monad.hs view
@@ -0,0 +1,95 @@+{- |+ Module : $Header$+ Description : Monads for message handling+ Copyright : 2014 - 2016 Björn Peemöller+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental++ The monads defined in this module provide a common way to stop execution+ when some errors occur. They are used to integrate different compiler passes+ smoothly.+-}++module Curry.Base.Monad+ ( CYIO, CYM, CYT, failMessages, failMessageAt, warnMessages, warnMessageAt+ , ok, runCYIO, runCYM, runCYIOIgnWarn, runCYMIgnWarn, liftCYM, silent+ ) where++import Control.Monad.Identity+import Control.Monad.Trans.Except (ExceptT, mapExceptT, runExceptT, throwE)+import Control.Monad.Writer++import Curry.Base.Message (Message, spanMessage)+import Curry.Base.Span (Span)+import Curry.Base.Pretty (text)++-- |Curry compiler monad transformer+type CYT m a = WriterT [Message] (ExceptT [Message] m) a++-- |Curry compiler monad based on the `IO` monad+type CYIO a = CYT IO a++-- |Pure Curry compiler monad+type CYM a = CYT Identity a++-- |Run an `IO`-based Curry compiler action in the `IO` monad,+-- yielding either a list of errors or a result in case of success+-- consisting of the actual result and a (possibly empty) list of warnings+runCYIO :: CYIO a -> IO (Either [Message] (a, [Message]))+runCYIO = runExceptT . runWriterT++-- |Run an pure Curry compiler action,+-- yielding either a list of errors or a result in case of success+-- consisting of the actual result and a (possibly empty) list of warnings+runCYM :: CYM a -> Either [Message] (a, [Message])+runCYM = runIdentity . runExceptT . runWriterT++-- |Run an `IO`-based Curry compiler action in the `IO` monad,+-- yielding either a list of errors or a result in case of success.+runCYIOIgnWarn :: CYIO a -> IO (Either [Message] a)+runCYIOIgnWarn = runExceptT . (liftM fst) . runWriterT++-- |Run an pure Curry compiler action,+-- yielding either a list of errors or a result in case of success.+runCYMIgnWarn :: CYM a -> Either [Message] a+runCYMIgnWarn = runIdentity . runExceptT . (liftM fst) . runWriterT++-- |Failing action with a message describing the cause of failure.+failMessage :: Monad m => Message -> CYT m a+failMessage msg = failMessages [msg]++-- |Failing action with a list of messages describing the cause(s) of failure.+failMessages :: Monad m => [Message] -> CYT m a+failMessages = lift . throwE++-- |Failing action with a source code span and a `String` indicating+-- the cause of failure.+failMessageAt :: Monad m => Span -> String -> CYT m a+failMessageAt sp s = failMessage $ spanMessage sp $ text s++-- |Warning with a message describing the cause of the warning.+warnMessage :: Monad m => Message -> CYT m ()+warnMessage msg = warnMessages [msg]++-- |Warning with a list of messages describing the cause(s) of the warnings.+warnMessages :: Monad m => [Message] -> CYT m ()+warnMessages msgs = tell msgs++-- |Execute a monadic action, but ignore any warnings it issues+silent :: Monad m => CYT m a -> CYT m a+silent act = censor (const []) act++-- |Warning with a source code position and a `String` indicating+-- the cause of the warning.+warnMessageAt :: Monad m => Span -> String -> CYT m ()+warnMessageAt sp s = warnMessage $ spanMessage sp $ text s++-- |Lift a value into the `CYT m` monad, same as `return`.+ok :: Monad m => a -> CYT m a+ok = return++-- |Lift a pure action into an action based on another monad.+liftCYM :: Monad m => CYM a -> CYT m a+liftCYM = mapWriterT (mapExceptT (return . runIdentity))
+ src/Curry/Base/Position.hs view
@@ -0,0 +1,128 @@+{- |+ Module : $Header$+ Description : Positions in a source file+ Copyright : (c) Wolfgang Lux+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This module implements a data type for positions in a source file and+ respective functions to operate on them. A source file position consists+ of a filename, a line number, and a column number. A tab stop is assumed+ at every eighth column.+-}+module Curry.Base.Position+ ( -- * Source code position+ HasPosition (..), Position (..), (@>)+ , showPosition, ppPosition, ppCompactLine, ppLine, showLine+ , first, next, incr, tab, tabWidth, nl+ ) where++import Prelude hiding ((<>))+import Data.Binary+import Control.Monad+import System.FilePath++import Curry.Base.Pretty++-- |Type class for entities which have a source code 'Position'+class HasPosition a where+ -- |Get the 'Position'+ getPosition :: a -> Position+ getPosition _ = NoPos++ -- |Set the 'Position'+ setPosition :: Position -> a -> a+ setPosition _ = id++-- | @x \@> y@ returns @x@ with the position obtained from @y@+(@>) :: (HasPosition a, HasPosition b) => a -> b -> a+x @> y = setPosition (getPosition y) x++-- |Source code positions+data Position+ -- |Normal source code position+ = Position+ { file :: FilePath -- ^ 'FilePath' of the source file+ , line :: Int -- ^ line number, beginning at 1+ , column :: Int -- ^ column number, beginning at 1+ }+ -- |no position+ | NoPos+ deriving (Eq, Ord, Read, Show)++instance HasPosition Position where+ getPosition = id+ setPosition = const++instance Pretty Position where+ pPrint = ppPosition++instance Binary Position where+ put (Position _ l c) = putWord8 0 >> put l >> put c+ put NoPos = putWord8 1++ get = do+ x <- getWord8+ case x of+ 0 -> liftM2 (Position "") get get+ 1 -> return NoPos+ _ -> fail "Not a valid encoding for a Position"++-- |Show a 'Position' as a 'String'+showPosition :: Position -> String+showPosition = show . ppPosition++-- |Pretty print a 'Position'+ppPosition :: Position -> Doc+ppPosition p@(Position f _ _)+ | null f = lineCol+ | otherwise = text (normalise f) <> comma <+> lineCol+ where lineCol = ppLine p+ppPosition _ = empty++-- |Pretty print a compact representation of a 'Position''s line/column+ppCompactLine :: Position -> Doc+ppCompactLine (Position _ l c) = text (show l)+ <> if c == 0 then empty else (colon <> text (show c))+ppCompactLine _ = empty++-- |Pretty print the line and column of a 'Position'+ppLine :: Position -> Doc+ppLine (Position _ l c) = text "line" <+> text (show l)+ <> if c == 0 then empty else text ('.' : show c)+ppLine _ = empty++-- |Show the line and column of a 'Position'+showLine :: Position -> String+showLine = show . ppLine++-- | Absolute first position of a file+first :: FilePath -> Position+first fn = Position fn 1 1++-- |Next position to the right+next :: Position -> Position+next = flip incr 1++-- |Increment a position by a number of columns+incr :: Position -> Int -> Position+incr p@Position { column = c } n = p { column = c + n }+incr p _ = p++-- |Number of spaces for a tabulator+tabWidth :: Int+tabWidth = 8++-- |First position after the next tabulator+tab :: Position -> Position+tab p@Position { column = c }+ = p { column = c + tabWidth - (c - 1) `mod` tabWidth }+tab p = p++-- |First position of the next line+nl :: Position -> Position+nl p@Position { line = l } = p { line = l + 1, column = 1 }+nl p = p
+ src/Curry/Base/Pretty.hs view
@@ -0,0 +1,209 @@+{- |+ Module : $Header$+ Description : Pretty printing+ Copyright : (c) 2013 - 2014 Björn Peemöller+ 2016 Finn Teegen+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : stable+ Portability : portable++ This module re-exports the well known pretty printing combinators+ from Hughes and Peyton-Jones. In addition, it re-exports the type class+ 'Pretty' for pretty printing arbitrary types.+-}+{-# LANGUAGE CPP #-}+module Curry.Base.Pretty+ ( module Curry.Base.Pretty+ , module Text.PrettyPrint+ ) where++import Prelude hiding ((<>))++import Text.PrettyPrint++-- | Pretty printing class.+-- The precedence level is used in a similar way as in the 'Show' class.+-- Minimal complete definition is either 'pPrintPrec' or 'pPrint'.+class Pretty a where+ -- | Pretty-print something in isolation.+ pPrint :: a -> Doc+ pPrint = pPrintPrec 0++ -- | Pretty-print something in a precedence context.+ pPrintPrec :: Int -> a -> Doc+ pPrintPrec _ = pPrint++ -- |Pretty-print a list.+ pPrintList :: [a] -> Doc+ pPrintList = brackets . fsep . punctuate comma . map (pPrintPrec 0)++#if __GLASGOW_HASKELL__ >= 707+ {-# MINIMAL pPrintPrec | pPrint #-}+#endif++-- | Pretty print a value to a 'String'.+prettyShow :: Pretty a => a -> String+prettyShow = render . pPrint++-- | Parenthesize an value if the boolean is true.+parenIf :: Bool -> Doc -> Doc+parenIf False = id+parenIf True = parens++-- | Pretty print a value if the boolean is true+ppIf :: Bool -> Doc -> Doc+ppIf True = id+ppIf False = const empty++-- | Pretty print a 'Maybe' value for the 'Just' constructor only+maybePP :: (a -> Doc) -> Maybe a -> Doc+maybePP = maybe empty++-- | A blank line.+blankLine :: Doc+blankLine = text ""++-- |Above with a blank line in between. If one of the documents is empty,+-- then the other document is returned.+($++$) :: Doc -> Doc -> Doc+d1 $++$ d2 | isEmpty d1 = d2+ | isEmpty d2 = d1+ | otherwise = d1 $+$ blankLine $+$ d2++-- |Above with overlapping, but with a space in between. If one of the+-- documents is empty, then the other document is returned.+($-$) :: Doc -> Doc -> Doc+d1 $-$ d2 | isEmpty d1 = d2+ | isEmpty d2 = d1+ | otherwise = d1 $$ space $$ d2++-- | Seperate a list of 'Doc's by a 'blankLine'.+sepByBlankLine :: [Doc] -> Doc+sepByBlankLine = foldr ($++$) empty++-- |A '.' character.+dot :: Doc+dot = char '.'++-- |Precedence of function application+appPrec :: Int+appPrec = 10++-- |A left arrow @<-@.+larrow :: Doc+larrow = text "<-"++-- |A right arrow @->@.+rarrow :: Doc+rarrow = text "->"++-- |A double arrow @=>@.+darrow :: Doc+darrow = text "=>"++-- |A back quote @`@.+backQuote :: Doc+backQuote = char '`'++-- |A backslash @\@.+backsl :: Doc+backsl = char '\\'++-- |A vertical bar @|@.+vbar :: Doc+vbar = char '|'++-- |Set a document in backquotes.+bquotes :: Doc -> Doc+bquotes doc = backQuote <> doc <> backQuote++-- |Set a document in backquotes if the condition is @True@.+bquotesIf :: Bool -> Doc -> Doc+bquotesIf b doc = if b then bquotes doc else doc++-- |Seperate a list of documents by commas+list :: [Doc] -> Doc+list = fsep . punctuate comma . filter (not . isEmpty)++-- | Instance for 'Int'+instance Pretty Int where pPrint = int++-- | Instance for 'Integer'+instance Pretty Integer where pPrint = integer++-- | Instance for 'Float'+instance Pretty Float where pPrint = float++-- | Instance for 'Double'+instance Pretty Double where pPrint = double++-- | Instance for '()'+instance Pretty () where pPrint _ = text "()"++-- | Instance for 'Bool'+instance Pretty Bool where pPrint = text . show++-- | Instance for 'Ordering'+instance Pretty Ordering where pPrint = text . show++-- | Instance for 'Char'+instance Pretty Char where+ pPrint = char+ pPrintList = text . show++-- | Instance for 'Maybe'+instance (Pretty a) => Pretty (Maybe a) where+ pPrintPrec _ Nothing = text "Nothing"+ pPrintPrec p (Just x) = parenIf (p > appPrec)+ $ text "Just" <+> pPrintPrec (appPrec + 1) x++-- | Instance for 'Either'+instance (Pretty a, Pretty b) => Pretty (Either a b) where+ pPrintPrec p (Left x) = parenIf (p > appPrec)+ $ text "Left" <+> pPrintPrec (appPrec + 1) x+ pPrintPrec p (Right x) = parenIf (p > appPrec)+ $ text "Right" <+> pPrintPrec (appPrec + 1) x++-- | Instance for '[]'+instance (Pretty a) => Pretty [a] where+ pPrintPrec _ = pPrintList++-- | Instance for '(,)'+instance (Pretty a, Pretty b) => Pretty (a, b) where+ pPrintPrec _ (a, b) = parens $ fsep $ punctuate comma [pPrint a, pPrint b]++-- | Instance for '(,,)'+instance (Pretty a, Pretty b, Pretty c) => Pretty (a, b, c) where+ pPrintPrec _ (a, b, c) = parens $ fsep $ punctuate comma+ [pPrint a, pPrint b, pPrint c]++-- | Instance for '(,,,)'+instance (Pretty a, Pretty b, Pretty c, Pretty d) => Pretty (a, b, c, d) where+ pPrintPrec _ (a, b, c, d) = parens $ fsep $ punctuate comma+ [pPrint a, pPrint b, pPrint c, pPrint d]++-- | Instance for '(,,,,)'+instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e)+ => Pretty (a, b, c, d, e) where+ pPrintPrec _ (a, b, c, d, e) = parens $ fsep $ punctuate comma+ [pPrint a, pPrint b, pPrint c, pPrint d, pPrint e]++-- | Instance for '(,,,,,)'+instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f)+ => Pretty (a, b, c, d, e, f) where+ pPrintPrec _ (a, b, c, d, e, f) = parens $ fsep $ punctuate comma+ [pPrint a, pPrint b, pPrint c, pPrint d, pPrint e, pPrint f]++-- | Instance for '(,,,,,,)'+instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g)+ => Pretty (a, b, c, d, e, f, g) where+ pPrintPrec _ (a, b, c, d, e, f, g) = parens $ fsep $ punctuate comma+ [pPrint a, pPrint b, pPrint c, pPrint d, pPrint e, pPrint f, pPrint g]++-- | Instance for '(,,,,,,,)'+instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h)+ => Pretty (a, b, c, d, e, f, g, h) where+ pPrintPrec _ (a, b, c, d, e, f, g, h) = parens $ fsep $ punctuate comma+ [pPrint a, pPrint b, pPrint c, pPrint d, pPrint e, pPrint f, pPrint g, pPrint h]
+ src/Curry/Base/Span.hs view
@@ -0,0 +1,180 @@+{- |+ Module : $Header$+ Description : Spans in a source file+ Copyright : (c) 2016 Jan Tikovsky+ 2016 Finn Teegen+ License : BSD-3-clause++ Maintainer : jrt@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This module implements a data type for span information in a source file and+ respective functions to operate on them. A source file span consists+ of a filename, a start position and an end position.++ In addition, the type 'SrcRef' identifies the path to an expression in+ the abstract syntax tree by argument positions, which is used for+ debugging purposes.+-}+module Curry.Base.Span where++import Prelude hiding ((<>))++import Data.Binary+import Data.List (transpose)+import Control.Monad+import System.FilePath++import Curry.Base.Position hiding (file)+import Curry.Base.Pretty++data Span+ -- |Normal source code span+ = Span+ { file :: FilePath -- ^ 'FilePath' of the source file+ , start :: Position -- ^ start position+ , end :: Position -- ^ end position+ }+ -- |no span+ | NoSpan+ deriving (Eq, Ord, Read, Show)++instance Pretty Span where+ pPrint = ppSpan++instance HasPosition Span where+ setPosition p NoSpan = Span "" p NoPos+ setPosition p (Span f _ e) = Span f p e++ getPosition NoSpan = NoPos+ getPosition (Span _ p _) = p++instance Binary Span where+ put (Span _ s e) = putWord8 0 >> put s >> put e+ put NoSpan = putWord8 1++ get = do+ x <- getWord8+ case x of+ 0 -> liftM2 (Span "") get get+ 1 -> return NoSpan+ _ -> fail "Not a valid encoding for a Span"++-- |Show a 'Span' as a 'String'+showSpan :: Span -> String+showSpan = show . ppSpan++-- |Pretty print a 'Span'+ppSpan :: Span -> Doc+ppSpan s@(Span f _ _)+ | null f = startEnd+ | otherwise = text (normalise f) <> comma <+> startEnd+ where startEnd = ppPositions s+ppSpan _ = empty++-- |Pretty print a span with it's file path and position compactly.+ppCompactSpan :: Span -> Doc+ppCompactSpan s@(Span f _ _)+ | null f = ppCompactPositions s+ | otherwise = text (normalise f) <> colon <> ppCompactPositions s+ppCompactSpan _ = empty++-- |Pretty print a source preview of a span+ppSpanPreview :: Span -> IO Doc+ppSpanPreview (Span f (Position _ sl sc) (Position _ el ec))+ | null f = return empty+ | otherwise = do+ fileContents <- readFile f++ let lns = lines fileContents+ lnContent | sl <= 0 || sl > length lns = ""+ | otherwise = lns !! (sl - 1)+ lnNum = text <$> lPadStr lnNumWidth <$> (vPad ++ [show sl] ++ vPad)+ ec' = if isMultiline then length lnContent else ec+ gutter = text <$> replicate (1 + 2 * vPadCount) "|"+ highlight = replicate (sc - 1) ' ' ++ replicate (1 + ec' - sc) '^' ++ if isMultiline then "..." else ""+ previews = text <$> (vPad ++ [lnContent, highlight] ++ replicate (vPadCount - 1) "")+ + return $ vcat $ map hsep $ transpose [lnNum, gutter, previews]+ where vPadCount = 1 -- Number of padding lines at the top and bottom+ isMultiline = el - sl > 0+ numWidth = length . show+ lnNumWidth = 1 + numWidth el+ vPad = replicate vPadCount ""+ lPadStr n s = replicate (n - length s) ' ' ++ s+ppSpanPreview _ = return empty++-- |Pretty print the positions compactly.+ppCompactPositions :: Span -> Doc+ppCompactPositions (Span _ s e) | s == e = ppCompactLine s+ | otherwise = ppCompactLine s <> text "-" <> ppCompactLine e+ppCompactPositions _ = empty++-- |Pretty print the start and end position of a 'Span'+ppPositions :: Span -> Doc+ppPositions (Span _ s e) = text "startPos:" <+> ppLine s <> comma+ <+> text "endPos:" <+> ppLine e+ppPositions _ = empty++fstSpan :: FilePath -> Span+fstSpan fn = Span fn (first fn) (first fn)++-- |Compute the column of the start position of a 'Span'+startCol :: Span -> Int+startCol (Span _ p _) = column p+startCol _ = 0++nextSpan :: Span -> Span+nextSpan sp = incrSpan sp 1++incrSpan :: Span -> Int -> Span+incrSpan (Span fn s e) n = Span fn (incr s n) (incr e n)+incrSpan sp _ = sp++-- TODO: Rename to tab and nl as soon as positions are completely replaced by spans++-- |Convert a position to a single character span.+pos2Span :: Position -> Span+pos2Span p@(Position f _ _) = Span f p p+pos2Span _ = NoSpan++-- |Convert a span to a (start) position+-- TODO: This function should be removed as soon as positions are completely replaced by spans+-- in the frontend+span2Pos :: Span -> Position+span2Pos (Span _ p _) = p+span2Pos NoSpan = NoPos++combineSpans :: Span -> Span -> Span+combineSpans sp1 sp2 = Span f s e+ where s = start sp1+ e = end sp2+ f = file sp1++-- |First position after the next tabulator+tabSpan :: Span -> Span+tabSpan (Span fn s e) = Span fn (tab s) (tab e)+tabSpan sp = sp++-- |First position of the next line+nlSpan :: Span -> Span+nlSpan (Span fn s e) = Span fn (nl s) (nl e)+nlSpan sp = sp++addSpan :: Span -> (a, [Span]) -> (a, [Span])+addSpan sp (a, ss) = (a, sp:ss)++-- |Distance of a span, i.e. the line and column distance between start+-- and end position+type Distance = (Int, Int)++-- |Set the distance of a span, i.e. update its end position+setDistance :: Span -> Distance -> Span+setDistance (Span fn p _) d = Span fn p (p `moveBy` d)+setDistance s _ = s++-- |Move position by given distance+moveBy :: Position -> Distance -> Position+moveBy (Position fn l c) (ld, cd) = Position fn (l + ld) (c + cd)+moveBy p _ = p
+ src/Curry/Base/SpanInfo.hs view
@@ -0,0 +1,139 @@+{- |+ Module : $Header$+ Description : SpansInfo for entities+ Copyright : (c) 2017 Kai-Oliver Prott+ License : BSD-3-clause++ Maintainer : fte@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This module implements a data type for span information for entities from a+ source file and function to operate on them. A span info consists of the+ span of the entity and a list of sub-spans whith additional information+ about location of keywords, e.g.+-}+module Curry.Base.SpanInfo+ ( SpanInfo(..), spanInfo, LayoutInfo(..), HasSpanInfo(..)+ , fromSrcSpan, fromSrcSpanBoth, getSrcSpan, setSrcSpan, spanInfoLike+ , fromSrcInfoPoints, getSrcInfoPoints, setSrcInfoPoints+ , getStartPosition, getSrcSpanEnd, setStartPosition, setEndPosition+ , spanInfo2Pos+ ) where++import Data.Binary+import Control.Monad++import Curry.Base.Position+import Curry.Base.Span++data SpanInfo = SpanInfo+ { srcSpan :: Span+ , srcInfoPoints :: [Span]+ }+ | NoSpanInfo+ deriving (Eq, Ord, Read, Show)++spanInfo :: Span -> [Span] -> SpanInfo+spanInfo sp sps = SpanInfo sp sps++data LayoutInfo = ExplicitLayout [Span]+ | WhitespaceLayout+ deriving (Eq, Read, Show)++class HasPosition a => HasSpanInfo a where++ getSpanInfo :: a -> SpanInfo++ setSpanInfo :: SpanInfo -> a -> a++ updateEndPos :: a -> a+ updateEndPos = id++ getLayoutInfo :: a -> LayoutInfo+ getLayoutInfo = const WhitespaceLayout++instance HasSpanInfo SpanInfo where+ getSpanInfo = id+ setSpanInfo = const++instance HasPosition SpanInfo where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance Binary SpanInfo where+ put (SpanInfo sp ss) = putWord8 0 >> put sp >> put ss+ put NoSpanInfo = putWord8 1++ get = do+ x <- getWord8+ case x of+ 0 -> liftM2 SpanInfo get get+ 1 -> return NoSpanInfo+ _ -> fail "Not a valid encoding for a SpanInfo"++instance Binary LayoutInfo where+ put (ExplicitLayout ss) = putWord8 0 >> put ss+ put WhitespaceLayout = putWord8 1++ get = do+ x <- getWord8+ case x of+ 0 -> fmap ExplicitLayout get+ 1 -> return WhitespaceLayout+ _ -> fail "Not a valid encoding for a LayoutInfo"++fromSrcSpan :: Span -> SpanInfo+fromSrcSpan sp = SpanInfo sp []++fromSrcSpanBoth :: Span -> SpanInfo+fromSrcSpanBoth sp = SpanInfo sp [sp]++getSrcSpan :: HasSpanInfo a => a -> Span+getSrcSpan a = case getSpanInfo a of+ NoSpanInfo -> NoSpan+ SpanInfo s _ -> s++setSrcSpan :: HasSpanInfo a => Span -> a -> a+setSrcSpan s a = case getSpanInfo a of+ NoSpanInfo -> setSpanInfo (SpanInfo s [] ) a+ SpanInfo _ inf -> setSpanInfo (SpanInfo s inf) a++fromSrcInfoPoints :: [Span] -> SpanInfo+fromSrcInfoPoints = SpanInfo NoSpan++getSrcInfoPoints :: HasSpanInfo a => a -> [Span]+getSrcInfoPoints a = case getSpanInfo a of+ NoSpanInfo -> []+ SpanInfo _ xs -> xs++setSrcInfoPoints :: HasSpanInfo a => [Span] -> a -> a+setSrcInfoPoints inf a = case getSpanInfo a of+ NoSpanInfo -> setSpanInfo (SpanInfo NoSpan inf) a+ SpanInfo s _ -> setSpanInfo (SpanInfo s inf) a++getStartPosition :: HasSpanInfo a => a -> Position+getStartPosition a = case getSrcSpan a of+ NoSpan -> NoPos+ Span _ s _ -> s++getSrcSpanEnd :: HasSpanInfo a => a -> Position+getSrcSpanEnd a = case getSpanInfo a of+ NoSpanInfo -> NoPos+ SpanInfo s _ -> end s++setStartPosition :: HasSpanInfo a => Position -> a -> a+setStartPosition p a = case getSrcSpan a of+ NoSpan -> setSrcSpan (Span "" p NoPos) a+ Span f _ e -> setSrcSpan (Span f p e) a++setEndPosition :: HasSpanInfo a => Position -> a -> a+setEndPosition e a = case getSrcSpan a of+ NoSpan -> setSrcSpan (Span "" NoPos e) a+ Span f p _ -> setSrcSpan (Span f p e) a++spanInfo2Pos :: HasSpanInfo a => a -> Position+spanInfo2Pos = getStartPosition++spanInfoLike :: (HasSpanInfo a, HasSpanInfo b) => a -> b -> a+spanInfoLike a b = setSpanInfo (getSpanInfo b) a
+ src/Curry/CondCompile/Parser.hs view
@@ -0,0 +1,90 @@+{- |+ Module : $Header$+ Description : Parser for conditional compiling+ Copyright : (c) 2017 Kai-Oliver Prott+ 2017 Finn Teegen+ License : BSD-3-clause++ Maintainer : fte@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ TODO+-}+{-# LANGUAGE CPP #-}+module Curry.CondCompile.Parser where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>), (<*>), (*>), (<*))+#endif++import Text.Parsec++import Curry.CondCompile.Type++type Parser a = Parsec String () a++program :: Parser Program+program = statement `sepBy` eol <* eof++statement :: Parser Stmt+statement = ifElse "if" condition If+ <|> ifElse "ifdef" identifier IfDef+ <|> ifElse "ifndef" identifier IfNDef+ <|> define+ <|> undef+ <|> line++ifElse :: String -> Parser a -> (a -> [Stmt] -> [Elif] -> Else -> Stmt)+ -> Parser Stmt+ifElse k p c = c <$> (try (many sp *> keyword k *> many1 sp) *> p <* many sp <* eol)+ <*> many (statement <* eol)+ <*> many (Elif <$> ((,) <$> (try (many sp *> keyword "elif" *> many1 sp) *> condition <* many sp <* eol)+ <*> many (statement <* eol)))+ <*> (Else <$> optionMaybe+ (try (many sp *> keyword "else" *> many sp) *> eol *> many (statement <* eol)))+ <* try (many sp <* keyword "endif" <* many sp)++define :: Parser Stmt+define = Define <$> (try (many sp *> keyword "define" *> many1 sp) *> identifier <* many1 sp)+ <*> value <* many sp++undef :: Parser Stmt+undef = Undef <$> (try (many sp *> keyword "undef" *> many1 sp) *> identifier <* many sp)++line :: Parser Stmt+line = do+ sps <- many sp+ try $ ((char '#' <?> "") *> fail "unknown directive")+ <|> ((Line . (sps ++)) <$> manyTill anyChar (try (lookAhead (eol <|> eof))))++keyword :: String -> Parser String+keyword = string . ('#' :)++condition :: Parser Cond+condition = (Defined <$> (try (string "defined(") *> many sp *> identifier <* many sp <* char ')'))+ <|> (NDefined <$> (try (string "!defined(") *> many sp *> identifier <* many sp <* char ')'))+ <|> (Comp <$> (identifier <* many sp) <*> operator <*> (many sp *> value) <?> "condition")++identifier :: Parser String+identifier = (:) <$> firstChar <*> many (firstChar <|> digit) <?> "identifier"+ where firstChar = letter <|> char '_'++operator :: Parser Op+operator = choice [ Leq <$ try (string "<=")+ , Lt <$ try (string "<")+ , Geq <$ try (string ">=")+ , Gt <$ try (string ">")+ , Neq <$ try (string "!=")+ , Eq <$ string "=="+ ] <?> "operator"++value :: Parser Int+value = fmap read (many1 digit)++eol :: Parser ()+eol = endOfLine *> return ()++sp :: Parser Char+sp = try $ lookAhead (eol *> unexpected "end of line" <?> "")+ <|> space
+ src/Curry/CondCompile/Transform.hs view
@@ -0,0 +1,116 @@+{- |+ Module : $Header$+ Description : Conditional compiling transformation+ Copyright : (c) 2017 Kai-Oliver Prott+ 2017 Finn Teegen+ License : BSD-3-clause++ Maintainer : fte@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ TODO+-}+module Curry.CondCompile.Transform (condTransform) where++import Control.Monad.State+import Control.Monad.Extra (concatMapM)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Text.Parsec hiding (State)+import Text.Parsec.Error ()++import Curry.Base.Message+import Curry.Base.Position+import Curry.Base.Pretty++import Curry.CondCompile.Parser+import Curry.CondCompile.Type++type CCState = Map.Map String Int++type CCM = State CCState++condTransform :: CCState -> FilePath -> String -> Either Message String+condTransform s fn p = either (Left . convertError)+ (Right . transformWith s)+ (parse program fn p)++transformWith :: CCState -> Program -> String+transformWith s p = show $ pPrint $ evalState (transform p) s++convertError :: ParseError -> Message+convertError err = posMessage pos $+ foldr ($+$) empty $ map text $ tail $ lines $ show err+ where pos = Position (sourceName src) (sourceLine src) (sourceColumn src)+ src = errorPos err++class CCTransform a where+ transform :: a -> CCM [Stmt]++instance CCTransform Stmt where+ transform (Line s) = return [Line s]+ transform (If c stmts is e) = do+ s <- get+ if checkCond c s+ then do stmts' <- transform stmts+ return (blank : stmts' ++ fill is ++ fill e ++ [blank])+ else case is of+ [] -> do+ stmts' <- transform e+ return (blank : fill stmts ++ stmts' ++ [blank])+ (Elif (c', stmts') : is') -> do+ stmts'' <- transform (If c' stmts' is' e)+ return (blank : fill stmts ++ stmts'')+ transform (IfDef v stmts is e) = transform (If (Defined v) stmts is e)+ transform (IfNDef v stmts is e) = transform (If (NDefined v) stmts is e)+ transform (Define v i) = modify (Map.insert v i) >> return [blank]+ transform (Undef v ) = modify (Map.delete v) >> return [blank]++instance CCTransform a => CCTransform [a] where+ transform = concatMapM transform++instance CCTransform Else where+ transform (Else (Just p)) = (blank :) <$> transform p+ transform (Else Nothing ) = return []++checkCond :: Cond -> CCState -> Bool+checkCond (Comp v op i) = flip (compareOp op) i . fromMaybe 0 . Map.lookup v+checkCond (Defined v) = Map.member v+checkCond (NDefined v) = Map.notMember v++compareOp :: Ord a => Op -> a -> a -> Bool+compareOp Eq = (==)+compareOp Neq = (/=)+compareOp Lt = (<)+compareOp Leq = (<=)+compareOp Gt = (>)+compareOp Geq = (>=)++class FillLength a where+ fillLength :: a -> Int++instance FillLength Stmt where+ fillLength (Line _ ) = 1+ fillLength (Define _ _ ) = 1+ fillLength (Undef _ ) = 1+ fillLength (If _ stmts is e) =+ 3 + fillLength stmts + fillLength e + fillLength is+ fillLength (IfDef v stmts is e) = fillLength (If (Defined v) stmts is e)+ fillLength (IfNDef v stmts is e) = fillLength (If (NDefined v) stmts is e)++instance FillLength a => FillLength [a] where+ fillLength = foldr ((+) . fillLength) 0++instance FillLength Else where+ fillLength (Else (Just stmts)) = 1 + fillLength stmts+ fillLength (Else Nothing ) = 0++instance FillLength Elif where+ fillLength (Elif (_, stmts)) = 1 + fillLength stmts++fill :: FillLength a => a -> [Stmt]+fill p = replicate (fillLength p) blank++blank :: Stmt+blank = Line ""
+ src/Curry/CondCompile/Type.hs view
@@ -0,0 +1,88 @@+{- |+ Module : $Header$+ Description : Abstract syntax for conditional compiling+ Copyright : (c) 2017 Kai-Oliver Prott+ 2017 Finn Teegen+ License : BSD-3-clause++ Maintainer : fte@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ TODO+-}+{-# LANGUAGE CPP #-}+module Curry.CondCompile.Type+ ( Program, Stmt (..), Else (..), Elif (..), Cond (..), Op (..)+ ) where++#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif++import Curry.Base.Pretty++type Program = [Stmt]++data Stmt = If Cond [Stmt] [Elif] Else+ | IfDef String [Stmt] [Elif] Else+ | IfNDef String [Stmt] [Elif] Else+ | Define String Int+ | Undef String+ | Line String+ deriving Show++newtype Else = Else (Maybe [Stmt])+ deriving Show++newtype Elif = Elif (Cond, [Stmt])+ deriving Show++data Cond = Comp String Op Int+ | Defined String+ | NDefined String+ deriving Show++data Op = Eq+ | Neq+ | Lt+ | Leq+ | Gt+ | Geq+ deriving Show++instance Pretty Stmt where+ pPrint (If c stmts is e) = prettyIf "#if" (pPrint c) stmts is e+ pPrint (IfDef v stmts is e) = prettyIf "#ifdef" (text v) stmts is e+ pPrint (IfNDef v stmts is e) = prettyIf "#ifndef" (text v) stmts is e+ pPrint (Define v i ) = text "#define" <+> text v <+> int i+ pPrint (Undef v ) = text "#undef" <+> text v+ pPrint (Line s ) = text s++ pPrintList = foldr (($+$) . pPrint) empty++instance Pretty Elif where+ pPrint (Elif (c, stmts)) = text "#elif" <+> pPrint c $+$ pPrint stmts++ pPrintList = foldr (($+$) . pPrint) empty++instance Pretty Else where+ pPrint (Else (Just stmts)) = text "#else" $+$ pPrint stmts+ pPrint (Else Nothing) = empty++prettyIf :: String -> Doc -> [Stmt] -> [Elif] -> Else -> Doc+prettyIf k doc stmts is e = foldr ($+$) empty+ [text k <+> doc, pPrint stmts, pPrint is, pPrint e, text "#endif"]++instance Pretty Cond where+ pPrint (Comp v op i) = text v <+> pPrint op <+> int i+ pPrint (Defined v ) = text "defined(" <> text v <> char ')'+ pPrint (NDefined v ) = text "!defined(" <> text v <> char ')'++instance Pretty Op where+ pPrint Eq = text "=="+ pPrint Neq = text "/="+ pPrint Lt = text "<"+ pPrint Leq = text "<="+ pPrint Gt = text ">"+ pPrint Geq = text ">="
+ src/Curry/Files/Filenames.hs view
@@ -0,0 +1,256 @@+{- |+ Module : $Header$+ Description : File names for several intermediate file formats.+ Copyright : (c) 2009 Holger Siegel+ 2013 - 2014 Björn Peemöller+ 2018 Kai-Oliver Prott+ License : BSD-3-clause++ Maintainer : fte@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ The functions in this module were collected from several compiler modules+ in order to provide a unique accessing point for this functionality.+-}+module Curry.Files.Filenames+ ( -- * Re-exports from 'System.FilePath'+ FilePath, takeBaseName, dropExtension, takeExtension, takeFileName++ -- * Conversion between 'ModuleIdent' and 'FilePath'+ , moduleNameToFile, fileNameToModule, splitModuleFileName, isCurryFilePath++ -- * Curry sub-directory+ , defaultOutDir, hasOutDir, addOutDir, addOutDirModule+ , ensureOutDir++ -- * File name extensions+ -- ** Curry files+ , curryExt, lcurryExt, icurryExt++ -- ** FlatCurry files+ , annotatedFlatExt, typedFlatExt, flatExt, flatIntExt++ -- ** AbstractCurry files+ , acyExt, uacyExt++ -- ** Source and object files+ , sourceRepExt, sourceExts, moduleExts++ -- * Functions for computing file names+ , interfName, typedFlatName, annotatedFlatName, flatName, flatIntName+ , acyName, uacyName, sourceRepName, tokensName, commentsName+ , astName, shortASTName, htmlName+ ) where++import System.FilePath++import Curry.Base.Ident++-- -----------------------------------------------------------------------------+-- Conversion between ModuleIdent and FilePath+-- -----------------------------------------------------------------------------++-- |Create a 'FilePath' from a 'ModuleIdent' using the hierarchical module+-- system+moduleNameToFile :: ModuleIdent -> FilePath+moduleNameToFile = foldr1 (</>) . midQualifiers++-- |Extract the 'ModuleIdent' from a 'FilePath'+fileNameToModule :: FilePath -> ModuleIdent+fileNameToModule = mkMIdent . splitDirectories . dropExtension . dropDrive++-- |Split a 'FilePath' into a prefix directory part and those part that+-- corresponds to the 'ModuleIdent'. This is especially useful for+-- hierarchically module names.+splitModuleFileName :: ModuleIdent -> FilePath -> (FilePath, FilePath)+splitModuleFileName m fn = case midQualifiers m of+ [_] -> splitFileName fn+ ms -> let (base, ext) = splitExtension fn+ dirs = splitDirectories base+ (pre, suf) = splitAt (length dirs - length ms) dirs+ path = if null pre then ""+ else addTrailingPathSeparator (joinPath pre)+ in (path, joinPath suf <.> ext)++-- |Checks whether a 'String' represents a 'FilePath' to a Curry module+isCurryFilePath :: String -> Bool+isCurryFilePath str = isValid str+ && takeExtension str `elem` ("" : moduleExts)++-- -----------------------------------------------------------------------------+-- Curry sub-directory+-- -----------------------------------------------------------------------------++-- |The standard hidden subdirectory for curry files+defaultOutDir :: String+defaultOutDir = ".curry"++-- |Does the given 'FilePath' contain the 'outDir'+-- as its last directory component?+hasOutDir :: String -> FilePath -> Bool+hasOutDir outDir f = not (null dirs) && last dirs == outDir+ where dirs = splitDirectories $ takeDirectory f++-- |Add the 'outDir' to the given 'FilePath' if the flag is 'True' and+-- the path does not already contain it, otherwise leave the path untouched.+addOutDir :: Bool -> String -> FilePath -> FilePath+addOutDir b outDir fn = if b then ensureOutDir outDir fn else fn++-- |Add the 'outDir' to the given 'FilePath' if the flag is 'True' and+-- the path does not already contain it, otherwise leave the path untouched.+addOutDirModule :: Bool -> String -> ModuleIdent -> FilePath -> FilePath+addOutDirModule b outDir m fn+ | b = let (pre, file) = splitModuleFileName m fn+ in ensureOutDir outDir pre </> file+ | otherwise = fn++-- | Ensure that the 'outDir' is the last component of the+-- directory structure of the given 'FilePath'. If the 'FilePath' already+-- contains the sub-directory, it remains unchanged.+ensureOutDir :: String -- ^ the 'outDir'+ -> FilePath -- ^ original 'FilePath'+ -> FilePath -- ^ new 'FilePath'+ensureOutDir outDir fn = normalise $ addSub (splitDirectories d) </> f+ where+ (d, f) = splitFileName fn+ addSub dirs | null dirs = outDir+ | last dirs == outDir = joinPath dirs+ | otherwise = joinPath dirs </> outDir++-- -----------------------------------------------------------------------------+-- File name extensions+-- -----------------------------------------------------------------------------++-- |Filename extension for non-literate curry files+curryExt :: String+curryExt = ".curry"++-- |Filename extension for literate curry files+lcurryExt :: String+lcurryExt = ".lcurry"++-- |Filename extension for curry interface files+icurryExt :: String+icurryExt = ".icurry"++-- |Filename extension for curry source files.+--+-- /Note:/ The order of the extensions defines the order in which source files+-- should be searched for, i.e. given a module name @M@, the search order+-- should be the following:+--+-- 1. @M.curry@+-- 2. @M.lcurry@+--+sourceExts :: [String]+sourceExts = [curryExt, lcurryExt]++-- |Filename extension for curry module files+-- TODO: Is the order correct?+moduleExts :: [String]+moduleExts = sourceExts ++ [icurryExt]++-- |Filename extension for typed flat-curry files+typedFlatExt :: String+typedFlatExt = ".tfcy"++-- |Filename extension for type-annotated flat-curry files+annotatedFlatExt :: String+annotatedFlatExt = ".tafcy"++-- |Filename extension for flat-curry files+flatExt :: String+flatExt = ".fcy"++-- |Filename extension for extended-flat-curry interface files+flatIntExt :: String+flatIntExt = ".fint"++-- |Filename extension for abstract-curry files+acyExt :: String+acyExt = ".acy"++-- |Filename extension for untyped-abstract-curry files+uacyExt :: String+uacyExt = ".uacy"++-- |Filename extension for curry source representation files+sourceRepExt :: String+sourceRepExt = ".cy"++-- |Filename extension for token files+tokensExt :: String+tokensExt = ".tokens"++-- |Filename extension for comment token files+commentsExt :: String+commentsExt = ".cycom"++-- |Filename extension for AST files+astExt :: String+astExt = ".ast"++-- |Filename extension for shortened AST files+shortASTExt :: String+shortASTExt = ".sast"++-- ---------------------------------------------------------------------------+-- Computation of file names for a given source file+-- ---------------------------------------------------------------------------++-- |Compute the filename of the interface file for a source file+interfName :: FilePath -> FilePath+interfName = replaceExtensionWith icurryExt++-- |Compute the filename of the typed flat curry file for a source file+typedFlatName :: FilePath -> FilePath+typedFlatName = replaceExtensionWith typedFlatExt++-- |Compute the filename of the typed flat curry file for a source file+annotatedFlatName :: FilePath -> FilePath+annotatedFlatName = replaceExtensionWith annotatedFlatExt++-- |Compute the filename of the flat curry file for a source file+flatName :: FilePath -> FilePath+flatName = replaceExtensionWith flatExt++-- |Compute the filename of the flat curry interface file for a source file+flatIntName :: FilePath -> FilePath+flatIntName = replaceExtensionWith flatIntExt++-- |Compute the filename of the abstract curry file for a source file+acyName :: FilePath -> FilePath+acyName = replaceExtensionWith acyExt++-- |Compute the filename of the untyped abstract curry file for a source file+uacyName :: FilePath -> FilePath+uacyName = replaceExtensionWith uacyExt++-- |Compute the filename of the source representation file for a source file+sourceRepName :: FilePath -> FilePath+sourceRepName = replaceExtensionWith sourceRepExt++-- |Compute the filename of the tokens file for a source file+tokensName :: FilePath -> FilePath+tokensName = replaceExtensionWith tokensExt++-- |Compute the filename of the comment tokens file for a source file+commentsName :: FilePath -> FilePath+commentsName = replaceExtensionWith commentsExt++-- |Compute the filename of the ast file for a source file+astName :: FilePath -> FilePath+astName = replaceExtensionWith astExt++-- |Compute the filename of the ast file for a source file+shortASTName :: FilePath -> FilePath+shortASTName = replaceExtensionWith shortASTExt++-- |Compute the filename of the HTML file for a source file+htmlName :: ModuleIdent -> String+htmlName m = moduleName m ++ "_curry.html"++-- |Replace a filename extension with a new extension+replaceExtensionWith :: String -> FilePath -> FilePath+replaceExtensionWith = flip replaceExtension
+ src/Curry/Files/PathUtils.hs view
@@ -0,0 +1,206 @@+{- |+ Module : $Header$+ Description : Utility functions for reading and writing files+ Copyright : (c) 1999 - 2003, Wolfgang Lux+ 2011 - 2014, Björn Peemöller (bjp@informatik.uni-kiel.de)+ 2017 , Finn Teegen (fte@informatik.uni-kiel.de)+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable+-}++{-# LANGUAGE CPP #-}++module Curry.Files.PathUtils+ ( -- * Retrieving curry files+ lookupCurryFile+ , lookupCurryModule+ , lookupCurryInterface+ , lookupFile++ -- * Reading and writing modules from files+ , getModuleModTime+ , writeModule+ , readModule+ , writeBinaryModule+ , addVersion+ , checkVersion+ ) where++import qualified Control.Exception as C (IOException, handle)+import Control.Monad (liftM)+import Data.List (isPrefixOf, isSuffixOf)+import qualified Data.ByteString.Lazy as B (ByteString, writeFile)+import System.FilePath+import System.Directory+import System.IO++#if MIN_VERSION_directory(1,2,0)+import Data.Time (UTCTime)+#else+import System.Time (ClockTime)+#endif++import Curry.Base.Ident+import Curry.Files.Filenames++-- ---------------------------------------------------------------------------+-- Searching for files+-- ---------------------------------------------------------------------------++-- |Search in the given list of paths for the given 'FilePath' and eventually+-- return the file name of the found file.+--+-- - If the file name already contains a directory, then the paths to search+-- in are ignored.+-- - If the file name has no extension, then a source file extension is+-- assumed.+lookupCurryFile :: [FilePath] -> FilePath -> IO (Maybe FilePath)+lookupCurryFile paths fn = lookupFile paths exts fn+ where+ exts | null fnExt = sourceExts+ | otherwise = [fnExt]+ fnExt = takeExtension fn++-- |Search for a given curry module in the given source file and+-- library paths. Note that the current directory is always searched first.+-- Returns the path of the found file.+lookupCurryModule :: [FilePath] -- ^ list of paths to source files+ -> [FilePath] -- ^ list of paths to library files+ -> ModuleIdent -- ^ module identifier+ -> IO (Maybe FilePath)+lookupCurryModule paths libPaths m =+ lookupFile (paths ++ libPaths) moduleExts (moduleNameToFile m)++-- |Search for an interface file in the import search path using the+-- interface extension 'icurryExt'. Note that the current directory is+-- always searched first.+lookupCurryInterface :: [FilePath] -- ^ list of paths to search in+ -> ModuleIdent -- ^ module identifier+ -> IO (Maybe FilePath) -- ^ the file path if found+lookupCurryInterface paths m = lookupFile paths [icurryExt] (moduleNameToFile m)++-- |Search in the given directories for the file with the specified file+-- extensions and eventually return the 'FilePath' of the file.+lookupFile :: [FilePath] -- ^ Directories to search in+ -> [String] -- ^ Accepted file extensions+ -> FilePath -- ^ Initial file name+ -> IO (Maybe FilePath) -- ^ 'FilePath' of the file if found+lookupFile paths exts file = lookup' files+ where+ files = [ normalise (p </> f) | p <- paths, f <- baseNames ]+ baseNames = map (replaceExtension file) exts++ lookup' [] = return Nothing+ lookup' (f : fs) = do+ exists <- doesFileExist f+ if exists then return (Just f) else lookup' fs++-- ---------------------------------------------------------------------------+-- Reading and writing files+-- ---------------------------------------------------------------------------++-- | Write the content to a file in the given directory.+writeModule :: FilePath -- ^ original path+ -> String -- ^ file content+ -> IO ()+writeModule fn contents = do+ createDirectoryIfMissing True $ takeDirectory fn+ tryWriteFile fn contents++-- | Write the content in binary to a file in the given directory.+writeBinaryModule :: FilePath -- ^ original path+ -> B.ByteString -- ^ file content+ -> IO ()+writeBinaryModule fn contents = do+ createDirectoryIfMissing True $ takeDirectory fn+ tryWriteBinaryFile (fn ++ "-bin") contents++-- | Read the specified module and returns either 'Just String' if+-- reading was successful or 'Nothing' otherwise.+readModule :: FilePath -> IO (Maybe String)+readModule = tryOnExistingFile readFileUTF8+ where+ readFileUTF8 :: FilePath -> IO String+ readFileUTF8 fn = do+ hdl <- openFile fn ReadMode+ hSetEncoding hdl utf8+ hGetContents hdl++-- | Get the modification time of a file, if existent+#if MIN_VERSION_directory(1,2,0)+getModuleModTime :: FilePath -> IO (Maybe UTCTime)+#else+getModuleModTime :: FilePath -> IO (Maybe ClockTime)+#endif+getModuleModTime = tryOnExistingFile getModificationTime++-- |Add the given version string to the file content+addVersion :: String -> String -> String+addVersion v content = "{- " ++ v ++ " -}\n" ++ content++-- |Check a source file for the given version string+checkVersion :: String -> String -> Either String String+checkVersion expected src = case lines src of+ [] -> Left "empty file"+ (l:ls) -> case getVersion l of+ Just v | v == expected -> Right (unlines ls)+ | otherwise -> Left $ "Expected version `" ++ expected+ ++ "', but found version `" ++ v ++ "'"+ _ -> Left $ "No version found"++ where+ getVersion s | "{- " `isPrefixOf` s && " -}" `isSuffixOf` s+ = Just (reverse $ drop 3 $ reverse $ drop 3 s)+ | otherwise+ = Nothing++-- ---------------------------------------------------------------------------+-- Helper functions+-- ---------------------------------------------------------------------------++tryOnExistingFile :: (FilePath -> IO a) -> FilePath -> IO (Maybe a)+tryOnExistingFile action fn = C.handle ignoreIOException $ do+ exists <- doesFileExist fn+ if exists then Just `liftM` action fn+ else return Nothing++ignoreIOException :: C.IOException -> IO (Maybe a)+ignoreIOException _ = return Nothing++-- | Try to write a file. If it already exists and is not writable,+-- a warning is issued. This solves some file dependency problems+-- in global installations.+tryWriteFile :: FilePath -- ^ original path+ -> String -- ^ file content+ -> IO ()+tryWriteFile fn contents = do+ exists <- doesFileExist fn+ if exists then C.handle issueWarning (writeFileUTF8 fn contents)+ else writeFileUTF8 fn contents+ where+ issueWarning :: C.IOException -> IO ()+ issueWarning _ = do+ putStrLn $ "*** Warning: cannot update file `" ++ fn ++ "' (update ignored)"+ return ()+ writeFileUTF8 :: FilePath -> String -> IO ()+ writeFileUTF8 fn' str =+ withFile fn' WriteMode (\hdl -> hSetEncoding hdl utf8 >> hPutStr hdl str)++-- | Try to write a file. If it already exists and is not writable,+-- a warning is issued. This solves some file dependency problems+-- in global installations.+tryWriteBinaryFile :: FilePath -- ^ original path+ -> B.ByteString -- ^ file content+ -> IO ()+tryWriteBinaryFile fn contents = do+ exists <- doesFileExist fn+ if exists then C.handle issueWarning (B.writeFile fn contents)+ else B.writeFile fn contents+ where+ issueWarning :: C.IOException -> IO ()+ issueWarning _ = do+ putStrLn $ "*** Warning: cannot update file `" ++ fn ++ "' (update ignored)"+ return ()
+ src/Curry/Files/Unlit.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE ViewPatterns #-}+{- |+ Module : $Header$+ Description : Handling of literate Curry files+ Copyright : (c) 2009 Holger Siegel+ 2012 - 2014 Björn Peemöller+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ Since version 0.7 of the language report, Curry accepts literate+ source programs. In a literate source, all program lines must begin+ with a greater sign in the first column. All other lines are assumed+ to be documentation. In order to avoid some common errors with+ literate programs, Curry requires at least one program line to be+ present in the file. In addition, every block of program code must be+ preceded by a blank line and followed by a blank line.++ It is also possible to use "\begin{code}" and "\end{code}"+ to mark code segments. Both styles can be used in mixed fashion.+-}++module Curry.Files.Unlit (isLiterate, unlit) where++import Control.Monad (when, unless, zipWithM)+import Data.Char (isSpace)+import Data.List (stripPrefix)++import Curry.Base.Monad (CYM, failMessageAt)+import Curry.Base.Span (pos2Span)+import Curry.Base.Position (Position (..), first)+import Curry.Files.Filenames (lcurryExt, takeExtension)++-- |Check whether a 'FilePath' represents a literate Curry module+isLiterate :: FilePath -> Bool+isLiterate = (== lcurryExt) . takeExtension++-- |Data type representing different kind of lines in a literate source+data Line+ = ProgramStart !Int -- ^ \begin{code}+ | ProgramEnd !Int -- ^ \end{code}+ | Program !Int String -- ^ program line with a line number and content+ | Comment !Int String -- ^ comment line+ | Blank !Int -- ^ blank line++-- |Process a curry program into error messages (if any) and the+-- corresponding non-literate program.+unlit :: FilePath -> String -> CYM String+unlit fn cy+ | isLiterate fn = do+ let cyl = lines cy+ ls <- progLines fn =<<+ normalize fn (length cyl) False (zipWith classify [1 .. ] cyl)+ when (all null ls) $ failMessageAt (pos2Span $ first fn) "No code in literate script"+ return (unlines ls)+ | otherwise = return cy++-- |Classification of a single program line+classify :: Int -> String -> Line+classify l s@('>' : _) = Program l s+classify l s@(stripPrefix "\\begin{code}" -> Just cs)+ | all isSpace cs = ProgramStart l+ | otherwise = Comment l s+classify l s@(stripPrefix "\\end{code}" -> Just cs)+ | all isSpace cs = ProgramEnd l+ | otherwise = Comment l s+classify l s+ | all isSpace s = Blank l+ | otherwise = Comment l s++-- |Check that ProgramStart and ProgramEnd match and desugar them.+normalize :: FilePath -> Int -> Bool -> [Line] -> CYM [Line]+normalize _ _ False [] = return []+normalize fn n True [] = reportMissingEnd fn n+normalize fn n b (ProgramStart l : rest) = do+ when b $ reportSpurious fn l "\\begin{code}"+ norm <- normalize fn n True rest+ return (Blank l : norm)+normalize fn n b (ProgramEnd l : rest) = do+ unless b $ reportSpurious fn l "\\end{code}"+ norm <- normalize fn n False rest+ return (Blank l : norm)+normalize fn n b (Comment l s : rest) = do+ let cons = if b then Program l s else Comment l s+ norm <- normalize fn n b rest+ return (cons : norm)+normalize fn n b (Program l s : rest) = do+ let cons = if b then Program l s else Program l (drop 1 s)+ norm <- normalize fn n b rest+ return (cons : norm)+normalize fn n b (Blank l : rest) = do+ let cons = if b then Program l "" else Blank l+ norm <- normalize fn n b rest+ return (cons : norm)++-- |Check that each program line is not adjacent to a comment line.+progLines :: FilePath -> [Line] -> CYM [String]+progLines fn cs = zipWithM checkAdjacency (Blank 0 : cs) cs where+ checkAdjacency (Program p _) (Comment _ _) = reportBlank fn p "followed"+ checkAdjacency (Comment _ _) (Program p _) = reportBlank fn p "preceded"+ checkAdjacency _ (Program _ s) = return s+ checkAdjacency _ _ = return ""++-- |Compute an appropiate error message+reportBlank :: FilePath -> Int -> String -> CYM a+reportBlank f l cause = failMessageAt (pos2Span $ Position f l 1) msg+ where msg = concat [ "When reading literate source: "+ , "Program line is " ++ cause ++ " by comment line."+ ]++reportMissingEnd :: FilePath -> Int -> CYM a+reportMissingEnd f l = failMessageAt (pos2Span $ Position f (l+1) 1) msg+ where msg = concat [ "When reading literate source: "+ , "Missing '\\end{code}' at the end of file."+ ]+++reportSpurious :: FilePath -> Int -> String -> CYM a+reportSpurious f l cause = failMessageAt (pos2Span $ Position f l 1) msg+ where msg = concat [ "When reading literate source: "+ , "Spurious '" ++ cause ++ "'."+ ]
+ src/Curry/FlatCurry.hs view
@@ -0,0 +1,19 @@+{- |+ Module : $Header$+ Description : Interface for reading and manipulating FlatCurry source code+ Copyright : (c) 2014 Björn Peemöller+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable+-}+module Curry.FlatCurry+ ( module Curry.FlatCurry.Type+ , module Curry.FlatCurry.Pretty+ , module Curry.FlatCurry.Files+ ) where++import Curry.FlatCurry.Files+import Curry.FlatCurry.Pretty+import Curry.FlatCurry.Type
+ src/Curry/FlatCurry/Annotated/Goodies.hs view
@@ -0,0 +1,685 @@+{- |+ Module : $Header$+ Description : Utility functions for working with annotated FlatCurry.+ Copyright : (c) 2016 - 2017 Finn Teegen+ License : BSD-3-clause++ Maintainer : fte@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This library provides selector functions, test and update operations+ as well as some useful auxiliary functions for AnnotatedFlatCurry data terms.+ Most of the provided functions are based on general transformation+ functions that replace constructors with user-defined+ functions. For recursive datatypes the transformations are defined+ inductively over the term structure. This is quite usual for+ transformations on AnnotatedFlatCurry terms,+ so the provided functions can be used to implement specific transformations+ without having to explicitly state the recursion. Essentially, the tedious+ part of such transformations - descend in fairly complex term structures -+ is abstracted away, which hopefully makes the code more clear and brief.+-}++module Curry.FlatCurry.Annotated.Goodies+ ( module Curry.FlatCurry.Annotated.Goodies+ , module Curry.FlatCurry.Goodies+ ) where++import Curry.FlatCurry.Goodies ( Update+ , trType, typeName, typeVisibility, typeParams+ , typeConsDecls, typeSyn, isTypeSyn+ , isDataTypeDecl, isExternalType, isPublicType+ , updType, updTypeName, updTypeVisibility+ , updTypeParams, updTypeConsDecls, updTypeSynonym+ , updQNamesInType+ , trCons, consName, consArity, consVisibility+ , isPublicCons, consArgs, updCons, updConsName+ , updConsArity, updConsVisibility, updConsArgs+ , updQNamesInConsDecl+ , trNewCons, newConsName, newConsVisibility+ , isPublicNewCons, newConsArg+ , updNewCons, updNewConsName+ , updNewConsVisibility, updNewConsArg+ , updQNamesInNewConsDecl+ , tVarIndex, domain, range, tConsName, tConsArgs+ , trTypeExpr, isTVar, isTCons, isFuncType+ , updTVars, updTCons, updFuncTypes, argTypes+ , typeArity, resultType, allVarsInTypeExpr+ , allTypeCons, rnmAllVarsInTypeExpr+ , updQNamesInTypeExpr+ , trOp, opName, opFixity, opPrecedence, updOp+ , updOpName, updOpFixity, updOpPrecedence+ , trCombType, isCombTypeFuncCall+ , isCombTypeFuncPartCall, isCombTypeConsCall+ , isCombTypeConsPartCall+ , isPublic+ )++import Curry.FlatCurry.Annotated.Type++-- AProg ----------------------------------------------------------------------++-- |transform program+trAProg :: (String -> [String] -> [TypeDecl] -> [AFuncDecl a] -> [OpDecl] -> b)+ -> AProg a -> b+trAProg prog (AProg name imps types funcs ops) = prog name imps types funcs ops++-- Selectors++-- |get name from program+aProgName :: AProg a -> String+aProgName = trAProg (\name _ _ _ _ -> name)++-- |get imports from program+aProgImports :: AProg a -> [String]+aProgImports = trAProg (\_ imps _ _ _ -> imps)++-- |get type declarations from program+aProgTypes :: AProg a -> [TypeDecl]+aProgTypes = trAProg (\_ _ types _ _ -> types)++-- |get functions from program+aProgAFuncs :: AProg a -> [AFuncDecl a]+aProgAFuncs = trAProg (\_ _ _ funcs _ -> funcs)++-- |get infix operators from program+aProgOps :: AProg a -> [OpDecl]+aProgOps = trAProg (\_ _ _ _ ops -> ops)++-- Update Operations++-- |update program+updAProg :: (String -> String) ->+ ([String] -> [String]) ->+ ([TypeDecl] -> [TypeDecl]) ->+ ([AFuncDecl a] -> [AFuncDecl a]) ->+ ([OpDecl] -> [OpDecl]) -> AProg a -> AProg a+updAProg fn fi ft ff fo = trAProg prog+ where+ prog name imps types funcs ops+ = AProg (fn name) (fi imps) (ft types) (ff funcs) (fo ops)++-- |update name of program+updAProgName :: Update (AProg a) String+updAProgName f = updAProg f id id id id++-- |update imports of program+updAProgImports :: Update (AProg a) [String]+updAProgImports f = updAProg id f id id id++-- |update type declarations of program+updAProgTypes :: Update (AProg a) [TypeDecl]+updAProgTypes f = updAProg id id f id id++-- |update functions of program+updAProgAFuncs :: Update (AProg a) [AFuncDecl a]+updAProgAFuncs f = updAProg id id id f id++-- |update infix operators of program+updAProgOps :: Update (AProg a) [OpDecl]+updAProgOps = updAProg id id id id++-- Auxiliary Functions++-- |get all program variables (also from patterns)+allVarsInAProg :: AProg a -> [(VarIndex, a)]+allVarsInAProg = concatMap allVarsInAFunc . aProgAFuncs++-- |lift transformation on expressions to program+updAProgAExps :: Update (AProg a) (AExpr a)+updAProgAExps = updAProgAFuncs . map . updAFuncBody++-- |rename programs variables+rnmAllVarsInAProg :: Update (AProg a) VarIndex+rnmAllVarsInAProg = updAProgAFuncs . map . rnmAllVarsInAFunc++-- |update all qualified names in program+updQNamesInAProg :: Update (AProg a) QName+updQNamesInAProg f = updAProg id id+ (map (updQNamesInType f)) (map (updQNamesInAFunc f)) (map (updOpName f))++-- |rename program (update name of and all qualified names in program)+rnmAProg :: String -> AProg a -> AProg a+rnmAProg name p = updAProgName (const name) (updQNamesInAProg rnm p)+ where+ rnm (m, n) | m == aProgName p = (name, n)+ | otherwise = (m, n)++-- AFuncDecl ------------------------------------------------------------------++-- |transform function+trAFunc :: (QName -> Int -> Visibility -> TypeExpr -> ARule a -> b) -> AFuncDecl a -> b+trAFunc func (AFunc name arity vis t rule) = func name arity vis t rule++-- Selectors++-- |get name of function+aFuncName :: AFuncDecl a -> QName+aFuncName = trAFunc (\name _ _ _ _ -> name)++-- |get arity of function+aFuncArity :: AFuncDecl a -> Int+aFuncArity = trAFunc (\_ arity _ _ _ -> arity)++-- |get visibility of function+aFuncVisibility :: AFuncDecl a -> Visibility+aFuncVisibility = trAFunc (\_ _ vis _ _ -> vis)++-- |get type of function+aFuncType :: AFuncDecl a -> TypeExpr+aFuncType = trAFunc (\_ _ _ t _ -> t)++-- |get rule of function+aFuncARule :: AFuncDecl a -> ARule a+aFuncARule = trAFunc (\_ _ _ _ rule -> rule)++-- Update Operations++-- |update function+updAFunc :: (QName -> QName) ->+ (Int -> Int) ->+ (Visibility -> Visibility) ->+ (TypeExpr -> TypeExpr) ->+ (ARule a -> ARule a) -> AFuncDecl a -> AFuncDecl a+updAFunc fn fa fv ft fr = trAFunc func+ where+ func name arity vis t rule+ = AFunc (fn name) (fa arity) (fv vis) (ft t) (fr rule)++-- |update name of function+updAFuncName :: Update (AFuncDecl a) QName+updAFuncName f = updAFunc f id id id id++-- |update arity of function+updAFuncArity :: Update (AFuncDecl a) Int+updAFuncArity f = updAFunc id f id id id++-- |update visibility of function+updAFuncVisibility :: Update (AFuncDecl a) Visibility+updAFuncVisibility f = updAFunc id id f id id++-- |update type of function+updFuncType :: Update (AFuncDecl a) TypeExpr+updFuncType f = updAFunc id id id f id++-- |update rule of function+updAFuncARule :: Update (AFuncDecl a) (ARule a)+updAFuncARule = updAFunc id id id id++-- Auxiliary Functions++-- |is function public?+isPublicAFunc :: AFuncDecl a -> Bool+isPublicAFunc = isPublic . aFuncVisibility++-- |is function externally defined?+isExternal :: AFuncDecl a -> Bool+isExternal = isARuleExternal . aFuncARule++-- |get variable names in a function declaration+allVarsInAFunc :: AFuncDecl a -> [(VarIndex, a)]+allVarsInAFunc = allVarsInARule . aFuncARule++-- |get arguments of function, if not externally defined+aFuncArgs :: AFuncDecl a -> [(VarIndex, a)]+aFuncArgs = aRuleArgs . aFuncARule++-- |get body of function, if not externally defined+aFuncBody :: AFuncDecl a -> AExpr a+aFuncBody = aRuleBody . aFuncARule++-- |get the right-hand-sides of a 'FuncDecl'+aFuncRHS :: AFuncDecl a -> [AExpr a]+aFuncRHS f | not (isExternal f) = orCase (aFuncBody f)+ | otherwise = []+ where+ orCase e+ | isAOr e = concatMap orCase (orExps e)+ | isACase e = concatMap orCase (map aBranchAExpr (caseBranches e))+ | otherwise = [e]++-- |rename all variables in function+rnmAllVarsInAFunc :: Update (AFuncDecl a) VarIndex+rnmAllVarsInAFunc = updAFunc id id id id . rnmAllVarsInARule++-- |update all qualified names in function+updQNamesInAFunc :: Update (AFuncDecl a) QName+updQNamesInAFunc f = updAFunc f id id (updQNamesInTypeExpr f) (updQNamesInARule f)++-- |update arguments of function, if not externally defined+updAFuncArgs :: Update (AFuncDecl a) [(VarIndex, a)]+updAFuncArgs = updAFuncARule . updARuleArgs++-- |update body of function, if not externally defined+updAFuncBody :: Update (AFuncDecl a) (AExpr a)+updAFuncBody = updAFuncARule . updARuleBody++-- ARule ----------------------------------------------------------------------++-- |transform rule+trARule :: (a -> [(VarIndex, a)] -> AExpr a -> b) -> (a -> String -> b) -> ARule a -> b+trARule rule _ (ARule a args e) = rule a args e+trARule _ ext (AExternal a s) = ext a s++-- Selectors++-- |get rules annotation+aRuleAnnot :: ARule a -> a+aRuleAnnot = trARule (\a _ _ -> a) (\a _ -> a)++-- |get rules arguments if it's not external+aRuleArgs :: ARule a -> [(VarIndex, a)]+aRuleArgs = trARule (\_ args _ -> args) undefined++-- |get rules body if it's not external+aRuleBody :: ARule a -> AExpr a+aRuleBody = trARule (\_ _ e -> e) undefined++-- |get rules external declaration+aRuleExtDecl :: ARule a -> String+aRuleExtDecl = trARule undefined (\_ s -> s)++-- Test Operations++-- |is rule external?+isARuleExternal :: ARule a -> Bool+isARuleExternal = trARule (\_ _ _ -> False) (\_ _ -> True)++-- Update Operations++-- |update rule+updARule :: (a -> b) ->+ ([(VarIndex, a)] -> [(VarIndex, b)]) ->+ (AExpr a -> AExpr b) ->+ (String -> String) -> ARule a -> ARule b+updARule fannot fa fe fs = trARule rule ext+ where+ rule a args e = ARule (fannot a) (fa args) (fe e)+ ext a s = AExternal (fannot a) (fs s)++-- |update rules annotation+updARuleAnnot :: Update (ARule a) a+updARuleAnnot f = updARule f id id id++-- |update rules arguments+updARuleArgs :: Update (ARule a) [(VarIndex, a)]+updARuleArgs f = updARule id f id id++-- |update rules body+updARuleBody :: Update (ARule a) (AExpr a)+updARuleBody f = updARule id id f id++-- |update rules external declaration+updARuleExtDecl :: Update (ARule a) String+updARuleExtDecl f = updARule id id id f++-- Auxiliary Functions++-- |get variable names in a functions rule+allVarsInARule :: ARule a -> [(VarIndex, a)]+allVarsInARule = trARule (\_ args body -> args ++ allVars body) (\_ _ -> [])++-- |rename all variables in rule+rnmAllVarsInARule :: Update (ARule a) VarIndex+rnmAllVarsInARule f = updARule id (map (\(a, b) -> (f a, b))) (rnmAllVars f) id++-- |update all qualified names in rule+updQNamesInARule :: Update (ARule a) QName+updQNamesInARule = updARuleBody . updQNames++-- AExpr ----------------------------------------------------------------------++-- Selectors++-- |get annoation of an expression+annot :: AExpr a -> a+annot (AVar a _ ) = a+annot (ALit a _ ) = a+annot (AComb a _ _ _) = a+annot (ALet a _ _ ) = a+annot (AFree a _ _ ) = a+annot (AOr a _ _ ) = a+annot (ACase a _ _ _) = a+annot (ATyped a _ _ ) = a++-- |get internal number of variable+varNr :: AExpr a -> VarIndex+varNr (AVar _ n) = n+varNr _ = error "Curry.FlatCurry.Annotated.Goodies.varNr: no variable"++-- |get literal if expression is literal expression+literal :: AExpr a -> Literal+literal (ALit _ l) = l+literal _ = error "Curry.FlatCurry.Annotated.Goodies.literal: no literal"++-- |get combination type of a combined expression+combType :: AExpr a -> CombType+combType (AComb _ ct _ _) = ct+combType _ = error $ "Curry.FlatCurry.Annotated.Goodies.combType: " +++ "no combined expression"++-- |get name of a combined expression+combName :: AExpr a -> (QName, a)+combName (AComb _ _ name _) = name+combName _ = error $ "Curry.FlatCurry.Annotated.Goodies.combName: " +++ "no combined expression"++-- |get arguments of a combined expression+combArgs :: AExpr a -> [AExpr a]+combArgs (AComb _ _ _ args) = args+combArgs _ = error $ "Curry.FlatCurry.Annotated.Goodies.combArgs: " +++ "no combined expression"++-- |get number of missing arguments if expression is combined+missingCombArgs :: AExpr a -> Int+missingCombArgs = missingArgs . combType+ where+ missingArgs :: CombType -> Int+ missingArgs = trCombType 0 id 0 id++-- |get indices of varoables in let declaration+letBinds :: AExpr a -> [((VarIndex, a), AExpr a)]+letBinds (ALet _ vs _) = vs+letBinds _ = error $ "Curry.FlatCurry.Annotated.Goodies.letBinds: " +++ "no let expression"++-- |get body of let declaration+letBody :: AExpr a -> AExpr a+letBody (ALet _ _ e) = e+letBody _ = error $ "Curry.FlatCurry.Annotated.Goodies.letBody: " +++ "no let expression"++-- |get variable indices from declaration of free variables+freeVars :: AExpr a -> [(VarIndex, a)]+freeVars (AFree _ vs _) = vs+freeVars _ = error $ "Curry.FlatCurry.Annotated.Goodies.freeVars: " +++ "no declaration of free variables"++-- |get expression from declaration of free variables+freeExpr :: AExpr a -> AExpr a+freeExpr (AFree _ _ e) = e+freeExpr _ = error $ "Curry.FlatCurry.Annotated.Goodies.freeExpr: " +++ "no declaration of free variables"++-- |get expressions from or-expression+orExps :: AExpr a -> [AExpr a]+orExps (AOr _ e1 e2) = [e1, e2]+orExps _ = error $ "Curry.FlatCurry.Annotated.Goodies.orExps: " +++ "no or expression"++-- |get case-type of case expression+caseType :: AExpr a -> CaseType+caseType (ACase _ ct _ _) = ct+caseType _ = error $ "Curry.FlatCurry.Annotated.Goodies.caseType: " +++ "no case expression"++-- |get scrutinee of case expression+caseExpr :: AExpr a -> AExpr a+caseExpr (ACase _ _ e _) = e+caseExpr _ = error $ "Curry.FlatCurry.Annotated.Goodies.caseExpr: " +++ "no case expression"+++-- |get branch expressions from case expression+caseBranches :: AExpr a -> [ABranchExpr a]+caseBranches (ACase _ _ _ bs) = bs+caseBranches _ = error+ "Curry.FlatCurry.Annotated.Goodies.caseBranches: no case expression"++-- Test Operations++-- |is expression a variable?+isAVar :: AExpr a -> Bool+isAVar e = case e of+ AVar _ _ -> True+ _ -> False++-- |is expression a literal expression?+isALit :: AExpr a -> Bool+isALit e = case e of+ ALit _ _ -> True+ _ -> False++-- |is expression combined?+isAComb :: AExpr a -> Bool+isAComb e = case e of+ AComb _ _ _ _ -> True+ _ -> False++-- |is expression a let expression?+isALet :: AExpr a -> Bool+isALet e = case e of+ ALet _ _ _ -> True+ _ -> False++-- |is expression a declaration of free variables?+isAFree :: AExpr a -> Bool+isAFree e = case e of+ AFree _ _ _ -> True+ _ -> False++-- |is expression an or-expression?+isAOr :: AExpr a -> Bool+isAOr e = case e of+ AOr _ _ _ -> True+ _ -> False++-- |is expression a case expression?+isACase :: AExpr a -> Bool+isACase e = case e of+ ACase _ _ _ _ -> True+ _ -> False++-- |transform expression+trAExpr :: (a -> VarIndex -> b)+ -> (a -> Literal -> b)+ -> (a -> CombType -> (QName, a) -> [b] -> b)+ -> (a -> [((VarIndex, a), b)] -> b -> b)+ -> (a -> [(VarIndex, a)] -> b -> b)+ -> (a -> b -> b -> b)+ -> (a -> CaseType -> b -> [c] -> b)+ -> (APattern a -> b -> c)+ -> (a -> b -> TypeExpr -> b)+ -> AExpr a+ -> b+trAExpr var lit comb lt fr oR cas branch typed expr = case expr of+ AVar a n -> var a n+ ALit a l -> lit a l+ AComb a ct name args -> comb a ct name (map f args)+ ALet a bs e -> lt a (map (\(v, x) -> (v, f x)) bs) (f e)+ AFree a vs e -> fr a vs (f e)+ AOr a e1 e2 -> oR a (f e1) (f e2)+ ACase a ct e bs -> cas a ct (f e) (map (\ (ABranch p e') -> branch p (f e')) bs)+ ATyped a e ty -> typed a (f e) ty+ where+ f = trAExpr var lit comb lt fr oR cas branch typed++-- |update all variables in given expression+updVars :: (a -> VarIndex -> AExpr a) -> AExpr a -> AExpr a+updVars var = trAExpr var ALit AComb ALet AFree AOr ACase ABranch ATyped++-- |update all literals in given expression+updLiterals :: (a -> Literal -> AExpr a) -> AExpr a -> AExpr a+updLiterals lit = trAExpr AVar lit AComb ALet AFree AOr ACase ABranch ATyped++-- |update all combined expressions in given expression+updCombs :: (a -> CombType -> (QName, a) -> [AExpr a] -> AExpr a) -> AExpr a -> AExpr a+updCombs comb = trAExpr AVar ALit comb ALet AFree AOr ACase ABranch ATyped++-- |update all let expressions in given expression+updLets :: (a -> [((VarIndex, a), AExpr a)] -> AExpr a -> AExpr a) -> AExpr a -> AExpr a+updLets lt = trAExpr AVar ALit AComb lt AFree AOr ACase ABranch ATyped++-- |update all free declarations in given expression+updFrees :: (a -> [(VarIndex, a)] -> AExpr a -> AExpr a) -> AExpr a -> AExpr a+updFrees fr = trAExpr AVar ALit AComb ALet fr AOr ACase ABranch ATyped++-- |update all or expressions in given expression+updOrs :: (a -> AExpr a -> AExpr a -> AExpr a) -> AExpr a -> AExpr a+updOrs oR = trAExpr AVar ALit AComb ALet AFree oR ACase ABranch ATyped++-- |update all case expressions in given expression+updCases :: (a -> CaseType -> AExpr a -> [ABranchExpr a] -> AExpr a) -> AExpr a -> AExpr a+updCases cas = trAExpr AVar ALit AComb ALet AFree AOr cas ABranch ATyped++-- |update all case branches in given expression+updBranches :: (APattern a -> AExpr a -> ABranchExpr a) -> AExpr a -> AExpr a+updBranches branch = trAExpr AVar ALit AComb ALet AFree AOr ACase branch ATyped++-- |update all typed expressions in given expression+updTypeds :: (a -> AExpr a -> TypeExpr -> AExpr a) -> AExpr a -> AExpr a+updTypeds = trAExpr AVar ALit AComb ALet AFree AOr ACase ABranch++-- Auxiliary Functions++-- |is expression a call of a function where all arguments are provided?+isFuncCall :: AExpr a -> Bool+isFuncCall e = isAComb e && isCombTypeFuncCall (combType e)++-- |is expression a partial function call?+isFuncPartCall :: AExpr a -> Bool+isFuncPartCall e = isAComb e && isCombTypeFuncPartCall (combType e)++-- |is expression a call of a constructor?+isConsCall :: AExpr a -> Bool+isConsCall e = isAComb e && isCombTypeConsCall (combType e)++-- |is expression a partial constructor call?+isConsPartCall :: AExpr a -> Bool+isConsPartCall e = isAComb e && isCombTypeConsPartCall (combType e)++-- |is expression fully evaluated?+isGround :: AExpr a -> Bool+isGround e+ = case e of+ AComb _ ConsCall _ args -> all isGround args+ _ -> isALit e++-- |get all variables (also pattern variables) in expression+allVars :: AExpr a -> [(VarIndex, a)]+allVars e = trAExpr var lit comb lt fr (const (.)) cas branch typ e []+ where+ var a v = (:) (v, a)+ lit = const (const id)+ comb _ _ _ = foldr (.) id+ lt _ bs e' = e' . foldr (.) id (map (\(n,ns) -> (n:) . ns) bs)+ fr _ vs e' = (vs++) . e'+ cas _ _ e' bs = e' . foldr (.) id bs+ branch pat e' = ((args pat)++) . e'+ typ _ = const+ args pat | isConsPattern pat = aPatArgs pat+ | otherwise = []++-- |rename all variables (also in patterns) in expression+rnmAllVars :: Update (AExpr a) VarIndex+rnmAllVars f = trAExpr var ALit AComb lt fr AOr ACase branch ATyped+ where+ var a = AVar a . f+ lt a = ALet a . map (\((n, b), e) -> ((f n, b), e))+ fr a = AFree a . map (\(b, c) -> (f b, c))+ branch = ABranch . updAPatArgs (map (\(a, b) -> (f a, b)))++-- |update all qualified names in expression+updQNames :: Update (AExpr a) QName+updQNames f = trAExpr AVar ALit comb ALet AFree AOr ACase branch ATyped+ where+ comb a ct (name, a') args = AComb a ct (f name, a') args+ branch = ABranch . updAPatCons (\(q, a) -> (f q, a))++-- ABranchExpr ----------------------------------------------------------------++-- |transform branch expression+trABranch :: (APattern a -> AExpr a -> b) -> ABranchExpr a -> b+trABranch branch (ABranch pat e) = branch pat e++-- Selectors++-- |get pattern from branch expression+aBranchAPattern :: ABranchExpr a -> APattern a+aBranchAPattern = trABranch (\pat _ -> pat)++-- |get expression from branch expression+aBranchAExpr :: ABranchExpr a -> AExpr a+aBranchAExpr = trABranch (\_ e -> e)++-- Update Operations++-- |update branch expression+updABranch :: (APattern a -> APattern a) -> (AExpr a -> AExpr a) -> ABranchExpr a -> ABranchExpr a+updABranch fp fe = trABranch branch+ where+ branch pat e = ABranch (fp pat) (fe e)++-- |update pattern of branch expression+updABranchAPattern :: Update (ABranchExpr a) (APattern a)+updABranchAPattern f = updABranch f id++-- |update expression of branch expression+updABranchAExpr :: Update (ABranchExpr a) (AExpr a)+updABranchAExpr = updABranch id++-- APattern -------------------------------------------------------------------++-- |transform pattern+trAPattern :: (a -> (QName, a) -> [(VarIndex, a)] -> b) -> (a -> Literal -> b) -> APattern a -> b+trAPattern pat _ (APattern a name args) = pat a name args+trAPattern _ lpat (ALPattern a l) = lpat a l++-- Selectors++-- |get annotation from pattern+aPatAnnot :: APattern a -> a+aPatAnnot = trAPattern (\a _ _ -> a) (\a _ -> a)++-- |get name from constructor pattern+aPatCons :: APattern a -> (QName, a)+aPatCons = trAPattern (\_ name _ -> name) undefined++-- |get arguments from constructor pattern+aPatArgs :: APattern a -> [(VarIndex, a)]+aPatArgs = trAPattern (\_ _ args -> args) undefined++-- |get literal from literal pattern+aPatLiteral :: APattern a -> Literal+aPatLiteral = trAPattern undefined (const id)++-- Test Operations++-- |is pattern a constructor pattern?+isConsPattern :: APattern a -> Bool+isConsPattern = trAPattern (\_ _ _ -> True) (\_ _ -> False)++-- Update Operations++-- |update pattern+updAPattern :: (a -> a) ->+ ((QName, a) -> (QName, a)) ->+ ([(VarIndex, a)] -> [(VarIndex, a)]) ->+ (Literal -> Literal) -> APattern a -> APattern a+updAPattern fannot fn fa fl = trAPattern pat lpat+ where+ pat a name args = APattern (fannot a) (fn name) (fa args)+ lpat a l = ALPattern (fannot a) (fl l)++-- |update annotation of pattern+updAPatAnnot :: (a -> a) -> APattern a -> APattern a+updAPatAnnot f = updAPattern f id id id++-- |update constructors name of pattern+updAPatCons :: ((QName, a) -> (QName, a)) -> APattern a -> APattern a+updAPatCons f = updAPattern id f id id++-- |update arguments of constructor pattern+updAPatArgs :: ([(VarIndex, a)] -> [(VarIndex, a)]) -> APattern a -> APattern a+updAPatArgs f = updAPattern id id f id++-- |update literal of pattern+updAPatLiteral :: (Literal -> Literal) -> APattern a -> APattern a+updAPatLiteral f = updAPattern id id id f++-- Auxiliary Functions++-- |build expression from pattern+aPatExpr :: APattern a -> AExpr a+aPatExpr = trAPattern (\a name -> AComb a ConsCall name . map (uncurry (flip AVar))) ALit
+ src/Curry/FlatCurry/Annotated/Type.hs view
@@ -0,0 +1,132 @@+{- |+ Module : $Header$+ Description : Representation of annotated FlatCurry.+ Copyright : (c) 2016 - 2017 Finn Teegen+ License : BSD-3-clause++ Maintainer : fte@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ TODO+-}++module Curry.FlatCurry.Annotated.Type+ ( module Curry.FlatCurry.Annotated.Type+ , module Curry.FlatCurry.Typeable+ , module Curry.FlatCurry.Type+ ) where++import Data.Binary+import Control.Monad++import Curry.FlatCurry.Typeable+import Curry.FlatCurry.Type ( QName, VarIndex, Visibility (..), TVarIndex+ , TypeDecl (..), Kind (..), OpDecl (..), Fixity (..)+ , TypeExpr (..), ConsDecl (..), NewConsDecl (..)+ , Literal (..), CombType (..), CaseType (..)+ )++data AProg a = AProg String [String] [TypeDecl] [AFuncDecl a] [OpDecl]+ deriving (Eq, Read, Show)++data AFuncDecl a = AFunc QName Int Visibility TypeExpr (ARule a)+ deriving (Eq, Read, Show)++data ARule a+ = ARule a [(VarIndex, a)] (AExpr a)+ | AExternal a String+ deriving (Eq, Read, Show)++data AExpr a+ = AVar a VarIndex+ | ALit a Literal+ | AComb a CombType (QName, a) [AExpr a]+ | ALet a [((VarIndex, a), AExpr a)] (AExpr a)+ | AFree a [(VarIndex, a)] (AExpr a)+ | AOr a (AExpr a) (AExpr a)+ | ACase a CaseType (AExpr a) [ABranchExpr a]+ | ATyped a (AExpr a) TypeExpr+ deriving (Eq, Read, Show)++data ABranchExpr a = ABranch (APattern a) (AExpr a)+ deriving (Eq, Read, Show)++data APattern a+ = APattern a (QName, a) [(VarIndex, a)]+ | ALPattern a Literal+ deriving (Eq, Read, Show)++instance Typeable a => Typeable (AExpr a) where+ typeOf (AVar a _) = typeOf a+ typeOf (ALit a _) = typeOf a+ typeOf (AComb a _ _ _) = typeOf a+ typeOf (ALet a _ _) = typeOf a+ typeOf (AFree a _ _) = typeOf a+ typeOf (AOr a _ _) = typeOf a+ typeOf (ACase a _ _ _) = typeOf a+ typeOf (ATyped a _ _) = typeOf a++instance Typeable a => Typeable (APattern a) where+ typeOf (APattern a _ _) = typeOf a+ typeOf (ALPattern a _) = typeOf a++instance Binary a => Binary (AProg a) where+ put (AProg mid im tys fus ops) =+ put mid >> put im >> put tys >> put fus >> put ops+ get = AProg <$> get <*> get <*> get <*> get <*> get++instance Binary a => Binary (AFuncDecl a) where+ put (AFunc qid arity vis ty r) =+ put qid >> put arity >> put vis >> put ty >> put r+ get = AFunc <$> get <*> get <*> get <*> get <*> get++instance Binary a => Binary (ARule a) where+ put (ARule a alts e) = putWord8 0 >> put a >> put alts >> put e+ put (AExternal ty n ) = putWord8 1 >> put ty >> put n++ get = do+ x <- getWord8+ case x of+ 0 -> liftM3 ARule get get get+ 1 -> liftM2 AExternal get get+ _ -> fail "Invalid encoding for TRule"++instance Binary a => Binary (AExpr a) where+ put (AVar a v) = putWord8 0 >> put a >> put v+ put (ALit a l) = putWord8 1 >> put a >> put l+ put (AComb a cty qid es) =+ putWord8 2 >> put a >> put cty >> put qid >> put es+ put (ALet a bs e ) = putWord8 3 >> put a >> put bs >> put e+ put (AFree a vs e ) = putWord8 4 >> put a >> put vs >> put e+ put (AOr a e1 e2) = putWord8 5 >> put a >> put e1 >> put e2+ put (ACase a cty ty as) = putWord8 6 >> put a >> put cty >> put ty >> put as+ put (ATyped a e ty) = putWord8 7 >> put a >> put e >> put ty++ get = do+ x <- getWord8+ case x of+ 0 -> liftM2 AVar get get+ 1 -> liftM2 ALit get get+ 2 -> liftM4 AComb get get get get+ 3 -> liftM3 ALet get get get+ 4 -> liftM3 AFree get get get+ 5 -> liftM3 AOr get get get+ 6 -> liftM4 ACase get get get get+ 7 -> liftM3 ATyped get get get+ _ -> fail "Invalid encoding for TExpr"++instance Binary a => Binary (ABranchExpr a) where+ put (ABranch p e) = put p >> put e+ get = liftM2 ABranch get get++instance Binary a => Binary (APattern a) where+ put (APattern a qid vs) = putWord8 0 >> put a >> put qid >> put vs+ put (ALPattern a l ) = putWord8 1 >> put a >> put l++ get = do+ x <- getWord8+ case x of+ 0 -> liftM3 APattern get get get+ 1 -> liftM2 ALPattern get get+ _ -> fail "Invalid encoding for TPattern"
+ src/Curry/FlatCurry/Files.hs view
@@ -0,0 +1,68 @@+{- |+ Module : $Header$+ Description : Functions for reading and writing FlatCurry files+ Copyright : (c) 2014 Björn Peemöller+ 2017 Finn Teegen+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This module contains functions for reading and writing FlatCurry files.+-}++module Curry.FlatCurry.Files+ ( readTypedFlatCurry, readFlatCurry, readFlatInterface+ , writeFlatCurry, writeBinaryFlatCurry+ ) where++import Data.Binary (Binary, encode)+import Data.Char (isSpace)++import Curry.Files.Filenames (typedFlatName, flatName, flatIntName)+import Curry.Files.PathUtils (writeModule, writeBinaryModule, readModule)++import Curry.FlatCurry.Type (Prog)+import Curry.FlatCurry.Annotated.Type (AProg, TypeExpr)+++-- ---------------------------------------------------------------------------+-- Functions for reading and writing FlatCurry terms+-- ---------------------------------------------------------------------------++-- |Reads an typed FlatCurry file (extension ".tfcy") and eventually+-- returns the corresponding FlatCurry program term (type 'AProg').+readTypedFlatCurry :: FilePath -> IO (Maybe (AProg TypeExpr))+readTypedFlatCurry = readFlat . typedFlatName++-- |Reads a FlatCurry file (extension ".fcy") and eventually returns the+-- corresponding FlatCurry program term (type 'Prog').+readFlatCurry :: FilePath -> IO (Maybe Prog)+readFlatCurry = readFlat . flatName++-- |Reads a FlatInterface file (extension @.fint@) and returns the+-- corresponding term (type 'Prog') as a value of type 'Maybe'.+readFlatInterface :: FilePath -> IO (Maybe Prog)+readFlatInterface = readFlat . flatIntName++-- |Reads a Flat file and returns the corresponding term (type 'Prog' or+-- 'AProg') as a value of type 'Maybe'.+-- Due to compatibility with PAKCS it is allowed to have a commentary+-- at the beginning of the file enclosed in {- ... -}.+readFlat :: Read a => FilePath -> IO (Maybe a)+readFlat = fmap (fmap (read . skipComment)) . readModule where+ skipComment s = case dropWhile isSpace s of+ '{' : '-' : s' -> dropComment s'+ s' -> s'+ dropComment ('-' : '}' : xs) = xs+ dropComment (_ : xs) = dropComment xs+ dropComment [] = []++-- |Writes a FlatCurry program term into a file.+writeFlatCurry :: Show a => FilePath -> a -> IO ()+writeFlatCurry fn = writeModule fn . show++-- |Writes a FlatCurry program term into a normal and a binary file.+writeBinaryFlatCurry :: Binary a => FilePath -> a -> IO ()+writeBinaryFlatCurry fn = writeBinaryModule fn . encode
+ src/Curry/FlatCurry/Goodies.hs view
@@ -0,0 +1,1037 @@+{- |+ Module : $Header$+ Description : Utility functions for working with FlatCurry.+ Copyright : (c) Sebastian Fischer 2006+ Björn Peemöller 2011+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This library provides selector functions, test and update operations+ as well as some useful auxiliary functions for FlatCurry data terms.+ Most of the provided functions are based on general transformation+ functions that replace constructors with user-defined functions. For+ recursive datatypes the transformations are defined inductively over the+ term structure. This is quite usual for transformations on FlatCurry+ terms, so the provided functions can be used to implement specific+ transformations without having to explicitly state the recursion.+ Essentially, the tedious part of such transformations - descend in fairly+ complex term structures - is abstracted away, which hopefully makes the+ code more clear and brief.+-}++module Curry.FlatCurry.Goodies where++import Curry.FlatCurry.Type++-- |Update of a type's component+type Update a b = (b -> b) -> a -> a++-- Prog ----------------------------------------------------------------------++-- |transform program+trProg :: (String -> [String] -> [TypeDecl] -> [FuncDecl] -> [OpDecl] -> a)+ -> Prog -> a+trProg prog (Prog name imps types funcs ops) = prog name imps types funcs ops++-- Selectors++-- |get name from program+progName :: Prog -> String+progName = trProg (\name _ _ _ _ -> name)++-- |get imports from program+progImports :: Prog -> [String]+progImports = trProg (\_ imps _ _ _ -> imps)++-- |get type declarations from program+progTypes :: Prog -> [TypeDecl]+progTypes = trProg (\_ _ types _ _ -> types)++-- |get functions from program+progFuncs :: Prog -> [FuncDecl]+progFuncs = trProg (\_ _ _ funcs _ -> funcs)++-- |get infix operators from program+progOps :: Prog -> [OpDecl]+progOps = trProg (\_ _ _ _ ops -> ops)++-- Update Operations++-- |update program+updProg :: (String -> String) ->+ ([String] -> [String]) ->+ ([TypeDecl] -> [TypeDecl]) ->+ ([FuncDecl] -> [FuncDecl]) ->+ ([OpDecl] -> [OpDecl]) -> Prog -> Prog+updProg fn fi ft ff fo = trProg prog+ where+ prog name imps types funcs ops+ = Prog (fn name) (fi imps) (ft types) (ff funcs) (fo ops)++-- |update name of program+updProgName :: Update Prog String+updProgName f = updProg f id id id id++-- |update imports of program+updProgImports :: Update Prog [String]+updProgImports f = updProg id f id id id++-- |update type declarations of program+updProgTypes :: Update Prog [TypeDecl]+updProgTypes f = updProg id id f id id++-- |update functions of program+updProgFuncs :: Update Prog [FuncDecl]+updProgFuncs f = updProg id id id f id++-- |update infix operators of program+updProgOps :: Update Prog [OpDecl]+updProgOps = updProg id id id id++-- Auxiliary Functions++-- |get all program variables (also from patterns)+allVarsInProg :: Prog -> [VarIndex]+allVarsInProg = concatMap allVarsInFunc . progFuncs++-- |lift transformation on expressions to program+updProgExps :: Update Prog Expr+updProgExps = updProgFuncs . map . updFuncBody++-- |rename programs variables+rnmAllVarsInProg :: Update Prog VarIndex+rnmAllVarsInProg = updProgFuncs . map . rnmAllVarsInFunc++-- |update all qualified names in program+updQNamesInProg :: Update Prog QName+updQNamesInProg f = updProg id id+ (map (updQNamesInType f)) (map (updQNamesInFunc f)) (map (updOpName f))++-- |rename program (update name of and all qualified names in program)+rnmProg :: String -> Prog -> Prog+rnmProg name p = updProgName (const name) (updQNamesInProg rnm p)+ where+ rnm (m,n) | m==progName p = (name,n)+ | otherwise = (m,n)++-- TypeDecl ------------------------------------------------------------------++-- Selectors++-- |transform type declaration+trType :: (QName -> Visibility -> [TVarWithKind] -> [ConsDecl] -> a) ->+ (QName -> Visibility -> [TVarWithKind] -> TypeExpr -> a) ->+ (QName -> Visibility -> [TVarWithKind] -> NewConsDecl -> a) -> TypeDecl -> a+trType typ _ _ (Type name vis params cs) = typ name vis params cs+trType _ typesyn _ (TypeSyn name vis params syn) = typesyn name vis params syn+trType _ _ newtyp (TypeNew name vis params nc) = newtyp name vis params nc++-- |get name of type declaration+typeName :: TypeDecl -> QName+typeName = trType (\name _ _ _ -> name) (\name _ _ _ -> name) (\name _ _ _ -> name)++-- |get visibility of type declaration+typeVisibility :: TypeDecl -> Visibility+typeVisibility = trType (\_ vis _ _ -> vis) (\_ vis _ _ -> vis) (\_ vis _ _ -> vis)++-- |get type parameters of type declaration+typeParams :: TypeDecl -> [TVarWithKind]+typeParams = trType (\_ _ params _ -> params) (\_ _ params _ -> params) (\_ _ params _ -> params)++-- |get constructor declarations from type declaration+typeConsDecls :: TypeDecl -> [ConsDecl]+typeConsDecls = trType (\_ _ _ cs -> cs)+ (error "Curry.FlatCurry.Goodies: type synonym")+ (error "Curry.FlatCurry.Goodies: newtype")++-- |get synonym of type declaration+typeSyn :: TypeDecl -> TypeExpr+typeSyn = trType undefined (\_ _ _ syn -> syn) undefined++-- |is type declaration a type synonym?+isTypeSyn :: TypeDecl -> Bool+isTypeSyn = trType (\_ _ _ _ -> False) (\_ _ _ _ -> True) (\_ _ _ _ -> False)++-- | is type declaration declaring a regular type?+isDataTypeDecl :: TypeDecl -> Bool+isDataTypeDecl = trType (\_ _ _ cs -> not (null cs)) (\_ _ _ _ -> False) (\_ _ _ _ -> False)++-- | is type declaration declaring an external type?+isExternalType :: TypeDecl -> Bool+isExternalType = trType (\_ _ _ cs -> null cs) (\_ _ _ _ -> False) (\_ _ _ _ -> False)++-- |is type declaration a newtype?+isNewtype :: TypeDecl -> Bool+isNewtype = trType (\_ _ _ _ -> False) (\_ _ _ _ -> False) (\_ _ _ _ -> False)++-- |Is the 'TypeDecl' public?+isPublicType :: TypeDecl -> Bool+isPublicType = (== Public) . typeVisibility++-- Update Operations++-- |update type declaration+updType :: (QName -> QName) ->+ (Visibility -> Visibility) ->+ ([TVarWithKind] -> [TVarWithKind]) ->+ ([ConsDecl] -> [ConsDecl]) ->+ (NewConsDecl -> NewConsDecl) ->+ (TypeExpr -> TypeExpr) -> TypeDecl -> TypeDecl+updType fn fv fp fc fnc fs = trType typ typesyn newtyp+ where+ typ name vis params cs = Type (fn name) (fv vis) (fp params) (fc cs)+ newtyp name vis params nc = TypeNew (fn name) (fv vis) (fp params) (fnc nc)+ typesyn name vis params syn = TypeSyn (fn name) (fv vis) (fp params) (fs syn)++-- |update name of type declaration+updTypeName :: Update TypeDecl QName+updTypeName f = updType f id id id id id++-- |update visibility of type declaration+updTypeVisibility :: Update TypeDecl Visibility+updTypeVisibility f = updType id f id id id id++-- |update type parameters of type declaration+updTypeParams :: Update TypeDecl [TVarWithKind]+updTypeParams f = updType id id f id id id++-- |update constructor declarations of type declaration+updTypeConsDecls :: Update TypeDecl [ConsDecl]+updTypeConsDecls f = updType id id id f id id++-- |update constructor declarations of newtype declaration+updTypeNewConsDecls :: Update TypeDecl NewConsDecl+updTypeNewConsDecls f = updType id id id id f id++-- |update synonym of type declaration+updTypeSynonym :: Update TypeDecl TypeExpr+updTypeSynonym = updType id id id id id++-- Auxiliary Functions++-- |update all qualified names in type declaration+updQNamesInType :: Update TypeDecl QName+updQNamesInType f+ = updType f id id (map (updQNamesInConsDecl f)) (updQNamesInNewConsDecl f)+ (updQNamesInTypeExpr f)++-- ConsDecl ------------------------------------------------------------------++-- Selectors++-- |transform constructor declaration+trCons :: (QName -> Int -> Visibility -> [TypeExpr] -> a) -> ConsDecl -> a+trCons cons (Cons name arity vis args) = cons name arity vis args++-- |get name of constructor declaration+consName :: ConsDecl -> QName+consName = trCons (\name _ _ _ -> name)++-- |get arity of constructor declaration+consArity :: ConsDecl -> Int+consArity = trCons (\_ arity _ _ -> arity)++-- |get visibility of constructor declaration+consVisibility :: ConsDecl -> Visibility+consVisibility = trCons (\_ _ vis _ -> vis)++-- |Is the constructor declaration public?+isPublicCons :: ConsDecl -> Bool+isPublicCons = isPublic . consVisibility++-- |get arguments of constructor declaration+consArgs :: ConsDecl -> [TypeExpr]+consArgs = trCons (\_ _ _ args -> args)++-- Update Operations++-- |update constructor declaration+updCons :: (QName -> QName) ->+ (Int -> Int) ->+ (Visibility -> Visibility) ->+ ([TypeExpr] -> [TypeExpr]) -> ConsDecl -> ConsDecl+updCons fn fa fv fas = trCons cons+ where+ cons name arity vis args = Cons (fn name) (fa arity) (fv vis) (fas args)++-- |update name of constructor declaration+updConsName :: Update ConsDecl QName+updConsName f = updCons f id id id++-- |update arity of constructor declaration+updConsArity :: Update ConsDecl Int+updConsArity f = updCons id f id id++-- |update visibility of constructor declaration+updConsVisibility :: Update ConsDecl Visibility+updConsVisibility f = updCons id id f id++-- |update arguments of constructor declaration+updConsArgs :: Update ConsDecl [TypeExpr]+updConsArgs = updCons id id id++-- Auxiliary Functions++-- |update all qualified names in constructor declaration+updQNamesInConsDecl :: Update ConsDecl QName+updQNamesInConsDecl f = updCons f id id (map (updQNamesInTypeExpr f))+++-- NewConsDecl ------------------------------------------------------------------++-- Selectors++-- |transform newtype constructor declaration+trNewCons :: (QName -> Visibility -> TypeExpr -> a) -> NewConsDecl -> a+trNewCons cons (NewCons name vis arg) = cons name vis arg++-- |get name of new constructor declaration+newConsName :: NewConsDecl -> QName+newConsName = trNewCons (\name _ _ -> name)++-- |get visibility of new constructor declaration+newConsVisibility :: NewConsDecl -> Visibility+newConsVisibility = trNewCons (\_ vis _ -> vis)++-- |Is the new constructor declaration public?+isPublicNewCons :: ConsDecl -> Bool+isPublicNewCons = isPublic . consVisibility++-- |get argument of new constructor declaration+newConsArg :: NewConsDecl -> TypeExpr+newConsArg = trNewCons (\_ _ arg -> arg)++-- Update Operations++-- |update new constructor declaration+updNewCons :: (QName -> QName) ->+ (Visibility -> Visibility) ->+ (TypeExpr -> TypeExpr) -> NewConsDecl -> NewConsDecl+updNewCons fn fv fas = trNewCons cons+ where+ cons name vis args = NewCons (fn name) (fv vis) (fas args)++-- |update name of new constructor declaration+updNewConsName :: Update NewConsDecl QName+updNewConsName f = updNewCons f id id++-- |update visibility of new constructor declaration+updNewConsVisibility :: Update NewConsDecl Visibility+updNewConsVisibility f = updNewCons id f id++-- |update argument of new constructor declaration+updNewConsArg :: Update NewConsDecl TypeExpr+updNewConsArg = updNewCons id id++-- Auxiliary Functions++-- |update all qualified names in new constructor declaration+updQNamesInNewConsDecl :: Update NewConsDecl QName+updQNamesInNewConsDecl f = updNewCons f id (updQNamesInTypeExpr f)++-- TypeExpr ------------------------------------------------------------------++-- Selectors++-- |get index from type variable+tVarIndex :: TypeExpr -> TVarIndex+tVarIndex (TVar n) = n+tVarIndex _ = error $ "Curry.FlatCurry.Goodies.tvarIndex: " +++ "no type variable"++-- |get domain from functional type+domain :: TypeExpr -> TypeExpr+domain (FuncType dom _) = dom+domain _ = error $ "Curry.FlatCurry.Goodies.domain: " +++ "no function type"++-- |get range from functional type+range :: TypeExpr -> TypeExpr+range (FuncType _ ran) = ran+range _ = error $ "Curry.FlatCurry.Goodies.range: " +++ "no function type"++-- |get name from constructed type+tConsName :: TypeExpr -> QName+tConsName (TCons name _) = name+tConsName _ = error $ "Curry.FlatCurry.Goodies.tConsName: " +++ "no constructor type"++-- |get arguments from constructed type+tConsArgs :: TypeExpr -> [TypeExpr]+tConsArgs (TCons _ args) = args+tConsArgs _ = error $ "Curry.FlatCurry.Goodies.tConsArgs: " +++ "no constructor type"++-- |transform type expression+trTypeExpr :: (TVarIndex -> a) ->+ (QName -> [a] -> a) ->+ (a -> a -> a) ->+ ([TVarWithKind] -> a -> a) -> TypeExpr -> a+trTypeExpr tvar _ _ _ (TVar t) = tvar t+trTypeExpr tvar tcons functype foralltype (TCons name args)+ = tcons name (map (trTypeExpr tvar tcons functype foralltype) args)+trTypeExpr tvar tcons functype foralltype (FuncType from to)+ = functype (f from) (f to)+ where+ f = trTypeExpr tvar tcons functype foralltype+trTypeExpr tvar tcons functype foralltype (ForallType ns t)+ = foralltype ns (trTypeExpr tvar tcons functype foralltype t)++-- Test Operations++-- |is type expression a type variable?+isTVar :: TypeExpr -> Bool+isTVar = trTypeExpr (\_ -> True) (\_ _ -> False) (\_ _ -> False) (\_ _ -> False)++-- |is type declaration a constructed type?+isTCons :: TypeExpr -> Bool+isTCons+ = trTypeExpr (\_ -> False) (\_ _ -> True) (\_ _ -> False) (\_ _ -> False)++-- |is type declaration a functional type?+isFuncType :: TypeExpr -> Bool+isFuncType+ = trTypeExpr (\_ -> False) (\_ _ -> False) (\_ _ -> True) (\_ _ -> False)++-- |is type declaration a forall type?+isForallType :: TypeExpr -> Bool+isForallType+ = trTypeExpr (\_ -> False) (\_ _ -> False) (\_ _ -> False) (\_ _ -> True)++-- Update Operations++-- |update all type variables+updTVars :: (TVarIndex -> TypeExpr) -> TypeExpr -> TypeExpr+updTVars tvar = trTypeExpr tvar TCons FuncType ForallType++-- |update all type constructors+updTCons :: (QName -> [TypeExpr] -> TypeExpr) -> TypeExpr -> TypeExpr+updTCons tcons = trTypeExpr TVar tcons FuncType ForallType++-- |update all functional types+updFuncTypes :: (TypeExpr -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr+updFuncTypes functype = trTypeExpr TVar TCons functype ForallType++-- |update all forall types+updForallTypes :: ([TVarWithKind] -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr+updForallTypes = trTypeExpr TVar TCons FuncType++-- Auxiliary Functions++-- |get argument types from functional type+argTypes :: TypeExpr -> [TypeExpr]+argTypes (TVar _) = []+argTypes (TCons _ _) = []+argTypes (FuncType dom ran) = dom : argTypes ran+argTypes (ForallType _ _) = []++-- |Compute the arity of a 'TypeExpr'+typeArity :: TypeExpr -> Int+typeArity = length . argTypes++-- |get result type from (nested) functional type+resultType :: TypeExpr -> TypeExpr+resultType (TVar n) = TVar n+resultType (TCons name args) = TCons name args+resultType (FuncType _ ran) = resultType ran+resultType (ForallType ns t) = ForallType ns t++-- |get indexes of all type variables+allVarsInTypeExpr :: TypeExpr -> [TVarIndex]+allVarsInTypeExpr = trTypeExpr pure (const concat) (++) ((++) . map fst)++-- |yield the list of all contained type constructors+allTypeCons :: TypeExpr -> [QName]+allTypeCons (TVar _) = []+allTypeCons (TCons name args) = name : concatMap allTypeCons args+allTypeCons (FuncType t1 t2) = allTypeCons t1 ++ allTypeCons t2+allTypeCons (ForallType _ t) = allTypeCons t++-- |rename variables in type expression+rnmAllVarsInTypeExpr :: (TVarIndex -> TVarIndex) -> TypeExpr -> TypeExpr+rnmAllVarsInTypeExpr f = updTVars (TVar . f)++-- |update all qualified names in type expression+updQNamesInTypeExpr :: (QName -> QName) -> TypeExpr -> TypeExpr+updQNamesInTypeExpr f = updTCons (\name args -> TCons (f name) args)++-- OpDecl --------------------------------------------------------------------++-- |transform operator declaration+trOp :: (QName -> Fixity -> Integer -> a) -> OpDecl -> a+trOp op (Op name fix prec) = op name fix prec++-- Selectors++-- |get name from operator declaration+opName :: OpDecl -> QName+opName = trOp (\name _ _ -> name)++-- |get fixity of operator declaration+opFixity :: OpDecl -> Fixity+opFixity = trOp (\_ fix _ -> fix)++-- |get precedence of operator declaration+opPrecedence :: OpDecl -> Integer+opPrecedence = trOp (\_ _ prec -> prec)++-- Update Operations++-- |update operator declaration+updOp :: (QName -> QName) ->+ (Fixity -> Fixity) ->+ (Integer -> Integer) -> OpDecl -> OpDecl+updOp fn ff fp = trOp op+ where op name fix prec = Op (fn name) (ff fix) (fp prec)++-- |update name of operator declaration+updOpName :: Update OpDecl QName+updOpName f = updOp f id id++-- |update fixity of operator declaration+updOpFixity :: Update OpDecl Fixity+updOpFixity f = updOp id f id++-- |update precedence of operator declaration+updOpPrecedence :: Update OpDecl Integer+updOpPrecedence = updOp id id++-- FuncDecl ------------------------------------------------------------------++-- |transform function+trFunc :: (QName -> Int -> Visibility -> TypeExpr -> Rule -> a) -> FuncDecl -> a+trFunc func (Func name arity vis t rule) = func name arity vis t rule++-- Selectors++-- |get name of function+funcName :: FuncDecl -> QName+funcName = trFunc (\name _ _ _ _ -> name)++-- |get arity of function+funcArity :: FuncDecl -> Int+funcArity = trFunc (\_ arity _ _ _ -> arity)++-- |get visibility of function+funcVisibility :: FuncDecl -> Visibility+funcVisibility = trFunc (\_ _ vis _ _ -> vis)++-- |get type of function+funcType :: FuncDecl -> TypeExpr+funcType = trFunc (\_ _ _ t _ -> t)++-- |get rule of function+funcRule :: FuncDecl -> Rule+funcRule = trFunc (\_ _ _ _ rule -> rule)++-- Update Operations++-- |update function+updFunc :: (QName -> QName) ->+ (Int -> Int) ->+ (Visibility -> Visibility) ->+ (TypeExpr -> TypeExpr) ->+ (Rule -> Rule) -> FuncDecl -> FuncDecl+updFunc fn fa fv ft fr = trFunc func+ where+ func name arity vis t rule+ = Func (fn name) (fa arity) (fv vis) (ft t) (fr rule)++-- |update name of function+updFuncName :: Update FuncDecl QName+updFuncName f = updFunc f id id id id++-- |update arity of function+updFuncArity :: Update FuncDecl Int+updFuncArity f = updFunc id f id id id++-- |update visibility of function+updFuncVisibility :: Update FuncDecl Visibility+updFuncVisibility f = updFunc id id f id id++-- |update type of function+updFuncType :: Update FuncDecl TypeExpr+updFuncType f = updFunc id id id f id++-- |update rule of function+updFuncRule :: Update FuncDecl Rule+updFuncRule = updFunc id id id id++-- Auxiliary Functions++-- |is function public?+isPublicFunc :: FuncDecl -> Bool+isPublicFunc = isPublic . funcVisibility++-- |is function externally defined?+isExternal :: FuncDecl -> Bool+isExternal = isRuleExternal . funcRule++-- |get variable names in a function declaration+allVarsInFunc :: FuncDecl -> [VarIndex]+allVarsInFunc = allVarsInRule . funcRule++-- |get arguments of function, if not externally defined+funcArgs :: FuncDecl -> [VarIndex]+funcArgs = ruleArgs . funcRule++-- |get body of function, if not externally defined+funcBody :: FuncDecl -> Expr+funcBody = ruleBody . funcRule++-- |get the right-hand-sides of a 'FuncDecl'+funcRHS :: FuncDecl -> [Expr]+funcRHS f | not (isExternal f) = orCase (funcBody f)+ | otherwise = []+ where+ orCase e+ | isOr e = concatMap orCase (orExps e)+ | isCase e = concatMap orCase (map branchExpr (caseBranches e))+ | otherwise = [e]++-- |rename all variables in function+rnmAllVarsInFunc :: Update FuncDecl VarIndex+rnmAllVarsInFunc = updFunc id id id id . rnmAllVarsInRule++-- |update all qualified names in function+updQNamesInFunc :: Update FuncDecl QName+updQNamesInFunc f = updFunc f id id (updQNamesInTypeExpr f) (updQNamesInRule f)++-- |update arguments of function, if not externally defined+updFuncArgs :: Update FuncDecl [VarIndex]+updFuncArgs = updFuncRule . updRuleArgs++-- |update body of function, if not externally defined+updFuncBody :: Update FuncDecl Expr+updFuncBody = updFuncRule . updRuleBody++-- Rule ----------------------------------------------------------------------++-- |transform rule+trRule :: ([VarIndex] -> Expr -> a) -> (String -> a) -> Rule -> a+trRule rule _ (Rule args e) = rule args e+trRule _ ext (External s) = ext s++-- Selectors++-- |get rules arguments if it's not external+ruleArgs :: Rule -> [VarIndex]+ruleArgs = trRule (\args _ -> args) undefined++-- |get rules body if it's not external+ruleBody :: Rule -> Expr+ruleBody = trRule (\_ e -> e) undefined++-- |get rules external declaration+ruleExtDecl :: Rule -> String+ruleExtDecl = trRule undefined id++-- Test Operations++-- |is rule external?+isRuleExternal :: Rule -> Bool+isRuleExternal = trRule (\_ _ -> False) (\_ -> True)++-- Update Operations++-- |update rule+updRule :: ([VarIndex] -> [VarIndex]) ->+ (Expr -> Expr) ->+ (String -> String) -> Rule -> Rule+updRule fa fe fs = trRule rule ext+ where+ rule args e = Rule (fa args) (fe e)+ ext s = External (fs s)++-- |update rules arguments+updRuleArgs :: Update Rule [VarIndex]+updRuleArgs f = updRule f id id++-- |update rules body+updRuleBody :: Update Rule Expr+updRuleBody f = updRule id f id++-- |update rules external declaration+updRuleExtDecl :: Update Rule String+updRuleExtDecl f = updRule id id f++-- Auxiliary Functions++-- |get variable names in a functions rule+allVarsInRule :: Rule -> [VarIndex]+allVarsInRule = trRule (\args body -> args ++ allVars body) (\_ -> [])++-- |rename all variables in rule+rnmAllVarsInRule :: Update Rule VarIndex+rnmAllVarsInRule f = updRule (map f) (rnmAllVars f) id++-- |update all qualified names in rule+updQNamesInRule :: Update Rule QName+updQNamesInRule = updRuleBody . updQNames++-- CombType ------------------------------------------------------------------++-- |transform combination type+trCombType :: a -> (Int -> a) -> a -> (Int -> a) -> CombType -> a+trCombType fc _ _ _ FuncCall = fc+trCombType _ fpc _ _ (FuncPartCall n) = fpc n+trCombType _ _ cc _ ConsCall = cc+trCombType _ _ _ cpc (ConsPartCall n) = cpc n++-- Test Operations++-- |is type of combination FuncCall?+isCombTypeFuncCall :: CombType -> Bool+isCombTypeFuncCall = trCombType True (\_ -> False) False (\_ -> False)++-- |is type of combination FuncPartCall?+isCombTypeFuncPartCall :: CombType -> Bool+isCombTypeFuncPartCall = trCombType False (\_ -> True) False (\_ -> False)++-- |is type of combination ConsCall?+isCombTypeConsCall :: CombType -> Bool+isCombTypeConsCall = trCombType False (\_ -> False) True (\_ -> False)++-- |is type of combination ConsPartCall?+isCombTypeConsPartCall :: CombType -> Bool+isCombTypeConsPartCall = trCombType False (\_ -> False) False (\_ -> True)++-- Expr ----------------------------------------------------------------------++-- Selectors++-- |get internal number of variable+varNr :: Expr -> VarIndex+varNr (Var n) = n+varNr _ = error "Curry.FlatCurry.Goodies.varNr: no variable"++-- |get literal if expression is literal expression+literal :: Expr -> Literal+literal (Lit l) = l+literal _ = error "Curry.FlatCurry.Goodies.literal: no literal"++-- |get combination type of a combined expression+combType :: Expr -> CombType+combType (Comb ct _ _) = ct+combType _ = error $ "Curry.FlatCurry.Goodies.combType: " +++ "no combined expression"++-- |get name of a combined expression+combName :: Expr -> QName+combName (Comb _ name _) = name+combName _ = error $ "Curry.FlatCurry.Goodies.combName: " +++ "no combined expression"++-- |get arguments of a combined expression+combArgs :: Expr -> [Expr]+combArgs (Comb _ _ args) = args+combArgs _ = error $ "Curry.FlatCurry.Goodies.combArgs: " +++ "no combined expression"++-- |get number of missing arguments if expression is combined+missingCombArgs :: Expr -> Int+missingCombArgs = missingArgs . combType+ where+ missingArgs :: CombType -> Int+ missingArgs = trCombType 0 id 0 id++-- |get indices of varoables in let declaration+letBinds :: Expr -> [(VarIndex,Expr)]+letBinds (Let vs _) = vs+letBinds _ = error $ "Curry.FlatCurry.Goodies.letBinds: " +++ "no let expression"++-- |get body of let declaration+letBody :: Expr -> Expr+letBody (Let _ e) = e+letBody _ = error $ "Curry.FlatCurry.Goodies.letBody: " +++ "no let expression"++-- |get variable indices from declaration of free variables+freeVars :: Expr -> [VarIndex]+freeVars (Free vs _) = vs+freeVars _ = error $ "Curry.FlatCurry.Goodies.freeVars: " +++ "no declaration of free variables"++-- |get expression from declaration of free variables+freeExpr :: Expr -> Expr+freeExpr (Free _ e) = e+freeExpr _ = error $ "Curry.FlatCurry.Goodies.freeExpr: " +++ "no declaration of free variables"++-- |get expressions from or-expression+orExps :: Expr -> [Expr]+orExps (Or e1 e2) = [e1,e2]+orExps _ = error $ "Curry.FlatCurry.Goodies.orExps: " +++ "no or expression"++-- |get case-type of case expression+caseType :: Expr -> CaseType+caseType (Case ct _ _) = ct+caseType _ = error $ "Curry.FlatCurry.Goodies.caseType: " +++ "no case expression"++-- |get scrutinee of case expression+caseExpr :: Expr -> Expr+caseExpr (Case _ e _) = e+caseExpr _ = error $ "Curry.FlatCurry.Goodies.caseExpr: " +++ "no case expression"+++-- |get branch expressions from case expression+caseBranches :: Expr -> [BranchExpr]+caseBranches (Case _ _ bs) = bs+caseBranches _ = error+ "Curry.FlatCurry.Goodies.caseBranches: no case expression"++-- Test Operations++-- |is expression a variable?+isVar :: Expr -> Bool+isVar e = case e of+ Var _ -> True+ _ -> False++-- |is expression a literal expression?+isLit :: Expr -> Bool+isLit e = case e of+ Lit _ -> True+ _ -> False++-- |is expression combined?+isComb :: Expr -> Bool+isComb e = case e of+ Comb _ _ _ -> True+ _ -> False++-- |is expression a let expression?+isLet :: Expr -> Bool+isLet e = case e of+ Let _ _ -> True+ _ -> False++-- |is expression a declaration of free variables?+isFree :: Expr -> Bool+isFree e = case e of+ Free _ _ -> True+ _ -> False++-- |is expression an or-expression?+isOr :: Expr -> Bool+isOr e = case e of+ Or _ _ -> True+ _ -> False++-- |is expression a case expression?+isCase :: Expr -> Bool+isCase e = case e of+ Case _ _ _ -> True+ _ -> False++-- |transform expression+trExpr :: (VarIndex -> a)+ -> (Literal -> a)+ -> (CombType -> QName -> [a] -> a)+ -> ([(VarIndex, a)] -> a -> a)+ -> ([VarIndex] -> a -> a)+ -> (a -> a -> a)+ -> (CaseType -> a -> [b] -> a)+ -> (Pattern -> a -> b)+ -> (a -> TypeExpr -> a)+ -> Expr+ -> a+trExpr var lit comb lt fr oR cas branch typed expr = case expr of+ Var n -> var n+ Lit l -> lit l+ Comb ct name args -> comb ct name (map f args)+ Let bs e -> lt (map (\(v, x) -> (v, f x)) bs) (f e)+ Free vs e -> fr vs (f e)+ Or e1 e2 -> oR (f e1) (f e2)+ Case ct e bs -> cas ct (f e) (map (\ (Branch p e') -> branch p (f e')) bs)+ Typed e ty -> typed (f e) ty+ where+ f = trExpr var lit comb lt fr oR cas branch typed++-- Update Operations++-- |update all variables in given expression+updVars :: (VarIndex -> Expr) -> Expr -> Expr+updVars var = trExpr var Lit Comb Let Free Or Case Branch Typed++-- |update all literals in given expression+updLiterals :: (Literal -> Expr) -> Expr -> Expr+updLiterals lit = trExpr Var lit Comb Let Free Or Case Branch Typed++-- |update all combined expressions in given expression+updCombs :: (CombType -> QName -> [Expr] -> Expr) -> Expr -> Expr+updCombs comb = trExpr Var Lit comb Let Free Or Case Branch Typed++-- |update all let expressions in given expression+updLets :: ([(VarIndex,Expr)] -> Expr -> Expr) -> Expr -> Expr+updLets lt = trExpr Var Lit Comb lt Free Or Case Branch Typed++-- |update all free declarations in given expression+updFrees :: ([VarIndex] -> Expr -> Expr) -> Expr -> Expr+updFrees fr = trExpr Var Lit Comb Let fr Or Case Branch Typed++-- |update all or expressions in given expression+updOrs :: (Expr -> Expr -> Expr) -> Expr -> Expr+updOrs oR = trExpr Var Lit Comb Let Free oR Case Branch Typed++-- |update all case expressions in given expression+updCases :: (CaseType -> Expr -> [BranchExpr] -> Expr) -> Expr -> Expr+updCases cas = trExpr Var Lit Comb Let Free Or cas Branch Typed++-- |update all case branches in given expression+updBranches :: (Pattern -> Expr -> BranchExpr) -> Expr -> Expr+updBranches branch = trExpr Var Lit Comb Let Free Or Case branch Typed++-- |update all typed expressions in given expression+updTypeds :: (Expr -> TypeExpr -> Expr) -> Expr -> Expr+updTypeds = trExpr Var Lit Comb Let Free Or Case Branch++-- Auxiliary Functions++-- |is expression a call of a function where all arguments are provided?+isFuncCall :: Expr -> Bool+isFuncCall e = isComb e && isCombTypeFuncCall (combType e)++-- |is expression a partial function call?+isFuncPartCall :: Expr -> Bool+isFuncPartCall e = isComb e && isCombTypeFuncPartCall (combType e)++-- |is expression a call of a constructor?+isConsCall :: Expr -> Bool+isConsCall e = isComb e && isCombTypeConsCall (combType e)++-- |is expression a partial constructor call?+isConsPartCall :: Expr -> Bool+isConsPartCall e = isComb e && isCombTypeConsPartCall (combType e)++-- |is expression fully evaluated?+isGround :: Expr -> Bool+isGround e+ = case e of+ Comb ConsCall _ args -> all isGround args+ _ -> isLit e++-- |get all variables (also pattern variables) in expression+allVars :: Expr -> [VarIndex]+allVars e = trExpr (:) (const id) comb lt fr (.) cas branch const e []+ where+ comb _ _ = foldr (.) id+ lt bs e' = e' . foldr (.) id (map (\ (n,ns) -> (n:) . ns) bs)+ fr vs e' = (vs++) . e'+ cas _ e' bs = e' . foldr (.) id bs+ branch pat e' = ((args pat)++) . e'+ args pat | isConsPattern pat = patArgs pat+ | otherwise = []++-- |rename all variables (also in patterns) in expression+rnmAllVars :: Update Expr VarIndex+rnmAllVars f = trExpr (Var . f) Lit Comb lt (Free . map f) Or Case branch Typed+ where+ lt = Let . map (\ (n,e) -> (f n,e))+ branch = Branch . updPatArgs (map f)++-- |update all qualified names in expression+updQNames :: Update Expr QName+updQNames f = trExpr Var Lit comb Let Free Or Case (Branch . updPatCons f) Typed+ where+ comb ct name args = Comb ct (f name) args++-- BranchExpr ----------------------------------------------------------------++-- |transform branch expression+trBranch :: (Pattern -> Expr -> a) -> BranchExpr -> a+trBranch branch (Branch pat e) = branch pat e++-- Selectors++-- |get pattern from branch expression+branchPattern :: BranchExpr -> Pattern+branchPattern = trBranch (\pat _ -> pat)++-- |get expression from branch expression+branchExpr :: BranchExpr -> Expr+branchExpr = trBranch (\_ e -> e)++-- Update Operations++-- |update branch expression+updBranch :: (Pattern -> Pattern) -> (Expr -> Expr) -> BranchExpr -> BranchExpr+updBranch fp fe = trBranch branch+ where+ branch pat e = Branch (fp pat) (fe e)++-- |update pattern of branch expression+updBranchPattern :: Update BranchExpr Pattern+updBranchPattern f = updBranch f id++-- |update expression of branch expression+updBranchExpr :: Update BranchExpr Expr+updBranchExpr = updBranch id++-- Pattern -------------------------------------------------------------------++-- |transform pattern+trPattern :: (QName -> [VarIndex] -> a) -> (Literal -> a) -> Pattern -> a+trPattern pattern _ (Pattern name args) = pattern name args+trPattern _ lpattern (LPattern l) = lpattern l++-- Selectors++-- |get name from constructor pattern+patCons :: Pattern -> QName+patCons = trPattern (\name _ -> name) undefined++-- |get arguments from constructor pattern+patArgs :: Pattern -> [VarIndex]+patArgs = trPattern (\_ args -> args) undefined++-- |get literal from literal pattern+patLiteral :: Pattern -> Literal+patLiteral = trPattern undefined id++-- Test Operations++-- |is pattern a constructor pattern?+isConsPattern :: Pattern -> Bool+isConsPattern = trPattern (\_ _ -> True) (\_ -> False)++-- Update Operations++-- |update pattern+updPattern :: (QName -> QName) ->+ ([VarIndex] -> [VarIndex]) ->+ (Literal -> Literal) -> Pattern -> Pattern+updPattern fn fa fl = trPattern pattern lpattern+ where+ pattern name args = Pattern (fn name) (fa args)+ lpattern l = LPattern (fl l)++-- |update constructors name of pattern+updPatCons :: (QName -> QName) -> Pattern -> Pattern+updPatCons f = updPattern f id id++-- |update arguments of constructor pattern+updPatArgs :: ([VarIndex] -> [VarIndex]) -> Pattern -> Pattern+updPatArgs f = updPattern id f id++-- |update literal of pattern+updPatLiteral :: (Literal -> Literal) -> Pattern -> Pattern+updPatLiteral f = updPattern id id f++-- Auxiliary Functions++-- |build expression from pattern+patExpr :: Pattern -> Expr+patExpr = trPattern (\ name -> Comb ConsCall name . map Var) Lit++-- |Is this a public 'Visibility'?+isPublic :: Visibility -> Bool+isPublic = (== Public)
+ src/Curry/FlatCurry/InterfaceEquivalence.hs view
@@ -0,0 +1,58 @@+{- |+ Module : $Header$+ Description : Check the equality of two FlatCurry interfaces+ Copyright : (c) 2006 , Martin Engelke+ 2011 - 2014, Björn Peemöller+ 2014 , Jan Tikovsky+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable+-}++module Curry.FlatCurry.InterfaceEquivalence (eqInterface) where++import Data.List (deleteFirstsBy)++import Curry.FlatCurry.Type++infix 4 =~=, `eqvSet`++-- |Check whether the interfaces of two FlatCurry programs are equivalent.+eqInterface :: Prog -> Prog -> Bool+eqInterface = (=~=)++-- |Type class to express the equivalence of two values+class Equiv a where+ (=~=) :: a -> a -> Bool++instance Equiv a => Equiv [a] where+ [] =~= [] = True+ (x:xs) =~= (y:ys) = x =~= y && xs =~= ys+ _ =~= _ = False++instance Equiv Char where (=~=) = (==)++-- |Equivalence of lists independent of the order.+eqvSet :: Equiv a => [a] -> [a] -> Bool+xs `eqvSet` ys = null (deleteFirstsBy (=~=) xs ys ++ deleteFirstsBy (=~=) ys xs)++instance Equiv Prog where+ Prog m1 is1 ts1 fs1 os1 =~= Prog m2 is2 ts2 fs2 os2+ = m1 == m2 && is1 `eqvSet` is2 && ts1 `eqvSet` ts2+ && fs1 `eqvSet` fs2 && os1 `eqvSet` os2++instance Equiv TypeDecl where (=~=) = (==)++instance Equiv FuncDecl where+ Func qn1 ar1 vis1 ty1 r1 =~= Func qn2 ar2 vis2 ty2 r2+ = qn1 == qn2 && ar1 == ar2 && vis1 == vis2 && ty1 == ty2 && r1 =~= r2++-- TODO: Check why arguments of rules are not checked for equivalence+instance Equiv Rule where+ Rule _ _ =~= Rule _ _ = True+ External _ =~= External _ = True+ _ =~= _ = False++instance Equiv OpDecl where (=~=) = (==)
+ src/Curry/FlatCurry/Pretty.hs view
@@ -0,0 +1,217 @@+{- |+ Module : $Header$+ Description : A pretty printer for FlatCurry+ Copyright : (c) 2015 Björn Peemöller+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This module implements a pretty printer for FlatCurry modules.+-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Curry.FlatCurry.Pretty (pPrint, pPrintPrec) where++import Prelude hiding ((<>))+import Data.Char (ord)++import Curry.Base.Pretty+import Curry.FlatCurry.Type++instance Pretty Prog where+ pPrint (Prog m is ts fs os) = sepByBlankLine+ [ ppHeader m ts fs+ , vcat (map ppImport is)+ , vcat (map pPrint os)+ , sepByBlankLine (map pPrint ts)+ , sepByBlankLine (map pPrint fs)+ ]++ppHeader :: String -> [TypeDecl] -> [FuncDecl] -> Doc+ppHeader m ts fs = sep+ [text "module" <+> text m, ppExports ts fs, text "where"]++-- |pretty-print the export list+ppExports :: [TypeDecl] -> [FuncDecl] -> Doc+ppExports ts fs = parens $ list (map ppTypeExport ts ++ ppFuncExports fs)++ppTypeExport :: TypeDecl -> Doc+ppTypeExport (Type qn vis _ cs)+ | vis == Private = empty+ | all isPublicCons cs = ppPrefixOp qn <+> text "(..)"+ | otherwise = ppPrefixOp qn <+> parens (list (ppConsExports cs))+ where isPublicCons (Cons _ _ v _) = v == Public+ppTypeExport (TypeNew qn vis _ nc)+ | vis == Private = empty+ | isPublicCons nc = ppPrefixOp qn <+> text "(..)"+ | otherwise = ppPrefixOp qn <+> parens empty+ where isPublicCons (NewCons _ v _) = v == Public+ppTypeExport (TypeSyn qn vis _ _ )+ | vis == Private = empty+ | otherwise = ppPrefixOp qn++-- |pretty-print the export list of constructors+ppConsExports :: [ConsDecl] -> [Doc]+ppConsExports cs = [ ppPrefixOp qn | Cons qn _ Public _ <- cs]++-- |pretty-print the export list of functions+ppFuncExports :: [FuncDecl] -> [Doc]+ppFuncExports fs = [ ppPrefixOp qn | Func qn _ Public _ _ <- fs]++-- |pretty-print an import statement+ppImport :: String -> Doc+ppImport m = text "import" <+> text m++instance Pretty OpDecl where+ pPrint(Op qn fix n) = pPrint fix <+> integer n <+> ppInfixOp qn++instance Pretty Fixity where+ pPrint InfixOp = text "infix"+ pPrint InfixlOp = text "infixl"+ pPrint InfixrOp = text "infixr"++instance Pretty TypeDecl where+ pPrint (Type qn _ vs cs) = text "data" <+> ppQName qn+ <+> hsep (ppTVarIndex <$> fst <$> vs) $+$ ppConsDecls cs+ pPrint (TypeSyn qn _ vs ty) = text "type" <+> ppQName qn+ <+> hsep (ppTVarIndex <$> fst <$> vs) <+> equals <+> pPrintPrec 0 ty+ pPrint (TypeNew qn _ vs nc) = text "newtype" <+> ppQName qn+ <+> hsep (ppTVarIndex <$> fst <$> vs) <+> equals <+> pPrint nc++-- |pretty-print the constructor declarations+ppConsDecls :: [ConsDecl] -> Doc+ppConsDecls cs = indent $ vcat $+ zipWith (<+>) (equals : repeat (char '|')) (map pPrint cs)++instance Pretty ConsDecl where+ pPrint (Cons qn _ _ tys) = fsep $ ppPrefixOp qn : map (pPrintPrec 2) tys++instance Pretty NewConsDecl where+ pPrint (NewCons qn _ ty) = fsep [pPrint qn, pPrintPrec 2 ty]++instance Pretty TypeExpr where+ pPrintPrec _ (TVar i) = ppTVarIndex i+ pPrintPrec p (FuncType ty1 ty2) = parenIf (p > 0) $ fsep+ [pPrintPrec 1 ty1, rarrow, pPrintPrec 0 ty2]+ pPrintPrec p (TCons qn tys) = parenIf (p > 1 && not (null tys)) $ fsep+ (ppPrefixOp qn : map (pPrintPrec 2) tys)+ pPrintPrec p (ForallType vs ty)+ | null vs = pPrintPrec p ty+ | otherwise = parenIf (p > 0) $ ppQuantifiedVars vs <+> pPrintPrec 0 ty++-- |pretty-print explicitly quantified type variables (without kinds)+ppQuantifiedVars :: [(TVarIndex, Kind)] -> Doc+ppQuantifiedVars vs+ | null vs = empty+ | otherwise = text "forall" <+> hsep (map ppTVar vs) <> char '.'++ppTVar :: (TVarIndex, Kind) -> Doc+ppTVar (i, _) = ppTVarIndex i++-- |pretty-print a type variable+ppTVarIndex :: TVarIndex -> Doc+ppTVarIndex i = text $ vars !! i+ where vars = [ if n == 0 then [c] else c : show n+ | n <- [0 :: Int ..], c <- ['a' .. 'z']+ ]++instance Pretty FuncDecl where+ pPrint (Func qn _ _ ty r)+ = hsep [ppPrefixOp qn, text "::", pPrintPrec 0 ty]+ $+$ ppPrefixOp qn <+> pPrint r++instance Pretty Rule where+ pPrint (Rule vs e) =+ fsep (map ppVarIndex vs) <+> equals <+> indent (pPrintPrec 0 e)+ pPrint (External _) = text "external"++instance Pretty Expr where+ pPrintPrec _ (Var v) = ppVarIndex v+ pPrintPrec _ (Lit l) = pPrint l+ pPrintPrec p (Comb _ qn es) = ppComb p qn es+ pPrintPrec p (Free vs e)+ | null vs = pPrintPrec p e+ | otherwise = parenIf (p > 0) $ sep+ [ text "let" <+> list (map ppVarIndex vs)+ <+> text "free"+ , text "in" <+> pPrintPrec 0 e+ ]+ pPrintPrec p (Let ds e) = parenIf (p > 0) $+ sep [text "let" <+> ppDecls ds, text "in" <+> pPrintPrec 0 e]+ pPrintPrec p (Or e1 e2) = parenIf (p > 0) $+ pPrintPrec 1 e1 <+> text "?" <+> pPrintPrec 1 e2+ pPrintPrec p (Case ct e bs) = parenIf (p > 0) $+ pPrint ct <+> pPrintPrec 0 e <+> text "of" $$ indent (vcat (map pPrint bs))+ pPrintPrec p (Typed e ty) = parenIf (p > 0) $+ pPrintPrec 0 e <+> text "::" <+> pPrintPrec 0 ty++-- |pretty-print a variable+ppVarIndex :: VarIndex -> Doc+ppVarIndex i = text $ 'v' : show i++instance Pretty Literal where+ pPrint (Intc i) = integer i+ pPrint (Floatc f) = double f+ pPrint (Charc c) = text (showEscape c)++-- |Escape character literal+showEscape :: Char -> String+showEscape c+ | o < 10 = "'\\00" ++ show o ++ "'"+ | o < 32 = "'\\0" ++ show o ++ "'"+ | o == 127 = "'\\127'"+ | otherwise = show c+ where o = ord c++-- |Pretty print a constructor or function call+ppComb :: Int -> QName -> [Expr] -> Doc+ppComb _ qn [] = ppPrefixOp qn+ppComb p qn [e1,e2]+ | isInfixOp qn = parenIf (p > 0)+ $ hsep [pPrintPrec 1 e1, pPrint qn, pPrintPrec 1 e2]+ppComb p qn es = parenIf (p > 0)+ $ hsep (ppPrefixOp qn : map (pPrintPrec 1) es)++-- |pretty-print a list of declarations+ppDecls :: [(VarIndex, Expr)] -> Doc+ppDecls = vcat . map ppDecl++-- |pretty-print a single declaration+ppDecl :: (VarIndex, Expr) -> Doc+ppDecl (v, e) = ppVarIndex v <+> equals <+> pPrintPrec 0 e++instance Pretty CaseType where+ pPrint Rigid = text "case"+ pPrint Flex = text "fcase"++instance Pretty BranchExpr where+ pPrint (Branch p e) = pPrint p <+> rarrow <+> pPrintPrec 0 e++instance Pretty Pattern where+ pPrint (Pattern c [v1,v2])+ | isInfixOp c = ppVarIndex v1 <+> ppInfixOp c <+> ppVarIndex v2+ pPrint (Pattern c vs) = fsep (ppPrefixOp c : map ppVarIndex vs)+ pPrint (LPattern l) = pPrint l++-- Names++-- |pretty-print a prefix operator+ppPrefixOp :: QName -> Doc+ppPrefixOp qn = parenIf (isInfixOp qn) (ppQName qn)++-- |pretty-print a name in infix manner+ppInfixOp :: QName -> Doc+ppInfixOp qn = if isInfixOp qn then ppQName qn else bquotes (ppQName qn)++-- |pretty-print a qualified name+ppQName :: QName -> Doc+ppQName (m, i) = text $ m ++ '.' : i++-- |Check whether an operator is an infix operator+isInfixOp :: QName -> Bool+isInfixOp = all (`elem` "~!@#$%^&*+-=<>:?./|\\") . snd++-- Indentation+indent :: Doc -> Doc+indent = nest 2
+ src/Curry/FlatCurry/Type.hs view
@@ -0,0 +1,521 @@+{- |+ Module : $Header$+ Description : Representation of FlatCurry.+ Copyright : (c) Michael Hanus 2003+ Martin Engelke 2004+ Bernd Brassel 2005+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This module contains a definition for representing FlatCurry programs+ in Haskell in type 'Prog'.+-}++module Curry.FlatCurry.Type+ ( -- * Representation of qualified names and (type) variables+ QName, VarIndex, TVarIndex, TVarWithKind+ -- * Data types for FlatCurry+ , Visibility (..), Prog (..), TypeDecl (..), TypeExpr (..), Kind (..)+ , ConsDecl (..), NewConsDecl(..), OpDecl (..), Fixity (..)+ , FuncDecl (..), Rule (..), Expr (..), Literal (..)+ , CombType (..), CaseType (..), BranchExpr (..), Pattern (..)+ ) where++import Data.Binary+import Control.Monad++-- ---------------------------------------------------------------------------+-- Qualified names+-- ---------------------------------------------------------------------------++-- |Qualified names.+--+-- In FlatCurry all names are qualified to avoid name clashes.+-- The first component is the module name and the second component the+-- unqualified name as it occurs in the source program.+type QName = (String, String)++-- ---------------------------------------------------------------------------+-- Variable representation+-- ---------------------------------------------------------------------------++-- |Representation of variables.+type VarIndex = Int++-- ---------------------------------------------------------------------------+-- FlatCurry representation+-- ---------------------------------------------------------------------------++-- |Visibility of various entities.+data Visibility+ = Public -- ^ public (exported) entity+ | Private -- ^ private entity+ deriving (Eq, Read, Show)++-- |A FlatCurry module.+--+-- A value of this data type has the form+--+-- @Prog modname imports typedecls functions opdecls@+--+-- where+--+-- [@modname@] Name of this module+-- [@imports@] List of modules names that are imported+-- [@typedecls@] Type declarations+-- [@funcdecls@] Function declarations+-- [@ opdecls@] Operator declarations+data Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl]+ deriving (Eq, Read, Show)++-- |Declaration of algebraic data type or type synonym.+--+-- A data type declaration of the form+--+-- @data t x1...xn = ...| c t1....tkc |...@+--+-- is represented by the FlatCurry term+--+-- @Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...]@+--+-- where each @ij@ is the index of the type variable @xj@+--+-- /Note:/ The type variable indices are unique inside each type declaration+-- and are usually numbered from 0.+--+-- Thus, a data type declaration consists of the name of the data type,+-- a list of type parameters and a list of constructor declarations.+data TypeDecl+ = Type QName Visibility [TVarWithKind] [ConsDecl]+ | TypeSyn QName Visibility [TVarWithKind] TypeExpr+ | TypeNew QName Visibility [TVarWithKind] NewConsDecl+ deriving (Eq, Read, Show)++-- |Type variables are represented by @(TVar i)@ where @i@ is a+-- type variable index.+type TVarIndex = Int++-- |Kinded type variables are represented by a tuple of type variable+-- index and kind.+type TVarWithKind = (TVarIndex, Kind)++-- |A constructor declaration consists of the name and arity of the+-- constructor and a list of the argument types of the constructor.+data ConsDecl = Cons QName Int Visibility [TypeExpr]+ deriving (Eq, Read, Show)++-- |A constructor declaration for a newtype consists+-- of the name of the constructor+-- and the argument type of the constructor.+data NewConsDecl = NewCons QName Visibility TypeExpr+ deriving (Eq, Read, Show)++-- |Type expressions.+--+-- A type expression is either a type variable, a function type,+-- or a type constructor application.+--+-- /Note:/ the names of the predefined type constructors are+-- @Int@, @Float@, @Bool@, @Char@, @IO@, @Success@,+-- @()@ (unit type), @(,...,)@ (tuple types), @[]@ (list type)+data TypeExpr+ = TVar TVarIndex -- ^ type variable+ | FuncType TypeExpr TypeExpr -- ^ function type @t1 -> t2@+ | TCons QName [TypeExpr] -- ^ type constructor application+ | ForallType [TVarWithKind] TypeExpr -- ^ forall type+ deriving (Eq, Read, Show)++-- |Kinds.+--+-- A kind is either * or k_1 -> k_2 where k_1 and k_2 are kinds.+data Kind+ = KStar -- ^ star kind+ | KArrow Kind Kind -- ^ arrow kind+ deriving (Eq, Ord, Read, Show)+ +-- |Operator declarations.+--+-- An operator declaration @fix p n@ in Curry corresponds to the+-- FlatCurry term @(Op n fix p)@.+--+-- /Note:/ the constructor definition of 'Op' differs from the original+-- PAKCS definition using Haskell type 'Integer' instead of 'Int'+-- for representing the precedence.+data OpDecl = Op QName Fixity Integer+ deriving (Eq, Read, Show)++-- |Fixity of an operator.+data Fixity+ = InfixOp -- ^ non-associative infix operator+ | InfixlOp -- ^ left-associative infix operator+ | InfixrOp -- ^ right-associative infix operator+ deriving (Eq, Read, Show)++-- |Data type for representing function declarations.+--+-- A function declaration in FlatCurry is a term of the form+--+-- @(Func name arity type (Rule [i_1,...,i_arity] e))@+--+-- and represents the function "name" with definition+--+-- @+-- name :: type+-- name x_1...x_arity = e+-- @+--+-- where each @i_j@ is the index of the variable @x_j@+--+-- /Note:/ The variable indices are unique inside each function declaration+-- and are usually numbered from 0.+--+-- External functions are represented as+--+-- @Func name arity type (External s)@+--+-- where s is the external name associated to this function.+--+-- Thus, a function declaration consists of the name, arity, type, and rule.+data FuncDecl = Func QName Int Visibility TypeExpr Rule+ deriving (Eq, Read, Show)++-- |A rule is either a list of formal parameters together with an expression+-- or an 'External' tag.+data Rule+ = Rule [VarIndex] Expr+ | External String+ deriving (Eq, Read, Show)++-- |Data type for representing expressions.+--+-- Remarks:+--+-- 1.if-then-else expressions are represented as function calls:+--+-- @(if e1 then e2 else e3)@+--+-- is represented as+--+-- @(Comb FuncCall ("Prelude","ifThenElse") [e1,e2,e3])@+--+-- 2.Higher order applications are represented as calls to the (external)+-- function @apply@. For instance, the rule+--+-- @app f x = f x@+--+-- is represented as+--+-- @(Rule [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1]))@+--+-- 3.A conditional rule is represented as a call to an external function+-- @cond@ where the first argument is the condition (a constraint).+--+-- For instance, the rule+--+-- @equal2 x | x=:=2 = success@+--+-- is represented as+--+-- @+-- (Rule [0]+-- (Comb FuncCall ("Prelude","cond")+-- [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)],+-- Comb FuncCall ("Prelude","success") []]))+-- @+--+-- 4.Functions with evaluation annotation @choice@ are represented+-- by a rule whose right-hand side is enclosed in a call to the+-- external function @Prelude.commit@.+-- Furthermore, all rules of the original definition must be+-- represented by conditional expressions (i.e., (cond [c,e]))+-- after pattern matching.+--+-- Example:+--+-- @+-- m eval choice+-- m [] y = y+-- m x [] = x+-- @+--+-- is translated into (note that the conditional branches can be also+-- wrapped with Free declarations in general):+--+-- @+-- Rule [0,1]+-- (Comb FuncCall ("Prelude","commit")+-- [Or (Case Rigid (Var 0)+-- [(Pattern ("Prelude","[]") []+-- (Comb FuncCall ("Prelude","cond")+-- [Comb FuncCall ("Prelude","success") [],+-- Var 1]))] )+-- (Case Rigid (Var 1)+-- [(Pattern ("Prelude","[]") []+-- (Comb FuncCall ("Prelude","cond")+-- [Comb FuncCall ("Prelude","success") [],+-- Var 0]))] )])+-- @+--+-- Operational meaning of @(Prelude.commit e)@:+-- evaluate @e@ with local search spaces and commit to the first+-- @(Comb FuncCall ("Prelude","cond") [c,ge])@ in @e@ whose constraint @c@+-- is satisfied+data Expr+ -- |Variable, represented by unique index+ = Var VarIndex+ -- |Literal (Integer/Float/Char constant)+ | Lit Literal+ -- |Application @(f e1 ... en)@ of function/constructor @f@+ -- with @n <= arity f@+ | Comb CombType QName [Expr]+ -- |Introduction of free local variables for an expression+ | Free [VarIndex] Expr+ -- |Local let-declarations+ | Let [(VarIndex, Expr)] Expr+ -- |Disjunction of two expressions+ -- (resulting from overlapping left-hand sides)+ | Or Expr Expr+ -- |case expression+ | Case CaseType Expr [BranchExpr]+ -- |typed expression+ | Typed Expr TypeExpr+ deriving (Eq, Read, Show)++-- |Data type for representing literals.+--+-- A literal is either an integer, a float, or a character constant.+--+-- /Note:/ The constructor definition of 'Intc' differs from the original+-- PAKCS definition. It uses Haskell type 'Integer' instead of 'Int'+-- to provide an unlimited range of integer numbers. Furthermore,+-- float values are represented with Haskell type 'Double' instead of+-- 'Float'.+data Literal+ = Intc Integer+ | Floatc Double+ | Charc Char+ deriving (Eq, Read, Show)++-- |Data type for classifying combinations+-- (i.e., a function/constructor applied to some arguments).+data CombType+ -- |a call to a function where all arguments are provided+ = FuncCall+ -- |a call with a constructor at the top, all arguments are provided+ | ConsCall+ -- |a partial call to a function (i.e., not all arguments are provided)+ -- where the parameter is the number of missing arguments+ | FuncPartCall Int+ -- |a partial call to a constructor along with number of missing arguments+ | ConsPartCall Int+ deriving (Eq, Read, Show)++-- |Classification of case expressions, either flexible or rigid.+data CaseType+ = Rigid+ | Flex+ deriving (Eq, Read, Show)++-- |Branches in a case expression.+--+-- Branches @(m.c x1...xn) -> e@ in case expressions are represented as+--+-- @(Branch (Pattern (m,c) [i1,...,in]) e)@+--+-- where each @ij@ is the index of the pattern variable @xj@, or as+--+-- @(Branch (LPattern (Intc i)) e)@+--+-- for integers as branch patterns (similarly for other literals+-- like float or character constants).+data BranchExpr = Branch Pattern Expr+ deriving (Eq, Read, Show)++-- |Patterns in case expressions.+data Pattern+ = Pattern QName [VarIndex]+ | LPattern Literal+ deriving (Eq, Read, Show)++instance Binary Visibility where+ put Public = putWord8 0+ put Private = putWord8 1++ get = do+ x <- getWord8+ case x of+ 0 -> return Public+ 1 -> return Private+ _ -> fail "Invalid encoding for Visibility"++instance Binary Prog where+ put (Prog mid im tys fus ops) =+ put mid >> put im >> put tys >> put fus >> put ops+ get = Prog <$> get <*> get <*> get <*> get <*> get++instance Binary TypeDecl where+ put (Type qid vis vs cs) =+ putWord8 0 >> put qid >> put vis >> put vs >> put cs+ put (TypeSyn qid vis vs ty) =+ putWord8 1 >> put qid >> put vis >> put vs >> put ty+ put (TypeNew qid vis vs c ) =+ putWord8 2 >> put qid >> put vis >> put vs >> put c++ get = do+ x <- getWord8+ case x of+ 0 -> liftM4 Type get get get get+ 1 -> liftM4 TypeSyn get get get get+ 2 -> liftM4 TypeNew get get get get+ _ -> fail "Invalid encoding for TypeDecl"++instance Binary ConsDecl where+ put (Cons qid arity vis tys) = put qid >> put arity >> put vis >> put tys+ get = Cons <$> get <*> get <*> get <*> get++instance Binary NewConsDecl where+ put (NewCons qid vis ty) = put qid >> put vis >> put ty+ get = NewCons <$> get <*> get <*> get++instance Binary TypeExpr where+ put (TVar tv) =+ putWord8 0 >> put tv+ put (FuncType ty1 ty2) =+ putWord8 1 >> put ty1 >> put ty2+ put (TCons qid tys) =+ putWord8 2 >> put qid >> put tys+ put (ForallType vs ty) =+ putWord8 3 >> put vs >> put ty++ get = do+ x <- getWord8+ case x of+ 0 -> fmap TVar get+ 1 -> liftM2 FuncType get get+ 2 -> liftM2 TCons get get+ 3 -> liftM2 ForallType get get+ _ -> fail "Invalid encoding for TypeExpr"++instance Binary Kind where+ put KStar = putWord8 0+ put (KArrow k1 k2) = putWord8 1 >> put k1 >> put k2+ get = do+ x <- getWord8+ case x of+ 0 -> return KStar+ 1 -> liftM2 KArrow get get+ _ -> fail "Invalid encoding for Kind"++instance Binary OpDecl where+ put (Op qid fix pr) = put qid >> put fix >> put pr+ get = liftM3 Op get get get++instance Binary Fixity where+ put InfixOp = putWord8 0+ put InfixlOp = putWord8 1+ put InfixrOp = putWord8 2++ get = do+ x <- getWord8+ case x of+ 0 -> return InfixOp+ 1 -> return InfixlOp+ 2 -> return InfixrOp+ _ -> fail "Invalid encoding for Fixity"++instance Binary FuncDecl where+ put (Func qid arity vis ty r) =+ put qid >> put arity >> put vis >> put ty >> put r+ get = Func <$> get <*> get <*> get <*> get <*> get++instance Binary Rule where+ put (Rule alts e) = putWord8 0 >> put alts >> put e+ put (External n ) = putWord8 1 >> put n++ get = do+ x <- getWord8+ case x of+ 0 -> liftM2 Rule get get+ 1 -> fmap External get+ _ -> fail "Invalid encoding for TRule"++instance Binary Expr where+ put (Var v) = putWord8 0 >> put v+ put (Lit l) = putWord8 1 >> put l+ put (Comb cty qid es) =+ putWord8 2 >> put cty >> put qid >> put es+ put (Let bs e) = putWord8 3 >> put bs >> put e+ put (Free vs e) = putWord8 4 >> put vs >> put e+ put (Or e1 e2) = putWord8 5 >> put e1 >> put e2+ put (Case cty ty as) = putWord8 6 >> put cty >> put ty >> put as+ put (Typed e ty) = putWord8 7 >> put e >> put ty++ get = do+ x <- getWord8+ case x of+ 0 -> fmap Var get+ 1 -> fmap Lit get+ 2 -> liftM3 Comb get get get+ 3 -> liftM2 Let get get+ 4 -> liftM2 Free get get+ 5 -> liftM2 Or get get+ 6 -> liftM3 Case get get get+ 7 -> liftM2 Typed get get+ _ -> fail "Invalid encoding for TExpr"++instance Binary BranchExpr where+ put (Branch p e) = put p >> put e+ get = liftM2 Branch get get++instance Binary Pattern where+ put (Pattern qid vs) = putWord8 0 >> put qid >> put vs+ put (LPattern l ) = putWord8 1 >> put l++ get = do+ x <- getWord8+ case x of+ 0 -> liftM2 Pattern get get+ 1 -> fmap LPattern get+ _ -> fail "Invalid encoding for TPattern"++instance Binary Literal where+ put (Intc i) = putWord8 0 >> put i+ put (Floatc f) = putWord8 1 >> put f+ put (Charc c) = putWord8 2 >> put c++ get = do+ x <- getWord8+ case x of+ 0 -> fmap Intc get+ 1 -> fmap Floatc get+ 2 -> fmap Charc get+ _ -> fail "Invalid encoding for Literal"++instance Binary CombType where+ put FuncCall = putWord8 0+ put ConsCall = putWord8 1+ put (FuncPartCall i) = putWord8 2 >> put i+ put (ConsPartCall i) = putWord8 3 >> put i++ get = do+ x <- getWord8+ case x of+ 0 -> return FuncCall+ 1 -> return ConsCall+ 2 -> fmap FuncPartCall get+ 3 -> fmap ConsPartCall get+ _ -> fail "Invalid encoding for CombType"++instance Binary CaseType where+ put Rigid = putWord8 0+ put Flex = putWord8 1++ get = do+ x <- getWord8+ case x of+ 0 -> return Rigid+ 1 -> return Flex+ _ -> fail "Invalid encoding for CaseType"
+ src/Curry/FlatCurry/Typeable.hs view
@@ -0,0 +1,22 @@+{- |+ Module : $Header$+ Description : Typeclass of Typeable entities+ Copyright : (c) 2018 Kai-Oliver Prott+ License : BSD-3-clause++ Maintainer : fte@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This module defines a Typeclass for easy access to the type of entites+-}++module Curry.FlatCurry.Typeable (Typeable(..)) where++import Curry.FlatCurry.Type (TypeExpr)++class Typeable a where+ typeOf :: a -> TypeExpr++instance Typeable TypeExpr where+ typeOf = id
+ src/Curry/FlatCurry/Typed/Goodies.hs view
@@ -0,0 +1,666 @@+{- |+ Module : $Header$+ Description : Utility functions for working with TypedFlatCurry.+ Copyright : (c) 2016 - 2017 Finn Teegen+ 2018 Kai-Oliver Prott+ License : BSD-3-clause++ Maintainer : fte@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This library provides selector functions, test and update operations+ as well as some useful auxiliary functions for TypedFlatCurry data terms.+ Most of the provided functions are based on general transformation+ functions that replace constructors with user-defined+ functions. For recursive datatypes the transformations are defined+ inductively over the term structure. This is quite usual for+ transformations on TypedFlatCurry terms,+ so the provided functions can be used to implement specific transformations+ without having to explicitly state the recursion. Essentially, the tedious+ part of such transformations - descend in fairly complex term structures -+ is abstracted away, which hopefully makes the code more clear and brief.+-}++module Curry.FlatCurry.Typed.Goodies+ ( module Curry.FlatCurry.Typed.Goodies+ , module Curry.FlatCurry.Goodies+ ) where++import Curry.FlatCurry.Goodies ( Update+ , trType, typeName, typeVisibility, typeParams+ , typeConsDecls, typeSyn, isTypeSyn+ , isDataTypeDecl, isExternalType, isPublicType+ , updType, updTypeName, updTypeVisibility+ , updTypeParams, updTypeConsDecls, updTypeSynonym+ , updQNamesInType+ , trCons, consName, consArity, consVisibility+ , isPublicCons, consArgs, updCons, updConsName+ , updConsArity, updConsVisibility, updConsArgs+ , updQNamesInConsDecl+ , trNewCons, newConsName, newConsVisibility+ , isPublicNewCons, newConsArg+ , updNewCons, updNewConsName+ , updNewConsVisibility, updNewConsArg+ , updQNamesInNewConsDecl+ , tVarIndex, domain, range, tConsName, tConsArgs+ , trTypeExpr, isTVar, isTCons, isFuncType+ , updTVars, updTCons, updFuncTypes, argTypes+ , typeArity, resultType, allVarsInTypeExpr+ , allTypeCons, rnmAllVarsInTypeExpr+ , updQNamesInTypeExpr+ , trOp, opName, opFixity, opPrecedence, updOp+ , updOpName, updOpFixity, updOpPrecedence+ , trCombType, isCombTypeFuncCall+ , isCombTypeFuncPartCall, isCombTypeConsCall+ , isCombTypeConsPartCall+ , isPublic+ )++import Curry.FlatCurry.Typed.Type++-- TProg ----------------------------------------------------------------------++-- |transform program+trTProg :: (String -> [String] -> [TypeDecl] -> [TFuncDecl] -> [OpDecl] -> b)+ -> TProg -> b+trTProg prog (TProg name imps types funcs ops) = prog name imps types funcs ops++-- Selectors++-- |get name from program+tProgName :: TProg -> String+tProgName = trTProg (\name _ _ _ _ -> name)++-- |get imports from program+tProgImports :: TProg -> [String]+tProgImports = trTProg (\_ imps _ _ _ -> imps)++-- |get type declarations from program+tProgTypes :: TProg -> [TypeDecl]+tProgTypes = trTProg (\_ _ types _ _ -> types)++-- |get functions from program+tProgTFuncs :: TProg -> [TFuncDecl]+tProgTFuncs = trTProg (\_ _ _ funcs _ -> funcs)++-- |get infix operators from program+tProgOps :: TProg -> [OpDecl]+tProgOps = trTProg (\_ _ _ _ ops -> ops)++-- Update Operations++-- |update program+updTProg :: (String -> String) ->+ ([String] -> [String]) ->+ ([TypeDecl] -> [TypeDecl]) ->+ ([TFuncDecl] -> [TFuncDecl]) ->+ ([OpDecl] -> [OpDecl]) -> TProg -> TProg+updTProg fn fi ft ff fo = trTProg prog+ where+ prog name imps types funcs ops+ = TProg (fn name) (fi imps) (ft types) (ff funcs) (fo ops)++-- |update name of program+updTProgName :: Update TProg String+updTProgName f = updTProg f id id id id++-- |update imports of program+updTProgImports :: Update TProg [String]+updTProgImports f = updTProg id f id id id++-- |update type declarations of program+updTProgTypes :: Update TProg [TypeDecl]+updTProgTypes f = updTProg id id f id id++-- |update functions of program+updTProgTFuncs :: Update TProg [TFuncDecl]+updTProgTFuncs f = updTProg id id id f id++-- |update infix operators of program+updTProgOps :: Update TProg [OpDecl]+updTProgOps = updTProg id id id id++-- Auxiliary Functions++-- |get all program variables (also from patterns)+allVarsInTProg :: TProg -> [(VarIndex, TypeExpr)]+allVarsInTProg = concatMap allVarsInTFunc . tProgTFuncs++-- |lift transformation on expressions to program+updTProgTExps :: Update TProg TExpr+updTProgTExps = updTProgTFuncs . map . updTFuncBody++-- |rename programs variables+rnmAllVarsInTProg :: Update TProg VarIndex+rnmAllVarsInTProg = updTProgTFuncs . map . rnmAllVarsInTFunc++-- |update all qualified names in program+updQNamesInTProg :: Update TProg QName+updQNamesInTProg f = updTProg id id+ (map (updQNamesInType f)) (map (updQNamesInTFunc f)) (map (updOpName f))++-- |rename program (update name of and all qualified names in program)+rnmTProg :: String -> TProg -> TProg+rnmTProg name p = updTProgName (const name) (updQNamesInTProg rnm p)+ where+ rnm (m, n) | m == tProgName p = (name, n)+ | otherwise = (m, n)++-- TFuncDecl ------------------------------------------------------------------++-- |transform function+trTFunc :: (QName -> Int -> Visibility -> TypeExpr -> TRule -> b) -> TFuncDecl -> b+trTFunc func (TFunc name arity vis t rule) = func name arity vis t rule++-- Selectors++-- |get name of function+tFuncName :: TFuncDecl -> QName+tFuncName = trTFunc (\name _ _ _ _ -> name)++-- |get arity of function+tFuncArity :: TFuncDecl -> Int+tFuncArity = trTFunc (\_ arity _ _ _ -> arity)++-- |get visibility of function+tFuncVisibility :: TFuncDecl -> Visibility+tFuncVisibility = trTFunc (\_ _ vis _ _ -> vis)++-- |get type of function+tFuncType :: TFuncDecl -> TypeExpr+tFuncType = trTFunc (\_ _ _ t _ -> t)++-- |get rule of function+tFuncTRule :: TFuncDecl -> TRule+tFuncTRule = trTFunc (\_ _ _ _ rule -> rule)++-- Update Operations++-- |update function+updTFunc :: (QName -> QName) ->+ (Int -> Int) ->+ (Visibility -> Visibility) ->+ (TypeExpr -> TypeExpr) ->+ (TRule -> TRule) -> TFuncDecl -> TFuncDecl+updTFunc fn fa fv ft fr = trTFunc func+ where+ func name arity vis t rule+ = TFunc (fn name) (fa arity) (fv vis) (ft t) (fr rule)++-- |update name of function+updTFuncName :: Update TFuncDecl QName+updTFuncName f = updTFunc f id id id id++-- |update arity of function+updTFuncArity :: Update TFuncDecl Int+updTFuncArity f = updTFunc id f id id id++-- |update visibility of function+updTFuncVisibility :: Update TFuncDecl Visibility+updTFuncVisibility f = updTFunc id id f id id++-- |update type of function+updFuncType :: Update TFuncDecl TypeExpr+updFuncType f = updTFunc id id id f id++-- |update rule of function+updTFuncTRule :: Update TFuncDecl TRule+updTFuncTRule = updTFunc id id id id++-- Auxiliary Functions++-- |is function public?+isPublicTFunc :: TFuncDecl -> Bool+isPublicTFunc = isPublic . tFuncVisibility++-- |is function externally defined?+isExternal :: TFuncDecl -> Bool+isExternal = isTRuleExternal . tFuncTRule++-- |get variable names in a function declaration+allVarsInTFunc :: TFuncDecl -> [(VarIndex, TypeExpr)]+allVarsInTFunc = allVarsInTRule . tFuncTRule++-- |get arguments of function, if not externally defined+tFuncArgs :: TFuncDecl -> [(VarIndex, TypeExpr)]+tFuncArgs = tRuleArgs . tFuncTRule++-- |get body of function, if not externally defined+tFuncBody :: TFuncDecl -> TExpr+tFuncBody = tRuleBody . tFuncTRule++-- |get the right-hand-sides of a 'FuncDecl'+tFuncRHS :: TFuncDecl -> [TExpr]+tFuncRHS f | not (isExternal f) = orCase (tFuncBody f)+ | otherwise = []+ where+ orCase e+ | isTOr e = concatMap orCase (orExps e)+ | isTCase e = concatMap (orCase . tBranchTExpr) (caseBranches e)+ | otherwise = [e]++-- |rename all variables in function+rnmAllVarsInTFunc :: Update TFuncDecl VarIndex+rnmAllVarsInTFunc = updTFunc id id id id . rnmAllVarsInTRule++-- |update all qualified names in function+updQNamesInTFunc :: Update TFuncDecl QName+updQNamesInTFunc f = updTFunc f id id (updQNamesInTypeExpr f) (updQNamesInTRule f)++-- |update arguments of function, if not externally defined+updTFuncArgs :: Update TFuncDecl [(VarIndex, TypeExpr)]+updTFuncArgs = updTFuncTRule . updTRuleArgs++-- |update body of function, if not externally defined+updTFuncBody :: Update TFuncDecl TExpr+updTFuncBody = updTFuncTRule . updTRuleBody++-- TRule ----------------------------------------------------------------------++-- |transform rule+trTRule :: ([(VarIndex, TypeExpr)] -> TExpr -> b) -> (TypeExpr -> String -> b) -> TRule -> b+trTRule rule _ (TRule args e) = rule args e+trTRule _ ext (TExternal ty s) = ext ty s++-- Selectors++-- |get rules arguments if it's not external+tRuleArgs :: TRule -> [(VarIndex, TypeExpr)]+tRuleArgs = trTRule const undefined++-- |get rules body if it's not external+tRuleBody :: TRule -> TExpr+tRuleBody = trTRule (\_ e -> e) undefined++-- |get rules external declaration+tRuleExtDecl :: TRule -> String+tRuleExtDecl = trTRule undefined (\_ s -> s)++-- Test Operations++-- |is rule external?+isTRuleExternal :: TRule -> Bool+isTRuleExternal = trTRule (\_ _ -> False) (\_ _ -> True)++-- Update Operations++-- |update rule+updTRule :: (TypeExpr -> TypeExpr) ->+ ([(VarIndex, TypeExpr)] -> [(VarIndex, TypeExpr)]) ->+ (TExpr -> TExpr) ->+ (String -> String) -> TRule -> TRule+updTRule fannot fa fe fs = trTRule rule ext+ where+ rule args e = TRule (fa args) (fe e)+ ext ty s = TExternal (fannot ty) (fs s)++-- |update rules TypeExpr+updTRuleType :: Update TRule TypeExpr+updTRuleType f = updTRule f id id id++-- |update rules arguments+updTRuleArgs :: Update TRule [(VarIndex, TypeExpr)]+updTRuleArgs f = updTRule id f id id++-- |update rules body+updTRuleBody :: Update TRule TExpr+updTRuleBody f = updTRule id id f id++-- |update rules external declaration+updTRuleExtDecl :: Update TRule String+updTRuleExtDecl = updTRule id id id++-- Auxiliary Functions++-- |get variable names in a functions rule+allVarsInTRule :: TRule -> [(VarIndex, TypeExpr)]+allVarsInTRule = trTRule (\args body -> args ++ allVars body) (\_ _ -> [])++-- |rename all variables in rule+rnmAllVarsInTRule :: Update TRule VarIndex+rnmAllVarsInTRule f = updTRule id (map (\(a, b) -> (f a, b))) (rnmAllVars f) id++-- |update all qualified names in rule+updQNamesInTRule :: Update TRule QName+updQNamesInTRule = updTRuleBody . updQNames++-- TExpr ----------------------------------------------------------------------++-- Selectors++-- |get internal number of variable+varNr :: TExpr -> VarIndex+varNr (TVarE _ n) = n+varNr _ = error "Curry.FlatCurry.Typed.Goodies.varNr: no variable"++-- |get literal if expression is literal expression+literal :: TExpr -> Literal+literal (TLit _ l) = l+literal _ = error "Curry.FlatCurry.Typed.Goodies.literal: no literal"++-- |get combination type of a combined expression+combType :: TExpr -> CombType+combType (TComb _ ct _ _) = ct+combType _ = error $ "Curry.FlatCurry.Typed.Goodies.combType: " +++ "no combined expression"++-- |get name of a combined expression+combName :: TExpr -> QName+combName (TComb _ _ name _) = name+combName _ = error $ "Curry.FlatCurry.Typed.Goodies.combName: " +++ "no combined expression"++-- |get arguments of a combined expression+combArgs :: TExpr -> [TExpr]+combArgs (TComb _ _ _ args) = args+combArgs _ = error $ "Curry.FlatCurry.Typed.Goodies.combArgs: " +++ "no combined expression"++-- |get number of missing arguments if expression is combined+missingCombArgs :: TExpr -> Int+missingCombArgs = missingArgs . combType+ where+ missingArgs :: CombType -> Int+ missingArgs = trCombType 0 id 0 id++-- |get indices of variables in let declaration+letBinds :: TExpr -> [((VarIndex, TypeExpr), TExpr)]+letBinds (TLet vs _) = vs+letBinds _ = error $ "Curry.FlatCurry.Typed.Goodies.letBinds: " +++ "no let expression"++-- |get body of let declaration+letBody :: TExpr -> TExpr+letBody (TLet _ e) = e+letBody _ = error $ "Curry.FlatCurry.Typed.Goodies.letBody: " +++ "no let expression"++-- |get variable indices from declaration of free variables+freeVars :: TExpr -> [(VarIndex, TypeExpr)]+freeVars (TFree vs _) = vs+freeVars _ = error $ "Curry.FlatCurry.Typed.Goodies.freeVars: " +++ "no declaration of free variables"++-- |get expression from declaration of free variables+freeExpr :: TExpr -> TExpr+freeExpr (TFree _ e) = e+freeExpr _ = error $ "Curry.FlatCurry.Typed.Goodies.freeExpr: " +++ "no declaration of free variables"++-- |get expressions from or-expression+orExps :: TExpr -> [TExpr]+orExps (TOr e1 e2) = [e1, e2]+orExps _ = error $ "Curry.FlatCurry.Typed.Goodies.orExps: " +++ "no or expression"++-- |get case-type of case expression+caseType :: TExpr -> CaseType+caseType (TCase ct _ _) = ct+caseType _ = error $ "Curry.FlatCurry.Typed.Goodies.caseType: " +++ "no case expression"++-- |get scrutinee of case expression+caseExpr :: TExpr -> TExpr+caseExpr (TCase _ e _) = e+caseExpr _ = error $ "Curry.FlatCurry.Typed.Goodies.caseExpr: " +++ "no case expression"+++-- |get branch expressions from case expression+caseBranches :: TExpr -> [TBranchExpr]+caseBranches (TCase _ _ bs) = bs+caseBranches _ = error "Curry.FlatCurry.Typed.Goodies.caseBranches: no case expression"++-- Test Operations++-- |is expression a variable?+isTVarE :: TExpr -> Bool+isTVarE e = case e of+ TVarE _ _ -> True+ _ -> False++-- |is expression a literal expression?+isTLit :: TExpr -> Bool+isTLit e = case e of+ TLit _ _ -> True+ _ -> False++-- |is expression combined?+isTComb :: TExpr -> Bool+isTComb e = case e of+ TComb _ _ _ _ -> True+ _ -> False++-- |is expression a let expression?+isTLet :: TExpr -> Bool+isTLet e = case e of+ TLet _ _ -> True+ _ -> False++-- |is expression a declaration of free variables?+isTFree :: TExpr -> Bool+isTFree e = case e of+ TFree _ _ -> True+ _ -> False++-- |is expression an or-expression?+isTOr :: TExpr -> Bool+isTOr e = case e of+ TOr _ _ -> True+ _ -> False++-- |is expression a case expression?+isTCase :: TExpr -> Bool+isTCase e = case e of+ TCase _ _ _ -> True+ _ -> False++-- |transform expression+trTExpr :: (TypeExpr -> VarIndex -> b)+ -> (TypeExpr -> Literal -> b)+ -> (TypeExpr -> CombType -> QName -> [b] -> b)+ -> ([((VarIndex, TypeExpr), b)] -> b -> b)+ -> ([(VarIndex, TypeExpr)] -> b -> b)+ -> (b -> b -> b)+ -> (CaseType -> b -> [c] -> b)+ -> (TPattern -> b -> c)+ -> (b -> TypeExpr -> b)+ -> TExpr+ -> b+trTExpr var lit comb lt fr oR cas branch typed expr = case expr of+ TVarE ty n -> var ty n+ TLit ty l -> lit ty l+ TComb ty ct name args -> comb ty ct name (map f args)+ TLet bs e -> lt (map (\(v, x) -> (v, f x)) bs) (f e)+ TFree vs e -> fr vs (f e)+ TOr e1 e2 -> oR (f e1) (f e2)+ TCase ct e bs -> cas ct (f e) (map (\ (TBranch p e') -> branch p (f e')) bs)+ TTyped e ty -> typed (f e) ty+ where+ f = trTExpr var lit comb lt fr oR cas branch typed++-- |update all variables in given expression+updVars :: (TypeExpr -> VarIndex -> TExpr) -> TExpr -> TExpr+updVars var = trTExpr var TLit TComb TLet TFree TOr TCase TBranch TTyped++-- |update all literals in given expression+updLiterals :: (TypeExpr -> Literal -> TExpr) -> TExpr -> TExpr+updLiterals lit = trTExpr TVarE lit TComb TLet TFree TOr TCase TBranch TTyped++-- |update all combined expressions in given expression+updCombs :: (TypeExpr -> CombType -> QName -> [TExpr] -> TExpr) -> TExpr -> TExpr+updCombs comb = trTExpr TVarE TLit comb TLet TFree TOr TCase TBranch TTyped++-- |update all let expressions in given expression+updLets :: ([((VarIndex, TypeExpr), TExpr)] -> TExpr -> TExpr) -> TExpr -> TExpr+updLets lt = trTExpr TVarE TLit TComb lt TFree TOr TCase TBranch TTyped++-- |update all free declarations in given expression+updFrees :: ([(VarIndex, TypeExpr)] -> TExpr -> TExpr) -> TExpr -> TExpr+updFrees fr = trTExpr TVarE TLit TComb TLet fr TOr TCase TBranch TTyped++-- |update all or expressions in given expression+updOrs :: (TExpr -> TExpr -> TExpr) -> TExpr -> TExpr+updOrs oR = trTExpr TVarE TLit TComb TLet TFree oR TCase TBranch TTyped++-- |update all case expressions in given expression+updCases :: (CaseType -> TExpr -> [TBranchExpr] -> TExpr) -> TExpr -> TExpr+updCases cas = trTExpr TVarE TLit TComb TLet TFree TOr cas TBranch TTyped++-- |update all case branches in given expression+updBranches :: (TPattern -> TExpr -> TBranchExpr) -> TExpr -> TExpr+updBranches branch = trTExpr TVarE TLit TComb TLet TFree TOr TCase branch TTyped++-- |update all typed expressions in given expression+updTypeds :: (TExpr -> TypeExpr -> TExpr) -> TExpr -> TExpr+updTypeds = trTExpr TVarE TLit TComb TLet TFree TOr TCase TBranch++-- Auxiliary Functions++-- |is expression a call of a function where all arguments are provided?+isFuncCall :: TExpr -> Bool+isFuncCall e = isTComb e && isCombTypeFuncCall (combType e)++-- |is expression a partial function call?+isFuncPartCall :: TExpr -> Bool+isFuncPartCall e = isTComb e && isCombTypeFuncPartCall (combType e)++-- |is expression a call of a constructor?+isConsCall :: TExpr -> Bool+isConsCall e = isTComb e && isCombTypeConsCall (combType e)++-- |is expression a partial constructor call?+isConsPartCall :: TExpr -> Bool+isConsPartCall e = isTComb e && isCombTypeConsPartCall (combType e)++-- |is expression fully evaluated?+isGround :: TExpr -> Bool+isGround e+ = case e of+ TComb _ ConsCall _ args -> all isGround args+ _ -> isTLit e++-- |get all variables (also pattern variables) in expression+allVars :: TExpr -> [(VarIndex, TypeExpr)]+allVars e = trTExpr var lit comb lt fr (.) cas branch typ e []+ where+ var a v = (:) (v, a)+ lit = const (const id)+ comb _ _ _ = foldr (.) id+ lt bs e' = e' . foldr (.) id (map (\(n,ns) -> (n:) . ns) bs)+ fr vs e' = (vs++) . e'+ cas _ e' bs = e' . foldr (.) id bs+ branch pat e' = (args pat ++) . e'+ typ = const+ args pat | isConsPattern pat = tPatArgs pat+ | otherwise = []++-- |rename all variables (also in patterns) in expression+rnmAllVars :: Update TExpr VarIndex+rnmAllVars f = trTExpr var TLit TComb lt fr TOr TCase branch TTyped+ where+ var a = TVarE a . f+ lt = TLet . map (\((n, b), e) -> ((f n, b), e))+ fr = TFree . map (\(b, c) -> (f b, c))+ branch = TBranch . updTPatArgs (map (\(a, b) -> (f a, b)))++-- |update all qualified names in expression+updQNames :: Update TExpr QName+updQNames f = trTExpr TVarE TLit comb TLet TFree TOr TCase branch TTyped+ where+ comb ty ct name args = TComb ty ct (f name) args+ branch = TBranch . updTPatCons f++-- TBranchExpr ----------------------------------------------------------------++-- |transform branch expression+trTBranch :: (TPattern -> TExpr -> b) -> TBranchExpr -> b+trTBranch branch (TBranch pat e) = branch pat e++-- Selectors++-- |get pattern from branch expression+tBranchTPattern :: TBranchExpr -> TPattern+tBranchTPattern = trTBranch const++-- |get expression from branch expression+tBranchTExpr :: TBranchExpr -> TExpr+tBranchTExpr = trTBranch (\_ e -> e)++-- Update Operations++-- |update branch expression+updTBranch :: (TPattern -> TPattern) -> (TExpr -> TExpr) -> TBranchExpr -> TBranchExpr+updTBranch fp fe = trTBranch branch+ where+ branch pat e = TBranch (fp pat) (fe e)++-- |update pattern of branch expression+updTBranchTPattern :: Update TBranchExpr TPattern+updTBranchTPattern f = updTBranch f id++-- |update expression of branch expression+updTBranchTExpr :: Update TBranchExpr TExpr+updTBranchTExpr = updTBranch id++-- TPattern -------------------------------------------------------------------++-- |transform pattern+trTPattern :: (TypeExpr -> QName -> [(VarIndex, TypeExpr)] -> b) -> (TypeExpr -> Literal -> b) -> TPattern -> b+trTPattern pat _ (TPattern ty name args) = pat ty name args+trTPattern _ lpat (TLPattern a l) = lpat a l++-- Selectors++-- |get name from constructor pattern+tPatCons :: TPattern -> QName+tPatCons = trTPattern (\_ name _ -> name) undefined++-- |get arguments from constructor pattern+tPatArgs :: TPattern -> [(VarIndex, TypeExpr)]+tPatArgs = trTPattern (\_ _ args -> args) undefined++-- |get literal from literal pattern+tPatLiteral :: TPattern -> Literal+tPatLiteral = trTPattern undefined (const id)++-- Test Operations++-- |is pattern a constructor pattern?+isConsPattern :: TPattern -> Bool+isConsPattern = trTPattern (\_ _ _ -> True) (\_ _ -> False)++-- Update Operations++-- |update pattern+updTPattern :: (TypeExpr -> TypeExpr) ->+ (QName -> QName) ->+ ([(VarIndex, TypeExpr)] -> [(VarIndex, TypeExpr)]) ->+ (Literal -> Literal) -> TPattern -> TPattern+updTPattern fannot fn fa fl = trTPattern pattern lpattern+ where+ pattern ty name args = TPattern (fannot ty) (fn name) (fa args)+ lpattern ty l = TLPattern (fannot ty) (fl l)++-- |update TypeExpr of pattern+updTPatType :: (TypeExpr -> TypeExpr) -> TPattern -> TPattern+updTPatType f = updTPattern f id id id++-- |update constructors name of pattern+updTPatCons :: (QName -> QName) -> TPattern -> TPattern+updTPatCons f = updTPattern id f id id++-- |update arguments of constructor pattern+updTPatArgs :: ([(VarIndex, TypeExpr)] -> [(VarIndex, TypeExpr)]) -> TPattern -> TPattern+updTPatArgs f = updTPattern id id f id++-- |update literal of pattern+updTPatLiteral :: (Literal -> Literal) -> TPattern -> TPattern+updTPatLiteral = updTPattern id id id++-- Auxiliary Functions++-- |build expression from pattern+tPatExpr :: TPattern -> TExpr+tPatExpr = trTPattern (\ty name -> TComb ty ConsCall name . map (uncurry (flip TVarE))) TLit
+ src/Curry/FlatCurry/Typed/Type.hs view
@@ -0,0 +1,146 @@+{- |+ Module : $Header$+ Description : Representation of annotated FlatCurry.+ Copyright : (c) 2016 - 2017 Finn Teegen+ 2018 Kai-Oliver Prott+ License : BSD-3-clause++ Maintainer : fte@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This library contains a version of FlatCurry's abstract syntax tree+ modified with type information++ For more information about the abstract syntax tree of `FlatCurry`,+ see the documentation of the respective module.+-}++module Curry.FlatCurry.Typed.Type+ ( module Curry.FlatCurry.Typed.Type+ , module Curry.FlatCurry.Typeable+ , module Curry.FlatCurry.Type+ ) where++import Data.Binary+import Control.Monad++import Curry.FlatCurry.Typeable+import Curry.FlatCurry.Type ( QName, VarIndex, Visibility (..), TVarIndex+ , TypeDecl (..), Kind (..), OpDecl (..), Fixity (..)+ , TypeExpr (..), ConsDecl (..), NewConsDecl (..)+ , Literal (..), CombType (..), CaseType (..)+ )++data TProg = TProg String [String] [TypeDecl] [TFuncDecl] [OpDecl]+ deriving (Eq, Read, Show)++data TFuncDecl = TFunc QName Int Visibility TypeExpr TRule+ deriving (Eq, Read, Show)++data TRule+ = TRule [(VarIndex, TypeExpr)] TExpr+ | TExternal TypeExpr String+ deriving (Eq, Read, Show)++data TExpr+ = TVarE TypeExpr VarIndex -- otherwise name clash with TypeExpr's TVar+ | TLit TypeExpr Literal+ | TComb TypeExpr CombType QName [TExpr]+ | TLet [((VarIndex, TypeExpr), TExpr)] TExpr+ | TFree [(VarIndex, TypeExpr)] TExpr+ | TOr TExpr TExpr+ | TCase CaseType TExpr [TBranchExpr]+ | TTyped TExpr TypeExpr+ deriving (Eq, Read, Show)++data TBranchExpr = TBranch TPattern TExpr+ deriving (Eq, Read, Show)++data TPattern+ = TPattern TypeExpr QName [(VarIndex, TypeExpr)]+ | TLPattern TypeExpr Literal+ deriving (Eq, Read, Show)++instance Typeable TRule where+ typeOf (TRule args e) = foldr (FuncType . snd) (typeOf e) args+ typeOf (TExternal ty _) = ty++instance Typeable TExpr where+ typeOf (TVarE ty _) = ty+ typeOf (TLit ty _) = ty+ typeOf (TComb ty _ _ _) = ty+ typeOf (TLet _ e) = typeOf e+ typeOf (TFree _ e) = typeOf e+ typeOf (TOr e _) = typeOf e+ typeOf (TCase _ _ (e:_)) = typeOf e+ typeOf (TTyped _ ty) = ty+ typeOf (TCase _ _ []) = error $ "Curry.FlatCurry.Typed.Type.typeOf: " +++ "empty list in case expression"++instance Typeable TPattern where+ typeOf (TPattern ty _ _) = ty+ typeOf (TLPattern ty _) = ty++instance Typeable TBranchExpr where+ typeOf (TBranch _ e) = typeOf e++instance Binary TProg where+ put (TProg mid im tys fus ops) =+ put mid >> put im >> put tys >> put fus >> put ops+ get = TProg <$> get <*> get <*> get <*> get <*> get++instance Binary TFuncDecl where+ put (TFunc qid arity vis ty r) =+ put qid >> put arity >> put vis >> put ty >> put r+ get = TFunc <$> get <*> get <*> get <*> get <*> get++instance Binary TRule where+ put (TRule alts e) = putWord8 0 >> put alts >> put e+ put (TExternal ty n ) = putWord8 1 >> put ty >> put n++ get = do+ x <- getWord8+ case x of+ 0 -> liftM2 TRule get get+ 1 -> liftM2 TExternal get get+ _ -> fail "Invalid encoding for TRule"++instance Binary TExpr where+ put (TVarE ty v) = putWord8 0 >> put ty >> put v+ put (TLit ty l) = putWord8 1 >> put ty >> put l+ put (TComb ty cty qid es) =+ putWord8 2 >> put ty >> put cty >> put qid >> put es+ put (TLet bs e) = putWord8 3 >> put bs >> put e+ put (TFree vs e) = putWord8 4 >> put vs >> put e+ put (TOr e1 e2) = putWord8 5 >> put e1 >> put e2+ put (TCase cty ty as) = putWord8 6 >> put cty >> put ty >> put as+ put (TTyped e ty) = putWord8 7 >> put e >> put ty++ get = do+ x <- getWord8+ case x of+ 0 -> liftM2 TVarE get get+ 1 -> liftM2 TLit get get+ 2 -> liftM4 TComb get get get get+ 3 -> liftM2 TLet get get+ 4 -> liftM2 TFree get get+ 5 -> liftM2 TOr get get+ 6 -> liftM3 TCase get get get+ 7 -> liftM2 TTyped get get+ _ -> fail "Invalid encoding for TExpr"++instance Binary TBranchExpr where+ put (TBranch p e) = put p >> put e+ get = liftM2 TBranch get get++instance Binary TPattern where+ put (TPattern ty qid vs) = putWord8 0 >> put ty >> put qid >> put vs+ put (TLPattern ty l ) = putWord8 1 >> put ty >> put l++ get = do+ x <- getWord8+ case x of+ 0 -> liftM3 TPattern get get get+ 1 -> liftM2 TLPattern get get+ _ -> fail "Invalid encoding for TPattern"
+ src/Curry/Syntax.hs view
@@ -0,0 +1,81 @@+{- |+ Module : $Header$+ Description : Interface for reading and manipulating Curry source code+ Copyright : (c) 2009 Holger Siegel+ 2011 - 2013 Björn Peemöller+ 2016 Finn Teegen+ 2016 Jan Tikovsky+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable+-}+module Curry.Syntax+ ( module Curry.Syntax.Type+ , module Curry.Syntax.Utils+ , L.Token (..), L.Category (..), L.Attributes (..)+ , unlit, unlitLexSource, unlitParseHeader, unlitParsePragmas, unlitParseModule+ , lexSource, parseInterface, parseHeader, parsePragmas, parseModule, parseGoal+ , pPrint, pPrintPrec+ , showModule+ ) where++import Curry.Base.Monad (CYM)+import Curry.Base.Span (Span)+import Curry.Base.Pretty (pPrint, pPrintPrec)+import qualified Curry.Files.Unlit as U (unlit)++import qualified Curry.Syntax.Lexer as L+import qualified Curry.Syntax.Parser as P+import Curry.Syntax.Pretty ()+import Curry.Syntax.ShowModule (showModule)+import Curry.Syntax.Type+import Curry.Syntax.Utils++-- |Unliterate a LiterateCurry file, identity on normal Curry file.+unlit :: FilePath -> String -> CYM String+unlit = U.unlit++-- |Unliterate and return the result of a lexical analysis of the source+-- program @src@.+-- The result is a list of tuples consisting of a 'Span' and a 'Token'.+unlitLexSource :: FilePath -> String -> CYM [(Span, L.Token)]+unlitLexSource fn src = U.unlit fn src >>= L.lexSource fn++-- |Unliterate and parse only pragmas of a Curry 'Module'+unlitParsePragmas :: FilePath -> String -> CYM (Module ())+unlitParsePragmas fn src = U.unlit fn src >>= P.parsePragmas fn++-- |Unliterate and parse a Curry 'Module' header+unlitParseHeader :: FilePath -> String -> CYM (Module ())+unlitParseHeader fn src = U.unlit fn src >>= P.parseHeader fn++-- |Unliterate and parse a Curry 'Module'+unlitParseModule :: FilePath -> String -> CYM (Module ())+unlitParseModule fn src = U.unlit fn src >>= P.parseSource fn++-- |Return the result of a lexical analysis of the source program @src@.+-- The result is a list of tuples consisting of a 'Span' and a 'Token'.+lexSource :: FilePath -> String -> CYM [(Span, L.Token)]+lexSource = L.lexSource++-- |Parse a Curry 'Interface'+parseInterface :: FilePath -> String -> CYM Interface+parseInterface = P.parseInterface++-- |Parse only pragmas of a Curry 'Module'+parsePragmas :: FilePath -> String -> CYM (Module ())+parsePragmas = P.parsePragmas++-- |Parse a Curry 'Module' header+parseHeader :: FilePath -> String -> CYM (Module ())+parseHeader = P.parseHeader++-- |Parse a Curry 'Module'+parseModule :: FilePath -> String -> CYM (Module ())+parseModule = P.parseSource++-- |Parse a 'Goal', i.e. an expression with (optional) local declarations+parseGoal :: String -> CYM (Goal ())+parseGoal = P.parseGoal
+ src/Curry/Syntax/Extension.hs view
@@ -0,0 +1,120 @@+{- |+ Module : $Header$+ Description : Curry language extensions+ Copyright : (c) 2013 - 2014 Björn Peemöller+ 2016 Finn Teegen+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This module provides the data structures for Curry language extensions.+-}++module Curry.Syntax.Extension+ ( -- * Extensions+ Extension (..), KnownExtension (..), classifyExtension, kielExtensions+ -- * Tools+ , Tool (..), classifyTool+ ) where++import Data.Binary+import Data.Char (toUpper)+import Control.Monad++import Curry.Base.Ident (Ident (..))+import Curry.Base.Position+import Curry.Base.SpanInfo++-- |Specified language extensions, either known or unknown.+data Extension+ = KnownExtension SpanInfo KnownExtension -- ^ a known extension+ | UnknownExtension SpanInfo String -- ^ an unknown extension+ deriving (Eq, Read, Show)++instance HasSpanInfo Extension where+ getSpanInfo (KnownExtension spi _) = spi+ getSpanInfo (UnknownExtension spi _) = spi+ + setSpanInfo spi (KnownExtension _ ke) = KnownExtension spi ke+ setSpanInfo spi (UnknownExtension _ s) = UnknownExtension spi s++instance HasPosition Extension where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance Binary Extension where+ put (KnownExtension p e) = putWord8 0 >> put p >> put e+ put (UnknownExtension p e) = putWord8 1 >> put p >> put e++ get = do+ x <- getWord8+ case x of+ 0 -> liftM2 KnownExtension get get+ 1 -> liftM2 UnknownExtension get get+ _ -> fail "Invalid encoding for Extension"++instance Binary KnownExtension where+ put AnonFreeVars = putWord8 0+ put CPP = putWord8 1+ put FunctionalPatterns = putWord8 2+ put NegativeLiterals = putWord8 3+ put NoImplicitPrelude = putWord8 4++ get = do+ x <- getWord8+ case x of+ 0 -> return AnonFreeVars+ 1 -> return CPP+ 2 -> return FunctionalPatterns+ 3 -> return NegativeLiterals+ 4 -> return NoImplicitPrelude+ _ -> fail "Invalid encoding for KnownExtension"++-- |Known language extensions of Curry.+data KnownExtension+ = AnonFreeVars -- ^ anonymous free variables+ | CPP -- ^ C preprocessor+ | FunctionalPatterns -- ^ functional patterns+ | NegativeLiterals -- ^ negative literals+ | NoImplicitPrelude -- ^ no implicit import of the prelude+ deriving (Eq, Read, Show, Enum, Bounded)++-- |Classifies a 'String' as an 'Extension'+classifyExtension :: Ident -> Extension+classifyExtension i = case reads extName of+ [(e, "")] -> KnownExtension (getSpanInfo i) e+ _ -> UnknownExtension (getSpanInfo i) extName+ where extName = idName i++-- |'Extension's available by Kiel's Curry compilers.+kielExtensions :: [KnownExtension]+kielExtensions = [AnonFreeVars, FunctionalPatterns]++-- |Different Curry tools which may accept compiler options.+data Tool = KICS2 | PAKCS | CYMAKE | FRONTEND | UnknownTool String+ deriving (Eq, Read, Show)++instance Binary Tool where+ put KICS2 = putWord8 0+ put PAKCS = putWord8 1+ put CYMAKE = putWord8 2+ put FRONTEND = putWord8 3+ put (UnknownTool s) = putWord8 4 >> put s++ get = do+ x <- getWord8+ case x of+ 0 -> return KICS2+ 1 -> return PAKCS+ 2 -> return CYMAKE+ 3 -> return FRONTEND+ 4 -> fmap UnknownTool get+ _ -> fail "Invalid encoding for Tool"++-- |Classifies a 'String' as a 'Tool'+classifyTool :: String -> Tool+classifyTool str = case reads (map toUpper str) of+ [(t, "")] -> t+ _ -> UnknownTool str
+ src/Curry/Syntax/InterfaceEquivalence.hs view
@@ -0,0 +1,209 @@+{- |+ Module : $Header$+ Description : Comparison of Curry Interfaces+ Copyright : (c) 2000 - 2007 Wolfgang Lux+ 2014 - 2015 Björn Peemöller+ 2014 Jan Tikovsky+ 2016 Finn Teegen+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ If a module is recompiled, the compiler has to check whether the+ interface file must be updated. This must be done if any exported+ entity has been changed, or an export was removed or added. The+ function 'intfEquiv' checks whether two interfaces are+ equivalent, i.e., whether they define the same entities.+-}+module Curry.Syntax.InterfaceEquivalence (fixInterface, intfEquiv) where++import Data.List (deleteFirstsBy, sort)+import qualified Data.Set as Set++import Curry.Base.Ident+import Curry.Syntax++infix 4 =~=, `eqvSet`++-- |Are two given interfaces equivalent?+intfEquiv :: Interface -> Interface -> Bool+intfEquiv = (=~=)++-- |Type class to express the equivalence of two values+class Equiv a where+ (=~=) :: a -> a -> Bool++instance Equiv a => Equiv (Maybe a) where+ Nothing =~= Nothing = True+ Nothing =~= Just _ = False+ Just _ =~= Nothing = False+ Just x =~= Just y = x =~= y++instance Equiv a => Equiv [a] where+ [] =~= [] = True+ (x:xs) =~= (y:ys) = x =~= y && xs =~= ys+ _ =~= _ = False++eqvList, eqvSet :: Equiv a => [a] -> [a] -> Bool+xs `eqvList` ys = length xs == length ys && and (zipWith (=~=) xs ys)+xs `eqvSet` ys = null (deleteFirstsBy (=~=) xs ys ++ deleteFirstsBy (=~=) ys xs)++instance Equiv Interface where+ Interface m1 is1 ds1 =~= Interface m2 is2 ds2+ = m1 == m2 && is1 `eqvSet` is2 && ds1 `eqvSet` ds2++instance Equiv IImportDecl where+ IImportDecl _ m1 =~= IImportDecl _ m2 = m1 == m2++-- Since the kind of type constructors or type classes can be omitted+-- in the interface when the kind is simple, i.e., it is either * or of+-- the form * -> ... -> *, a non given kind has to be considered equivalent+-- to a given one if the latter is simple.++eqvKindExpr :: Maybe KindExpr -> Maybe KindExpr -> Bool+Nothing `eqvKindExpr` (Just k) = isSimpleKindExpr k+(Just k) `eqvKindExpr` Nothing = isSimpleKindExpr k+k1 `eqvKindExpr` k2 = k1 == k2++isSimpleKindExpr :: KindExpr -> Bool+isSimpleKindExpr Star = True+isSimpleKindExpr (ArrowKind Star k) = isSimpleKindExpr k+isSimpleKindExpr _ = False+++instance Equiv IDecl where+ IInfixDecl _ fix1 p1 op1 =~= IInfixDecl _ fix2 p2 op2+ = fix1 == fix2 && p1 == p2 && op1 == op2+ HidingDataDecl _ tc1 k1 tvs1 =~= HidingDataDecl _ tc2 k2 tvs2+ = tc1 == tc2 && k1 `eqvKindExpr` k2 && tvs1 == tvs2+ IDataDecl _ tc1 k1 tvs1 cs1 hs1 =~= IDataDecl _ tc2 k2 tvs2 cs2 hs2+ = tc1 == tc2 && k1 `eqvKindExpr` k2 && tvs1 == tvs2 && cs1 =~= cs2 &&+ hs1 `eqvSet` hs2+ INewtypeDecl _ tc1 k1 tvs1 nc1 hs1 =~= INewtypeDecl _ tc2 k2 tvs2 nc2 hs2+ = tc1 == tc2 && k1 `eqvKindExpr` k2 && tvs1 == tvs2 && nc1 =~= nc2 &&+ hs1 `eqvSet` hs2+ ITypeDecl _ tc1 k1 tvs1 ty1 =~= ITypeDecl _ tc2 k2 tvs2 ty2+ = tc1 == tc2 && k1 `eqvKindExpr` k2 && tvs1 == tvs2 && ty1 == ty2+ IFunctionDecl _ f1 cm1 n1 qty1 =~= IFunctionDecl _ f2 cm2 n2 qty2+ = f1 == f2 && cm1 == cm2 && n1 == n2 && qty1 == qty2+ HidingClassDecl _ cx1 cls1 k1 _ =~= HidingClassDecl _ cx2 cls2 k2 _+ = cx1 == cx2 && cls1 == cls2 && k1 `eqvKindExpr` k2+ IClassDecl _ cx1 cls1 k1 _ ms1 hs1 =~= IClassDecl _ cx2 cls2 k2 _ ms2 hs2+ = cx1 == cx2 && cls1 == cls2 && k1 `eqvKindExpr` k2 &&+ ms1 `eqvList` ms2 && hs1 `eqvSet` hs2+ IInstanceDecl _ cx1 cls1 ty1 is1 m1 =~= IInstanceDecl _ cx2 cls2 ty2 is2 m2+ = cx1 == cx2 && cls1 == cls2 && ty1 == ty2 && sort is1 == sort is2 &&+ m1 == m2+ _ =~= _ = False++instance Equiv ConstrDecl where+ ConstrDecl _ c1 tys1 =~= ConstrDecl _ c2 tys2+ = c1 == c2 && tys1 == tys2+ ConOpDecl _ ty11 op1 ty12 =~= ConOpDecl _ ty21 op2 ty22+ = op1 == op2 && ty11 == ty21 && ty12 == ty22+ RecordDecl _ c1 fs1 =~= RecordDecl _ c2 fs2+ = c1 == c2 && fs1 `eqvList` fs2+ _ =~= _ = False++instance Equiv FieldDecl where+ FieldDecl _ ls1 ty1 =~= FieldDecl _ ls2 ty2 = ls1 == ls2 && ty1 == ty2++instance Equiv NewConstrDecl where+ NewConstrDecl _ c1 ty1 =~= NewConstrDecl _ c2 ty2 = c1 == c2 && ty1 == ty2+ NewRecordDecl _ c1 fld1 =~= NewRecordDecl _ c2 fld2 = c1 == c2 && fld1 == fld2+ _ =~= _ = False++instance Equiv IMethodDecl where+ IMethodDecl _ f1 a1 qty1 =~= IMethodDecl _ f2 a2 qty2+ = f1 == f2 && a1 == a2 && qty1 == qty2++instance Equiv Ident where+ (=~=) = (==)++-- If we check for a change in the interface, we do not need to check the+-- interface declarations, but still must disambiguate (nullary) type+-- constructors and type variables in type expressions. This is handled+-- by function 'fixInterface' and the associated type class 'FixInterface'.++-- |Disambiguate nullary type constructors and type variables.+fixInterface :: Interface -> Interface+fixInterface (Interface m is ds) = Interface m is $+ fix (Set.fromList (typeConstructors ds)) ds++class FixInterface a where+ fix :: Set.Set Ident -> a -> a++instance FixInterface a => FixInterface (Maybe a) where+ fix tcs = fmap (fix tcs)++instance FixInterface a => FixInterface [a] where+ fix tcs = map (fix tcs)++instance FixInterface IDecl where+ fix tcs (IDataDecl p tc k vs cs hs) =+ IDataDecl p tc k vs (fix tcs cs) hs+ fix tcs (INewtypeDecl p tc k vs nc hs) =+ INewtypeDecl p tc k vs (fix tcs nc) hs+ fix tcs (ITypeDecl p tc k vs ty) =+ ITypeDecl p tc k vs (fix tcs ty)+ fix tcs (IFunctionDecl p f cm n qty) =+ IFunctionDecl p f cm n (fix tcs qty)+ fix tcs (HidingClassDecl p cx cls k tv) =+ HidingClassDecl p (fix tcs cx) cls k tv+ fix tcs (IClassDecl p cx cls k tv ms hs) =+ IClassDecl p (fix tcs cx) cls k tv (fix tcs ms) hs+ fix tcs (IInstanceDecl p cx cls inst is m) =+ IInstanceDecl p (fix tcs cx) cls (fix tcs inst) is m+ fix _ d = d++instance FixInterface ConstrDecl where+ fix tcs (ConstrDecl p c tys) = ConstrDecl p c (fix tcs tys)+ fix tcs (ConOpDecl p ty1 op ty2) = ConOpDecl p (fix tcs ty1)+ op (fix tcs ty2)+ fix tcs (RecordDecl p c fs) = RecordDecl p c (fix tcs fs)++instance FixInterface FieldDecl where+ fix tcs (FieldDecl p ls ty) = FieldDecl p ls (fix tcs ty)++instance FixInterface NewConstrDecl where+ fix tcs (NewConstrDecl p c ty ) = NewConstrDecl p c (fix tcs ty)+ fix tcs (NewRecordDecl p c (i,ty)) = NewRecordDecl p c (i, fix tcs ty)++instance FixInterface IMethodDecl where+ fix tcs (IMethodDecl p f a qty) = IMethodDecl p f a (fix tcs qty)++instance FixInterface QualTypeExpr where+ fix tcs (QualTypeExpr spi cx ty) = QualTypeExpr spi (fix tcs cx) (fix tcs ty)++instance FixInterface Constraint where+ fix tcs (Constraint spi qcls ty) = Constraint spi qcls (fix tcs ty)++instance FixInterface TypeExpr where+ fix tcs (ConstructorType spi tc)+ | not (isQualified tc) && not (isPrimTypeId tc) && tc' `Set.notMember` tcs+ = VariableType spi tc'+ | otherwise = ConstructorType spi tc+ where tc' = unqualify tc+ fix tcs (ApplyType spi ty1 ty2) = ApplyType spi (fix tcs ty1) (fix tcs ty2)+ fix tcs (VariableType spi tv)+ | tv `Set.member` tcs = ConstructorType spi (qualify tv)+ | otherwise = VariableType spi tv+ fix tcs (TupleType spi tys) = TupleType spi (fix tcs tys)+ fix tcs (ListType spi ty) = ListType spi (fix tcs ty)+ fix tcs (ArrowType spi ty1 ty2) = ArrowType spi (fix tcs ty1) (fix tcs ty2)+ fix tcs (ParenType spi ty) = ParenType spi (fix tcs ty)+ fix tcs (ForallType spi vs ty) = ForallType spi vs (fix tcs ty)++typeConstructors :: [IDecl] -> [Ident]+typeConstructors ds = [tc | (QualIdent _ Nothing tc) <- foldr tyCons [] ds]+ where tyCons (IInfixDecl _ _ _ _) tcs = tcs+ tyCons (HidingDataDecl _ tc _ _) tcs = tc : tcs+ tyCons (IDataDecl _ tc _ _ _ _) tcs = tc : tcs+ tyCons (INewtypeDecl _ tc _ _ _ _) tcs = tc : tcs+ tyCons (ITypeDecl _ tc _ _ _) tcs = tc : tcs+ tyCons (IFunctionDecl _ _ _ _ _) tcs = tcs+ tyCons (HidingClassDecl _ _ _ _ _) tcs = tcs+ tyCons (IClassDecl _ _ _ _ _ _ _) tcs = tcs+ tyCons (IInstanceDecl _ _ _ _ _ _) tcs = tcs
+ src/Curry/Syntax/Lexer.hs view
@@ -0,0 +1,889 @@+{- |+ Module : $Header$+ Description : A lexer for Curry+ Copyright : (c) 1999 - 2004 Wolfgang Lux+ 2005 Martin Engelke+ 2011 - 2013 Björn Peemöller+ 2016 Finn Teegen+ 2016 Jan Tikovsky+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable+-}+module Curry.Syntax.Lexer+ ( -- * Data types for tokens+ Token (..), Category (..), Attributes (..)++ -- * lexing functions+ , lexSource, lexer, fullLexer+ ) where++import Prelude hiding (fail)+import Data.Char+ ( chr, ord, isAlpha, isAlphaNum, isDigit, isHexDigit, isOctDigit+ , isSpace, isUpper, toLower+ )+import Data.List (intercalate)+import qualified Data.Map as Map+ (Map, union, lookup, findWithDefault, fromList)++import Curry.Base.LexComb+import Curry.Base.Position+import Curry.Base.Span++-- ---------------------------------------------------------------------------+-- Tokens. Note that the equality and ordering instances of Token disregard+-- the attributes, as so that the parser decides about accepting a token+-- just by its category.+-- ---------------------------------------------------------------------------++-- |Data type for curry lexer tokens+data Token = Token Category Attributes++instance Eq Token where+ Token c1 _ == Token c2 _ = c1 == c2++instance Ord Token where+ Token c1 _ `compare` Token c2 _ = c1 `compare` c2++instance Symbol Token where+ isEOF (Token c _) = c == EOF++ dist _ (Token VSemicolon _) = (0, 0)+ dist _ (Token VRightBrace _) = (0, 0)+ dist _ (Token EOF _) = (0, 0)+ dist _ (Token DotDot _) = (0, 1)+ dist _ (Token DoubleColon _) = (0, 1)+ dist _ (Token LeftArrow _) = (0, 1)+ dist _ (Token RightArrow _) = (0, 1)+ dist _ (Token DoubleArrow _) = (0, 1)+ dist _ (Token KW_do _) = (0, 1)+ dist _ (Token KW_if _) = (0, 1)+ dist _ (Token KW_in _) = (0, 1)+ dist _ (Token KW_of _) = (0, 1)+ dist _ (Token Id_as _) = (0, 1)+ dist _ (Token KW_let _) = (0, 2)+ dist _ (Token PragmaEnd _) = (0, 2)+ dist _ (Token KW_case _) = (0, 3)+ dist _ (Token KW_class _) = (0, 4)+ dist _ (Token KW_data _) = (0, 3)+ dist _ (Token KW_default _) = (0, 6)+ dist _ (Token KW_deriving _) = (0, 7)+ dist _ (Token KW_else _) = (0, 3)+ dist _ (Token KW_free _) = (0, 3)+ dist _ (Token KW_then _) = (0, 3)+ dist _ (Token KW_type _) = (0, 3)+ dist _ (Token KW_fcase _) = (0, 4)+ dist _ (Token KW_infix _) = (0, 4)+ dist _ (Token KW_instance _) = (0, 7)+ dist _ (Token KW_where _) = (0, 4)+ dist _ (Token Id_ccall _) = (0, 4)+ dist _ (Token KW_import _) = (0, 5)+ dist _ (Token KW_infixl _) = (0, 5)+ dist _ (Token KW_infixr _) = (0, 5)+ dist _ (Token KW_module _) = (0, 5)+ dist _ (Token Id_forall _) = (0, 5)+ dist _ (Token Id_hiding _) = (0, 5)+ dist _ (Token KW_newtype _) = (0, 6)+ dist _ (Token KW_external _) = (0, 7)+ dist _ (Token Id_interface _) = (0, 8)+ dist _ (Token Id_primitive _) = (0, 8)+ dist _ (Token Id_qualified _) = (0, 8)+ dist _ (Token PragmaHiding _) = (0, 9)+ dist _ (Token PragmaLanguage _) = (0, 11)+ dist _ (Token Id a) = distAttr False a+ dist _ (Token QId a) = distAttr False a+ dist _ (Token Sym a) = distAttr False a+ dist _ (Token QSym a) = distAttr False a+ dist _ (Token IntTok a) = distAttr False a+ dist _ (Token FloatTok a) = distAttr False a+ dist _ (Token CharTok a) = distAttr False a+ dist c (Token StringTok a) = updColDist c (distAttr False a)+ dist _ (Token LineComment a) = distAttr True a+ dist c (Token NestedComment a) = updColDist c (distAttr True a)+ dist _ (Token PragmaOptions a) = let (ld, cd) = distAttr False a+ in (ld, cd + 11)+ dist _ _ = (0, 0)++-- TODO: Comment+updColDist :: Int -> Distance -> Distance+updColDist c (ld, cd) = (ld, if ld == 0 then cd else cd - c + 1)++distAttr :: Bool -> Attributes -> Distance+distAttr isComment attr = case attr of+ NoAttributes -> (0, 0)+ CharAttributes _ orig -> (0, length orig + 1)+ IntAttributes _ orig -> (0, length orig - 1)+ FloatAttributes _ orig -> (0, length orig - 1)+ StringAttributes _ orig+ -- comment without surrounding quotes+ | isComment -> (ld, cd)+ -- string with one ending double quote or two surrounding double quotes+ -- (column distance + 1 / + 2)+ | '\n' `elem` orig -> (ld, cd + 1)+ | otherwise -> (ld, cd + 2)+ where ld = length (filter (== '\n') orig)+ cd = length (takeWhile (/= '\n') (reverse orig)) - 1+ IdentAttributes mid i -> (0, length (intercalate "." (mid ++ [i])) - 1)+ OptionsAttributes mt args -> case mt of+ Nothing -> (0, distArgs + 1)+ Just t -> (0, length t + distArgs + 2)+ where distArgs = length args++-- |Category of curry tokens+data Category+ -- literals+ = CharTok+ | IntTok+ | FloatTok+ | StringTok++ -- identifiers+ | Id -- identifier+ | QId -- qualified identifier+ | Sym -- symbol+ | QSym -- qualified symbol++ -- punctuation symbols+ | LeftParen -- (+ | RightParen -- )+ | Semicolon -- ;+ | LeftBrace -- {+ | RightBrace -- }+ | LeftBracket -- [+ | RightBracket -- ]+ | Comma -- ,+ | Underscore -- _+ | Backquote -- `++ -- layout+ | VSemicolon -- virtual ;+ | VRightBrace -- virtual }++ -- reserved keywords+ | KW_case+ | KW_class+ | KW_data+ | KW_default+ | KW_deriving+ | KW_do+ | KW_else+ | KW_external+ | KW_fcase+ | KW_free+ | KW_if+ | KW_import+ | KW_in+ | KW_infix+ | KW_infixl+ | KW_infixr+ | KW_instance+ | KW_let+ | KW_module+ | KW_newtype+ | KW_of+ | KW_then+ | KW_type+ | KW_where++ -- reserved operators+ | At -- @+ | Colon -- :+ | DotDot -- ..+ | DoubleColon -- ::+ | Equals -- =+ | Backslash -- \+ | Bar -- |+ | LeftArrow -- <-+ | RightArrow -- ->+ | Tilde -- ~+ | DoubleArrow -- =>++ -- special identifiers+ | Id_as+ | Id_ccall+ | Id_forall+ | Id_hiding+ | Id_interface+ | Id_primitive+ | Id_qualified++ -- special operators+ | SymDot -- .+ | SymMinus -- -++ -- special symbols+ | SymStar -- kind star (*)++ -- pragmas+ | PragmaLanguage -- {-# LANGUAGE+ | PragmaOptions -- {-# OPTIONS+ | PragmaHiding -- {-# HIDING+ | PragmaMethod -- {-# METHOD+ | PragmaModule -- {-# MODULE+ | PragmaEnd -- #-}+++ -- comments (only for full lexer) inserted by men & bbr+ | LineComment+ | NestedComment++ -- end-of-file token+ | EOF+ deriving (Eq, Ord)++-- There are different kinds of attributes associated with the tokens.+-- Most attributes simply save the string corresponding to the token.+-- However, for qualified identifiers, we also record the list of module+-- qualifiers. The values corresponding to a literal token are properly+-- converted already. To simplify the creation and extraction of+-- attribute values, we make use of records.++-- |Attributes associated to a token+data Attributes+ = NoAttributes+ | CharAttributes { cval :: Char , original :: String }+ | IntAttributes { ival :: Integer , original :: String }+ | FloatAttributes { fval :: Double , original :: String }+ | StringAttributes { sval :: String , original :: String }+ | IdentAttributes { modulVal :: [String] , sval :: String }+ | OptionsAttributes { toolVal :: Maybe String, toolArgs :: String }++instance Show Attributes where+ showsPrec _ NoAttributes = showChar '_'+ showsPrec _ (CharAttributes cv _) = shows cv+ showsPrec _ (IntAttributes iv _) = shows iv+ showsPrec _ (FloatAttributes fv _) = shows fv+ showsPrec _ (StringAttributes sv _) = shows sv+ showsPrec _ (IdentAttributes mid i) = showsEscaped+ $ intercalate "." $ mid ++ [i]+ showsPrec _ (OptionsAttributes mt s) = showsTool mt+ . showChar ' ' . showString s+ where showsTool = maybe id (\t -> showChar '_' . showString t)+++-- ---------------------------------------------------------------------------+-- The 'Show' instance of 'Token' is designed to display all tokens in their+-- source representation.+-- ---------------------------------------------------------------------------++showsEscaped :: String -> ShowS+showsEscaped s = showChar '`' . showString s . showChar '\''++showsIdent :: Attributes -> ShowS+showsIdent a = showString "identifier " . shows a++showsSpecialIdent :: String -> ShowS+showsSpecialIdent s = showString "identifier " . showsEscaped s++showsOperator :: Attributes -> ShowS+showsOperator a = showString "operator " . shows a++showsSpecialOperator :: String -> ShowS+showsSpecialOperator s = showString "operator " . showsEscaped s++instance Show Token where+ showsPrec _ (Token Id a) = showsIdent a+ showsPrec _ (Token QId a) = showString "qualified "+ . showsIdent a+ showsPrec _ (Token Sym a) = showsOperator a+ showsPrec _ (Token QSym a) = showString "qualified "+ . showsOperator a+ showsPrec _ (Token IntTok a) = showString "integer " . shows a+ showsPrec _ (Token FloatTok a) = showString "float " . shows a+ showsPrec _ (Token CharTok a) = showString "character " . shows a+ showsPrec _ (Token StringTok a) = showString "string " . shows a+ showsPrec _ (Token LeftParen _) = showsEscaped "("+ showsPrec _ (Token RightParen _) = showsEscaped ")"+ showsPrec _ (Token Semicolon _) = showsEscaped ";"+ showsPrec _ (Token LeftBrace _) = showsEscaped "{"+ showsPrec _ (Token RightBrace _) = showsEscaped "}"+ showsPrec _ (Token LeftBracket _) = showsEscaped "["+ showsPrec _ (Token RightBracket _) = showsEscaped "]"+ showsPrec _ (Token Comma _) = showsEscaped ","+ showsPrec _ (Token Underscore _) = showsEscaped "_"+ showsPrec _ (Token Backquote _) = showsEscaped "`"+ showsPrec _ (Token VSemicolon _)+ = showsEscaped ";" . showString " (inserted due to layout)"+ showsPrec _ (Token VRightBrace _)+ = showsEscaped "}" . showString " (inserted due to layout)"+ showsPrec _ (Token At _) = showsEscaped "@"+ showsPrec _ (Token Colon _) = showsEscaped ":"+ showsPrec _ (Token DotDot _) = showsEscaped ".."+ showsPrec _ (Token DoubleArrow _) = showsEscaped "=>"+ showsPrec _ (Token DoubleColon _) = showsEscaped "::"+ showsPrec _ (Token Equals _) = showsEscaped "="+ showsPrec _ (Token Backslash _) = showsEscaped "\\"+ showsPrec _ (Token Bar _) = showsEscaped "|"+ showsPrec _ (Token LeftArrow _) = showsEscaped "<-"+ showsPrec _ (Token RightArrow _) = showsEscaped "->"+ showsPrec _ (Token Tilde _) = showsEscaped "~"+ showsPrec _ (Token SymDot _) = showsSpecialOperator "."+ showsPrec _ (Token SymMinus _) = showsSpecialOperator "-"+ showsPrec _ (Token SymStar _) = showsEscaped "*"+ showsPrec _ (Token KW_case _) = showsEscaped "case"+ showsPrec _ (Token KW_class _) = showsEscaped "class"+ showsPrec _ (Token KW_data _) = showsEscaped "data"+ showsPrec _ (Token KW_default _) = showsEscaped "default"+ showsPrec _ (Token KW_deriving _) = showsEscaped "deriving"+ showsPrec _ (Token KW_do _) = showsEscaped "do"+ showsPrec _ (Token KW_else _) = showsEscaped "else"+ showsPrec _ (Token KW_external _) = showsEscaped "external"+ showsPrec _ (Token KW_fcase _) = showsEscaped "fcase"+ showsPrec _ (Token KW_free _) = showsEscaped "free"+ showsPrec _ (Token KW_if _) = showsEscaped "if"+ showsPrec _ (Token KW_import _) = showsEscaped "import"+ showsPrec _ (Token KW_in _) = showsEscaped "in"+ showsPrec _ (Token KW_infix _) = showsEscaped "infix"+ showsPrec _ (Token KW_infixl _) = showsEscaped "infixl"+ showsPrec _ (Token KW_infixr _) = showsEscaped "infixr"+ showsPrec _ (Token KW_instance _) = showsEscaped "instance"+ showsPrec _ (Token KW_let _) = showsEscaped "let"+ showsPrec _ (Token KW_module _) = showsEscaped "module"+ showsPrec _ (Token KW_newtype _) = showsEscaped "newtype"+ showsPrec _ (Token KW_of _) = showsEscaped "of"+ showsPrec _ (Token KW_then _) = showsEscaped "then"+ showsPrec _ (Token KW_type _) = showsEscaped "type"+ showsPrec _ (Token KW_where _) = showsEscaped "where"+ showsPrec _ (Token Id_as _) = showsSpecialIdent "as"+ showsPrec _ (Token Id_ccall _) = showsSpecialIdent "ccall"+ showsPrec _ (Token Id_forall _) = showsSpecialIdent "forall"+ showsPrec _ (Token Id_hiding _) = showsSpecialIdent "hiding"+ showsPrec _ (Token Id_interface _) = showsSpecialIdent "interface"+ showsPrec _ (Token Id_primitive _) = showsSpecialIdent "primitive"+ showsPrec _ (Token Id_qualified _) = showsSpecialIdent "qualified"+ showsPrec _ (Token PragmaLanguage _) = showString "{-# LANGUAGE"+ showsPrec _ (Token PragmaOptions a) = showString "{-# OPTIONS"+ . shows a+ showsPrec _ (Token PragmaHiding _) = showString "{-# HIDING"+ showsPrec _ (Token PragmaMethod _) = showString "{-# METHOD"+ showsPrec _ (Token PragmaModule _) = showString "{-# MODULE"+ showsPrec _ (Token PragmaEnd _) = showString "#-}"+ showsPrec _ (Token LineComment a) = shows a+ showsPrec _ (Token NestedComment a) = shows a+ showsPrec _ (Token EOF _) = showString "<end-of-file>"++-- ---------------------------------------------------------------------------+-- The following functions can be used to construct tokens with+-- specific attributes.+-- ---------------------------------------------------------------------------++-- |Construct a simple 'Token' without 'Attributes'+tok :: Category -> Token+tok t = Token t NoAttributes++-- |Construct a 'Token' for a single 'Char'+charTok :: Char -> String -> Token+charTok c o = Token CharTok CharAttributes { cval = c, original = o }++-- |Construct a 'Token' for an int value+intTok :: Integer -> String -> Token+intTok base digits = Token IntTok IntAttributes+ { ival = convertIntegral base digits, original = digits }++-- |Construct a 'Token' for a float value+floatTok :: String -> String -> Int -> String -> Token+floatTok mant frac expo rest = Token FloatTok FloatAttributes+ { fval = convertFloating mant frac expo+ , original = mant ++ "." ++ frac ++ rest }++-- |Construct a 'Token' for a string value+stringTok :: String -> String -> Token+stringTok cs s = Token StringTok StringAttributes { sval = cs, original = s }++-- |Construct a 'Token' for identifiers+idTok :: Category -> [String] -> String -> Token+idTok t mIdent ident = Token t+ IdentAttributes { modulVal = mIdent, sval = ident }++-- TODO+pragmaOptionsTok :: Maybe String -> String -> Token+pragmaOptionsTok mbTool s = Token PragmaOptions+ OptionsAttributes { toolVal = mbTool, toolArgs = s }++-- |Construct a 'Token' for a line comment+lineCommentTok :: String -> Token+lineCommentTok s = Token LineComment+ StringAttributes { sval = s, original = s }++-- |Construct a 'Token' for a nested comment+nestedCommentTok :: String -> Token+nestedCommentTok s = Token NestedComment+ StringAttributes { sval = s, original = s }++-- ---------------------------------------------------------------------------+-- Tables for reserved operators and identifiers+-- ---------------------------------------------------------------------------++-- |Map of reserved operators+reservedOps:: Map.Map String Category+reservedOps = Map.fromList+ [ ("@" , At )+ , (":" , Colon )+ , ("=>", DoubleArrow)+ , ("::", DoubleColon)+ , ("..", DotDot )+ , ("=" , Equals )+ , ("\\", Backslash )+ , ("|" , Bar )+ , ("<-", LeftArrow )+ , ("->", RightArrow )+ , ("~" , Tilde )+ ]++-- |Map of reserved and special operators+reservedSpecialOps :: Map.Map String Category+reservedSpecialOps = Map.union reservedOps $ Map.fromList+ [ ("." , SymDot )+ , ("-" , SymMinus )+ , ("*" , SymStar )+ ]++-- |Map of keywords+keywords :: Map.Map String Category+keywords = Map.fromList+ [ ("case" , KW_case )+ , ("class" , KW_class )+ , ("data" , KW_data )+ , ("default" , KW_default )+ , ("deriving", KW_deriving)+ , ("do" , KW_do )+ , ("else" , KW_else )+ , ("external", KW_external)+ , ("fcase" , KW_fcase )+ , ("free" , KW_free )+ , ("if" , KW_if )+ , ("import" , KW_import )+ , ("in" , KW_in )+ , ("infix" , KW_infix )+ , ("infixl" , KW_infixl )+ , ("infixr" , KW_infixr )+ , ("instance", KW_instance)+ , ("let" , KW_let )+ , ("module" , KW_module )+ , ("newtype" , KW_newtype )+ , ("of" , KW_of )+ , ("then" , KW_then )+ , ("type" , KW_type )+ , ("where" , KW_where )+ ]++-- |Map of keywords and special identifiers+keywordsSpecialIds :: Map.Map String Category+keywordsSpecialIds = Map.union keywords $ Map.fromList+ [ ("as" , Id_as )+ , ("ccall" , Id_ccall )+ , ("forall" , Id_forall )+ , ("hiding" , Id_hiding )+ , ("interface", Id_interface)+ , ("primitive", Id_primitive)+ , ("qualified", Id_qualified)+ ]++pragmas :: Map.Map String Category+pragmas = Map.fromList+ [ ("language", PragmaLanguage)+ , ("options" , PragmaOptions )+ , ("hiding" , PragmaHiding )+ , ("method" , PragmaMethod )+ , ("module" , PragmaModule )+ ]+++-- ---------------------------------------------------------------------------+-- Character classes+-- ---------------------------------------------------------------------------++-- |Check whether a 'Char' is allowed for identifiers+isIdentChar :: Char -> Bool+isIdentChar c = isAlphaNum c || c `elem` "'_"++-- |Check whether a 'Char' is allowed for symbols+isSymbolChar :: Char -> Bool+isSymbolChar c = c `elem` "~!@#$%^&*+-=<>:?./|\\"++-- ---------------------------------------------------------------------------+-- Lexing functions+-- ---------------------------------------------------------------------------++-- |Lex source code+lexSource :: FilePath -> String -> CYM [(Span, Token)]+lexSource = parse (applyLexer fullLexer)++-- |CPS-Lexer for Curry+lexer :: Lexer Token a+lexer = skipWhiteSpace True -- skip comments++-- |CPS-Lexer for Curry which also lexes comments.+-- This lexer is useful for documentation tools.+fullLexer :: Lexer Token a+fullLexer = skipWhiteSpace False -- lex comments++-- |Lex the source code and skip whitespaces+skipWhiteSpace :: Bool -> Lexer Token a+skipWhiteSpace skipComments suc fail = skip+ where+ skip sp [] bol = suc sp (tok EOF) sp [] bol+ skip sp c@('-':'-':_) _ = lexLineComment sucComment fail sp c True+ skip sp c@('{':'-':'#':_) bol = lexPragma noPragma suc fail sp c bol+ skip sp c@('{':'-':_) bol = lexNestedComment sucComment fail sp c bol+ skip sp cs@(c:s) bol+ | c == '\t' = warnP sp "Tab character" skip (tabSpan sp) s bol+ | c == '\n' = skip (nlSpan sp) s True+ | isSpace c = skip (nextSpan sp) s bol+ | bol = lexBOL suc fail sp cs bol+ | otherwise = lexToken suc fail sp cs bol+ sucComment = if skipComments then (\ _suc _fail -> skip) else suc+ noPragma = lexNestedComment sucComment fail++-- Lex a line comment+lexLineComment :: Lexer Token a+lexLineComment suc _ sp str = case break (== '\n') str of+ (c, s ) -> suc sp (lineCommentTok c) (incrSpan sp $ length c) s++lexPragma :: P a -> Lexer Token a+lexPragma noPragma suc fail sp0 str = pragma (incrSpan sp0 3) (drop 3 str)+ where+ skip = noPragma sp0 str+ pragma sp [] = fail sp0 "Unterminated pragma" sp []+ pragma sp cs@(c : s)+ | c == '\t' = pragma (tabSpan sp) s+ | c == '\n' = pragma (nlSpan sp) s+ | isSpace c = pragma (nextSpan sp) s+ | isAlpha c = case Map.lookup (map toLower prag) pragmas of+ Nothing -> skip+ Just PragmaOptions -> lexOptionsPragma sp0 suc fail sp1 rest+ Just t -> suc sp0 (tok t) sp1 rest+ | otherwise = skip+ where+ (prag, rest) = span isAlphaNum cs+ sp1 = incrSpan sp (length prag)++lexOptionsPragma :: Span -> Lexer Token a+lexOptionsPragma sp0 _ fail sp [] = fail sp0 "Unterminated Options pragma" sp []+lexOptionsPragma sp0 suc fail sp (c : s)+ | c == '\t' = lexArgs Nothing (tabSpan sp) s+ | c == '\n' = lexArgs Nothing (nlSpan sp) s+ | isSpace c = lexArgs Nothing (nextSpan sp) s+ | c == '_' = let (tool, s1) = span isIdentChar s+ in lexArgs (Just tool) (incrSpan sp (length tool + 1)) s1+ | otherwise = fail sp0 "Malformed Options pragma" sp s+ where+ lexArgs mbTool = lexRaw ""+ where+ lexRaw s0 sp1 r = case hash of+ [] -> fail sp0 "End-of-file inside pragma" (incrSpan sp1 len) []+ '#':'-':'}':_ -> token (trim $ s0 ++ opts) (incrSpan sp1 len) hash+ _ -> lexRaw (s0 ++ opts ++ "#") (incrSpan sp1 (len + 1)) (drop 1 hash)+ where+ (opts, hash) = span (/= '#') r+ len = length opts+ token = suc sp0 . pragmaOptionsTok mbTool+ trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace++-- Lex a nested comment+lexNestedComment :: Lexer Token a+lexNestedComment suc fail sp0 = lnc (0 :: Integer) id sp0+ where+ -- d : nesting depth+ -- comm: comment already lexed as functional list+ lnc d comm sp str = case (d, str) of+ (_, []) -> fail sp0 "Unterminated nested comment" sp []+ (1, '-':'}':s) -> suc sp0 (nestedCommentTok (comm "-}")) (incrSpan sp 2) s+ (_, '{':'-':s) -> cont (d+1) ("{-" ++) (incrSpan sp 2) s+ (_, '-':'}':s) -> cont (d-1) ("-}" ++) (incrSpan sp 2) s+ (_, c@'\t' :s) -> cont d (c:) (tabSpan sp) s+ (_, c@'\n' :s) -> cont d (c:) (nlSpan sp) s+ (_, c :s) -> cont d (c:) (nextSpan sp) s+ where cont d' comm' = lnc d' (comm . comm')++-- Lex tokens at the beginning of a line, managing layout.+lexBOL :: Lexer Token a+lexBOL suc fail sp s _ [] = lexToken suc fail sp s False []+lexBOL suc fail sp s _ ctxt@(n:rest)+ | col < n = suc sp (tok VRightBrace) sp s True rest+ | col == n = lexSemiOrWhere suc fail sp s False ctxt+ | otherwise = lexToken suc fail sp s False ctxt+ where col = column (span2Pos sp)++lexSemiOrWhere :: Lexer Token a+lexSemiOrWhere suc _ sp ('w':'h':'e':'r':'e':s@(c:_))+ | not (isIdentChar c) = suc sp (tok KW_where) sp s+lexSemiOrWhere suc _ sp s = suc sp (tok VSemicolon) sp s++-- Lex a single 'Token'+lexToken :: Lexer Token a+lexToken suc _ sp [] = suc sp (tok EOF) sp []+lexToken suc fail sp cs@(c:s)+ | take 3 cs == "#-}" = suc sp (tok PragmaEnd) (incrSpan sp 3) (drop 3 cs)+ | c == '(' = token LeftParen+ | c == ')' = token RightParen+ | c == ',' = token Comma+ | c == ';' = token Semicolon+ | c == '[' = token LeftBracket+ | c == ']' = token RightBracket+ | c == '_' = token Underscore+ | c == '`' = token Backquote+ | c == '{' = token LeftBrace+ | c == '}' = lexRightBrace (suc sp) (nextSpan sp) s+ | c == '\'' = lexChar sp suc fail (nextSpan sp) s+ | c == '\"' = lexString sp suc fail (nextSpan sp) s+ | isAlpha c = lexIdent (suc sp) sp cs+ | isSymbolChar c = lexSymbol (suc sp) sp cs+ | isDigit c = lexNumber (suc sp) sp cs+ | otherwise = fail sp ("Illegal character " ++ show c) sp s+ where token t = suc sp (tok t) (nextSpan sp) s++-- Lex a right brace and pop from the context stack+lexRightBrace :: (Token -> P a) -> P a+lexRightBrace cont sp s bol ctxt = cont (tok RightBrace) sp s bol (drop 1 ctxt)++-- Lex an identifier+lexIdent :: (Token -> P a) -> P a+lexIdent cont sp s = maybe (lexOptQual cont (token Id) [ident]) (cont . token)+ (Map.lookup ident keywordsSpecialIds)+ (incrSpan sp $ length ident) rest+ where (ident, rest) = span isIdentChar s+ token t = idTok t [] ident++-- Lex a symbol+lexSymbol :: (Token -> P a) -> P a+lexSymbol cont sp s = cont+ (idTok (Map.findWithDefault Sym sym reservedSpecialOps) [] sym)+ (incrSpan sp $ length sym) rest+ where (sym, rest) = span isSymbolChar s++-- Lex an optionally qualified entity (identifier or symbol).+lexOptQual :: (Token -> P a) -> Token -> [String] -> P a+lexOptQual cont token mIdent sp cs@('.':c:s)+ | isAlpha c = lexQualIdent cont identCont mIdent+ (nextSpan sp) (c:s)+ | isSymbolChar c && c /= '.' = lexQualSymbol cont identCont mIdent+ (nextSpan sp) (c:s)+-- | c `elem` ":[(" = lexQualPrimitive cont token mIdent (nextSpan sp) (c:s)+ where identCont _ _ = cont token sp cs+lexOptQual cont token mIdent sp cs@('.':'.':c:s)+ | isSymbolChar c = lexQualSymbol cont identCont mIdent+ (nextSpan sp) ('.':c:s)+ | not $ isIdentChar c = lexQualSymbol cont identCont mIdent+ (nextSpan sp) ('.':c:s)+ where identCont _ _ = cont token sp cs+lexOptQual cont token _ sp cs = cont token sp cs++-- Lex a qualified identifier.+lexQualIdent :: (Token -> P a) -> P a -> [String] -> P a+lexQualIdent cont identCont mIdent sp s =+ maybe (lexOptQual cont (idTok QId mIdent ident) (mIdent ++ [ident]))+ (const identCont)+ (Map.lookup ident keywords)+ (incrSpan sp (length ident)) rest+ where (ident, rest) = span isIdentChar s++-- Lex a qualified symbol.+lexQualSymbol :: (Token -> P a) -> P a -> [String] -> P a+lexQualSymbol cont identCont mIdent sp s =+ maybe (cont (idTok QSym mIdent sym)) (const identCont)+ (Map.lookup sym reservedOps)+ (incrSpan sp (length sym)) rest+ where (sym, rest) = span isSymbolChar s++-- ---------------------------------------------------------------------------+-- /Note:/ since Curry allows an unlimited range of integer numbers,+-- read numbers must be converted to Haskell type 'Integer'.+-- ---------------------------------------------------------------------------++-- Lex a numeric literal.+lexNumber :: (Token -> P a) -> P a+lexNumber cont sp ('0':c:s)+ | c `elem` "bB" = lexBinary cont nullCont (incrSpan sp 2) s+ | c `elem` "oO" = lexOctal cont nullCont (incrSpan sp 2) s+ | c `elem` "xX" = lexHexadecimal cont nullCont (incrSpan sp 2) s+ where nullCont _ _ = cont (intTok 10 "0") (nextSpan sp) (c:s)+lexNumber cont sp s = lexOptFraction cont (intTok 10 digits) digits+ (incrSpan sp $ length digits) rest+ where (digits, rest) = span isDigit s++-- Lex a binary literal.+lexBinary :: (Token -> P a) -> P a -> P a+lexBinary cont nullCont sp s+ | null digits = nullCont undefined undefined+ | otherwise = cont (intTok 2 digits) (incrSpan sp $ length digits) rest+ where (digits, rest) = span isBinDigit s+ isBinDigit c = c >= '0' && c <= '1'++-- Lex an octal literal.+lexOctal :: (Token -> P a) -> P a -> P a+lexOctal cont nullCont sp s+ | null digits = nullCont undefined undefined+ | otherwise = cont (intTok 8 digits) (incrSpan sp $ length digits) rest+ where (digits, rest) = span isOctDigit s++-- Lex a hexadecimal literal.+lexHexadecimal :: (Token -> P a) -> P a -> P a+lexHexadecimal cont nullCont sp s+ | null digits = nullCont undefined undefined+ | otherwise = cont (intTok 16 digits) (incrSpan sp $ length digits) rest+ where (digits, rest) = span isHexDigit s++-- Lex an optional fractional part (float literal).+lexOptFraction :: (Token -> P a) -> Token -> String -> P a+lexOptFraction cont _ mant sp ('.':c:s)+ | isDigit c = lexOptExponent cont (floatTok mant frac 0 "") mant frac+ (incrSpan sp (length frac+1)) rest+ where (frac,rest) = span isDigit (c:s)+lexOptFraction cont token mant sp (c:s)+ | c `elem` "eE" = lexSignedExponent cont intCont mant "" [c] (nextSpan sp) s+ where intCont _ _ = cont token sp (c:s)+lexOptFraction cont token _ sp s = cont token sp s++-- Lex an optional exponent (float literal).+lexOptExponent :: (Token -> P a) -> Token -> String -> String -> P a+lexOptExponent cont token mant frac sp (c:s)+ | c `elem` "eE" = lexSignedExponent cont floatCont mant frac [c] (nextSpan sp) s+ where floatCont _ _ = cont token sp (c:s)+lexOptExponent cont token _ _ sp s = cont token sp s++-- Lex an exponent with sign (float literal).+lexSignedExponent :: (Token -> P a) -> P a -> String -> String -> String+ -> P a+lexSignedExponent cont floatCont mant frac e sp str = case str of+ ('+':c:s) | isDigit c -> lexExpo (e ++ "+") id (nextSpan sp) (c:s)+ ('-':c:s) | isDigit c -> lexExpo (e ++ "-") negate (nextSpan sp) (c:s)+ (c:_) | isDigit c -> lexExpo e id sp str+ _ -> floatCont sp str+ where lexExpo = lexExponent cont mant frac++-- Lex an exponent without sign (float literal).+lexExponent :: (Token -> P a) -> String -> String -> String -> (Int -> Int)+ -> P a+lexExponent cont mant frac e expSign sp s =+ cont (floatTok mant frac expo (e ++ digits)) (incrSpan sp $ length digits) rest+ where (digits, rest) = span isDigit s+ expo = expSign (convertIntegral 10 digits)++-- Lex a character literal.+lexChar :: Span -> Lexer Token a+lexChar sp0 _ fail sp [] = fail sp0 "Illegal character constant" sp []+lexChar sp0 success fail sp (c:s)+ | c == '\\' = lexEscape sp (\d o -> lexCharEnd d o sp0 success fail)+ fail (nextSpan sp) s+ | c == '\n' = fail sp0 "Illegal character constant" sp (c:s)+ | c == '\t' = lexCharEnd c "\t" sp0 success fail (tabSpan sp) s+ | otherwise = lexCharEnd c [c] sp0 success fail (nextSpan sp) s++-- Lex the end of a character literal.+lexCharEnd :: Char -> String -> Span -> Lexer Token a+lexCharEnd c o sp0 suc _ sp ('\'':s) = suc sp0 (charTok c o) (nextSpan sp) s+lexCharEnd _ _ sp0 _ fail sp s =+ fail sp0 "Improperly terminated character constant" sp s++-- Lex a String literal.+lexString :: Span -> Lexer Token a+lexString sp0 suc fail = lexStringRest "" id+ where+ lexStringRest _ _ sp [] = improperTermination sp+ lexStringRest s0 so sp (c:s)+ | c == '\n' = improperTermination sp+ | c == '\"' = suc sp0 (stringTok (reverse s0) (so "")) (nextSpan sp) s+ | c == '\\' = lexStringEscape sp s0 so lexStringRest fail (nextSpan sp) s+ | c == '\t' = lexStringRest (c:s0) (so . (c:)) (tabSpan sp) s+ | otherwise = lexStringRest (c:s0) (so . (c:)) (nextSpan sp) s+ improperTermination sp = fail sp0 "Improperly terminated string constant" sp []++-- Lex an escaped character inside a string.+lexStringEscape :: Span -> String -> (String -> String)+ -> (String -> (String -> String) -> P a)+ -> FailP a -> P a+lexStringEscape sp0 _ _ _ fail sp [] = lexEscape sp0 undefined fail sp []+lexStringEscape sp0 s0 so suc fail sp cs@(c:s)+ -- The escape sequence represents an empty character of length zero+ | c == '&' = suc s0 (so . ("\\&" ++)) (nextSpan sp) s+ | isSpace c = lexStringGap so (suc s0) fail sp cs+ | otherwise = lexEscape sp0 (\ c' s' -> suc (c': s0) (so . (s' ++))) fail sp cs++-- Lex a string gap.+lexStringGap :: (String -> String) -> ((String -> String) -> P a)+ -> FailP a -> P a+lexStringGap _ _ fail sp [] = fail sp "End-of-file in string gap" sp []+lexStringGap so suc fail sp (c:s)+ | c == '\\' = suc (so . (c:)) (nextSpan sp) s+ | c == '\t' = lexStringGap (so . (c:)) suc fail (tabSpan sp) s+ | c == '\n' = lexStringGap (so . (c:)) suc fail (nlSpan sp) s+ | isSpace c = lexStringGap (so . (c:)) suc fail (nextSpan sp) s+ | otherwise = fail sp ("Illegal character in string gap: " ++ show c) sp s++-- Lex an escaped character.+lexEscape :: Span -> (Char -> String -> P a) -> FailP a -> P a+lexEscape sp0 suc fail sp str = case str of+ -- character escape+ ('a' :s) -> suc '\a' "\\a" (nextSpan sp) s+ ('b' :s) -> suc '\b' "\\b" (nextSpan sp) s+ ('f' :s) -> suc '\f' "\\f" (nextSpan sp) s+ ('n' :s) -> suc '\n' "\\n" (nextSpan sp) s+ ('r' :s) -> suc '\r' "\\r" (nextSpan sp) s+ ('t' :s) -> suc '\t' "\\t" (nextSpan sp) s+ ('v' :s) -> suc '\v' "\\v" (nextSpan sp) s+ ('\\':s) -> suc '\\' "\\\\" (nextSpan sp) s+ ('"' :s) -> suc '\"' "\\\"" (nextSpan sp) s+ ('\'':s) -> suc '\'' "\\\'" (nextSpan sp) s+ -- control characters+ ('^':c:s) | isControlEsc c -> controlEsc c (incrSpan sp 2) s+ -- numeric escape+ ('o':c:s) | isOctDigit c -> numEsc 8 isOctDigit ("\\o" ++) (nextSpan sp) (c:s)+ ('x':c:s) | isHexDigit c -> numEsc 16 isHexDigit ("\\x" ++) (nextSpan sp) (c:s)+ (c:s) | isDigit c -> numEsc 10 isDigit ("\\" ++) sp (c:s)+ -- ascii escape+ _ -> asciiEscape sp0 suc fail sp str+ where numEsc = numEscape sp0 suc fail+ controlEsc c = suc (chr (ord c `mod` 32)) ("\\^" ++ [c])+ isControlEsc c = isUpper c || c `elem` "@[\\]^_"++numEscape :: Span -> (Char -> String -> P a) -> FailP a -> Int+ -> (Char -> Bool) -> (String -> String) -> P a+numEscape sp0 suc fail b isDigit' so sp s+ | n >= ord minBound && n <= ord maxBound+ = suc (chr n) (so digits) (incrSpan sp $ length digits) rest+ | otherwise+ = fail sp0 "Numeric escape out-of-range" sp s+ where (digits, rest) = span isDigit' s+ n = convertIntegral b digits++asciiEscape :: Span -> (Char -> String -> P a) -> FailP a -> P a+asciiEscape sp0 suc fail sp str = case str of+ ('N':'U':'L':s) -> suc '\NUL' "\\NUL" (incrSpan sp 3) s+ ('S':'O':'H':s) -> suc '\SOH' "\\SOH" (incrSpan sp 3) s+ ('S':'T':'X':s) -> suc '\STX' "\\STX" (incrSpan sp 3) s+ ('E':'T':'X':s) -> suc '\ETX' "\\ETX" (incrSpan sp 3) s+ ('E':'O':'T':s) -> suc '\EOT' "\\EOT" (incrSpan sp 3) s+ ('E':'N':'Q':s) -> suc '\ENQ' "\\ENQ" (incrSpan sp 3) s+ ('A':'C':'K':s) -> suc '\ACK' "\\ACK" (incrSpan sp 3) s+ ('B':'E':'L':s) -> suc '\BEL' "\\BEL" (incrSpan sp 3) s+ ('B':'S' :s) -> suc '\BS' "\\BS" (incrSpan sp 2) s+ ('H':'T' :s) -> suc '\HT' "\\HT" (incrSpan sp 2) s+ ('L':'F' :s) -> suc '\LF' "\\LF" (incrSpan sp 2) s+ ('V':'T' :s) -> suc '\VT' "\\VT" (incrSpan sp 2) s+ ('F':'F' :s) -> suc '\FF' "\\FF" (incrSpan sp 2) s+ ('C':'R' :s) -> suc '\CR' "\\CR" (incrSpan sp 2) s+ ('S':'O' :s) -> suc '\SO' "\\SO" (incrSpan sp 2) s+ ('S':'I' :s) -> suc '\SI' "\\SI" (incrSpan sp 2) s+ ('D':'L':'E':s) -> suc '\DLE' "\\DLE" (incrSpan sp 3) s+ ('D':'C':'1':s) -> suc '\DC1' "\\DC1" (incrSpan sp 3) s+ ('D':'C':'2':s) -> suc '\DC2' "\\DC2" (incrSpan sp 3) s+ ('D':'C':'3':s) -> suc '\DC3' "\\DC3" (incrSpan sp 3) s+ ('D':'C':'4':s) -> suc '\DC4' "\\DC4" (incrSpan sp 3) s+ ('N':'A':'K':s) -> suc '\NAK' "\\NAK" (incrSpan sp 3) s+ ('S':'Y':'N':s) -> suc '\SYN' "\\SYN" (incrSpan sp 3) s+ ('E':'T':'B':s) -> suc '\ETB' "\\ETB" (incrSpan sp 3) s+ ('C':'A':'N':s) -> suc '\CAN' "\\CAN" (incrSpan sp 3) s+ ('E':'M' :s) -> suc '\EM' "\\EM" (incrSpan sp 2) s+ ('S':'U':'B':s) -> suc '\SUB' "\\SUB" (incrSpan sp 3) s+ ('E':'S':'C':s) -> suc '\ESC' "\\ESC" (incrSpan sp 3) s+ ('F':'S' :s) -> suc '\FS' "\\FS" (incrSpan sp 2) s+ ('G':'S' :s) -> suc '\GS' "\\GS" (incrSpan sp 2) s+ ('R':'S' :s) -> suc '\RS' "\\RS" (incrSpan sp 2) s+ ('U':'S' :s) -> suc '\US' "\\US" (incrSpan sp 2) s+ ('S':'P' :s) -> suc '\SP' "\\SP" (incrSpan sp 2) s+ ('D':'E':'L':s) -> suc '\DEL' "\\DEL" (incrSpan sp 3) s+ s -> fail sp0 "Illegal escape sequence" sp s
+ src/Curry/Syntax/Parser.hs view
@@ -0,0 +1,1428 @@+{- |+ Module : $Header$+ Description : A Parser for Curry+ Copyright : (c) 1999 - 2004 Wolfgang Lux+ 2005 Martin Engelke+ 2011 - 2015 Björn Peemöller+ 2016 - 2017 Finn Teegen+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ The Curry parser is implemented using the (mostly) LL(1) parsing+ combinators implemented in 'Curry.Base.LLParseComb'.+-}+module Curry.Syntax.Parser+ ( parseSource, parseHeader, parsePragmas, parseInterface, parseGoal+ ) where++import Curry.Base.Ident+import Curry.Base.Monad (CYM)+import Curry.Base.Position (Position(..), getPosition, setPosition, incr)+import Curry.Base.LLParseComb+import Curry.Base.Span hiding (file) -- clash with Position.file+import Curry.Base.SpanInfo++import Curry.Syntax.Extension+import Curry.Syntax.Lexer (Token (..), Category (..), Attributes (..), lexer)+import Curry.Syntax.Type++-- |Parse a 'Module'+parseSource :: FilePath -> String -> CYM (Module ())+parseSource = fullParser (mkMod <$> moduleHeader <*> layout moduleDecls) lexer+ where mkMod f ((im, ds), lay) = f lay im ds++-- |Parse only pragmas of a 'Module'+parsePragmas :: FilePath -> String -> CYM (Module ())+parsePragmas+ = prefixParser ((\ps sp -> setEndPosition NoPos+ (Module (spanInfo sp []) WhitespaceLayout+ ps mainMIdent Nothing [] []))+ <$> modulePragmas <*> spanPosition)+ lexer++-- |Parse a 'Module' header+parseHeader :: FilePath -> String -> CYM (Module ())+parseHeader = prefixParser+ (mkMod <$> moduleHeader <*> startLayout importDecls) lexer+ where+ importDecls = mkImport <$> many ((,) <$> importDecl+ <*> many (spanPosition <*-> semicolon))+ mkImport xs = let (im, spss) = unzip xs in (im, concat spss)+ mkMod f (im, lay) = f lay im []++-- |Parse an 'Interface'+parseInterface :: FilePath -> String -> CYM Interface+parseInterface = fullParser interface lexer++-- |Parse a 'Goal'+parseGoal :: String -> CYM (Goal ())+parseGoal = fullParser goal lexer ""++-- ---------------------------------------------------------------------------+-- Module header+-- ---------------------------------------------------------------------------++-- |Parser for a module header+moduleHeader :: Parser a Token+ (LayoutInfo -> [ImportDecl] -> [Decl b] -> Module b)+moduleHeader =+ (\sp ps (m, es, inf) lay is ds -> updateEndPos $+ Module (spanInfo sp inf) lay ps m es is ds)+ <$> spanPosition+ <*> modulePragmas+ <*> header+ where header = (\sp1 m es sp2 -> (m, es, [sp1,sp2]))+ <$> tokenSpan KW_module+ <*> modIdent+ <*> option exportSpec+ <*> spanPosition+ <*-> expectWhere+ `opt` (mainMIdent, Nothing, [])++modulePragmas :: Parser a Token [ModulePragma]+modulePragmas = many (languagePragma <|> optionsPragma)++languagePragma :: Parser a Token ModulePragma+languagePragma = languagePragma'+ <$> tokenSpan PragmaLanguage+ <*> (languageExtension `sepBy1Sp` comma)+ <*> tokenSpan PragmaEnd+ where languageExtension = classifyExtension <$> ident+ languagePragma' sp1 (ex, ss) sp2 = updateEndPos $+ LanguagePragma (spanInfo sp1 (sp1 : ss ++ [sp2])) ex++-- TODO The span info is not 100% complete due to the lexer+-- combining OPTIONS, toolVal and toolArgs+optionsPragma :: Parser a Token ModulePragma+optionsPragma = optionsPragma'+ <$> spanPosition+ <*> token PragmaOptions+ <*> tokenSpan PragmaEnd+ where optionsPragma' sp1 a sp2 = updateEndPos $+ OptionsPragma (spanInfo sp1 [sp1, sp2])+ (classifyTool <$> toolVal a)+ (toolArgs a)++-- |Parser for an export specification+exportSpec :: Parser a Token ExportSpec+exportSpec = exportSpec' <$> spanPosition <*> parensSp (export `sepBySp` comma)+ where exportSpec' sp1 ((ex, ss),sp2,sp3) = updateEndPos $+ Exporting (spanInfo sp1 (sp2:(ss ++ [sp3]))) ex++-- |Parser for an export item+export :: Parser a Token Export+export = qtycon <**> (tcExportWith <$> parensSp spec `opt` tcExport)+ <|> tcExport <$> qfun <\> qtycon+ <|> exportModule' <$> tokenSpan KW_module <*> modIdent+ where spec = (\sp -> (ExportTypeAll , [sp])) <$> tokenSpan DotDot+ <|> (\(c, ss) -> (exportTypeWith' c, ss )) <$> con `sepBySp` comma+ tcExport qtc = updateEndPos $ Export (fromSrcSpan (getSrcSpan qtc)) qtc+ tcExportWith ((spc, ss), sp1, sp2) qtc =+ updateEndPos $ setSrcInfoPoints (sp1 : (ss ++ [sp2])) $+ spc (fromSrcSpan (getSrcSpan qtc)) qtc+ exportTypeWith' c spi qtc = ExportTypeWith spi qtc c+ exportModule' sp = updateEndPos . ExportModule (spanInfo sp [sp])++moduleDecls :: Parser a Token (([ImportDecl], [Decl ()]), [Span])+moduleDecls = mkImpDecl <$> importDecl+ <*> (moduleDecls' `opt` ([], [], []))+ <|> mkTopDecl <$> topDecls+ where+ mkImpDecl i (is, ds, sps) = ((i:is, ds), sps)+ mkTopDecl (ds, sps) = (([], ds), sps)++ moduleDecls' = mkDecls <$> spanPosition <*-> semicolon <*> moduleDecls+ mkDecls sp ((im, ds), sps) = (im, ds, sp:sps)++-- |Parser for a single import declaration+importDecl :: Parser a Token ImportDecl+importDecl = importDecl'+ <$> tokenSpan KW_import+ <*> option (tokenSpan Id_qualified)+ <*> modIdent+ <*> option ((,) <$> tokenSpan Id_as <*> modIdent)+ <*> option importSpec+ where+ importDecl' sp1 (Just sp2) mid (Just (sp3, alias)) = updateEndPos .+ ImportDecl (spanInfo sp1 [sp1, sp2, sp3]) mid True (Just alias)+ importDecl' sp1 Nothing mid (Just (sp3, alias)) = updateEndPos .+ ImportDecl (spanInfo sp1 [sp1, sp3]) mid False (Just alias)+ importDecl' sp1 (Just sp2) mid Nothing = updateEndPos .+ ImportDecl (spanInfo sp1 [sp1, sp2]) mid True Nothing+ importDecl' sp1 Nothing mid Nothing = updateEndPos .+ ImportDecl (spanInfo sp1 [sp1]) mid False Nothing++-- |Parser for an import specification+importSpec :: Parser a Token ImportSpec+importSpec = spanPosition+ <**> (hiding' <$-> token Id_hiding `opt` importing')+ <*> parensSp (importSp `sepBySp` comma)+ where+ hiding' sp1 ((specs, ss), sp2, sp3) = updateEndPos $+ Hiding (spanInfo sp1 (sp1 : sp2 : (ss ++ [sp3]))) specs+ importing' sp1 ((specs, ss), sp2, sp3) = updateEndPos $+ Importing (spanInfo sp1 ( sp2 : (ss ++ [sp3]))) specs++importSp :: Parser a Token Import+importSp = tycon <**> (tcImportWith <$> parensSp spec `opt` tcImport)+ <|> tcImport <$> fun <\> tycon+ where spec = (\sp -> (ImportTypeAll , [sp])) <$> tokenSpan DotDot+ <|> (\(c, ss) -> (importTypeWith' c, ss )) <$> con `sepBySp` comma+ tcImport tc = updateEndPos $ Import (fromSrcSpan (getSrcSpan tc)) tc+ tcImportWith ((spc, ss), sp1, sp2) tc =+ updateEndPos $ setSrcInfoPoints (sp1 : (ss ++ [sp2])) $+ spc (fromSrcSpan (getSrcSpan tc)) tc+ importTypeWith' c spi tc = ImportTypeWith spi tc c+-- ---------------------------------------------------------------------------+-- Interfaces+-- ---------------------------------------------------------------------------++-- |Parser for an interface+interface :: Parser a Token Interface+interface = uncurry <$> intfHeader <*> braces intfDecls++intfHeader :: Parser a Token ([IImportDecl] -> [IDecl] -> Interface)+intfHeader = Interface <$-> token Id_interface <*> modIdent <*-> expectWhere++intfDecls :: Parser a Token ([IImportDecl], [IDecl])+intfDecls = impDecl <$> iImportDecl+ <*> (semicolon <-*> intfDecls `opt` ([], []))+ <|> (,) [] <$> intfDecl `sepBy` semicolon+ where impDecl i (is, ds) = (i:is, ds)++-- |Parser for a single interface import declaration+iImportDecl :: Parser a Token IImportDecl+iImportDecl = IImportDecl <$> tokenPos KW_import <*> modIdent++-- |Parser for a single interface declaration+intfDecl :: Parser a Token IDecl+intfDecl = choice [ iInfixDecl, iHidingDecl, iDataDecl, iNewtypeDecl+ , iTypeDecl , iFunctionDecl <\> token Id_hiding+ , iClassDecl, iInstanceDecl ]++-- |Parser for an interface infix declaration+iInfixDecl :: Parser a Token IDecl+iInfixDecl = infixDeclLhs iInfixDecl' <*> integer <*> qfunop+ where iInfixDecl' sp = IInfixDecl (span2Pos sp)++-- |Parser for an interface hiding declaration+iHidingDecl :: Parser a Token IDecl+iHidingDecl = tokenPos Id_hiding <**> (hDataDecl <|> hClassDecl)+ where+ hDataDecl = hiddenData <$-> token KW_data <*> withKind qtycon <*> many tyvar+ hClassDecl = hiddenClass <$> classInstHead KW_class (withKind qtycls) clsvar+ hiddenData (tc, k) tvs p = HidingDataDecl p tc k tvs+ hiddenClass (_, _, cx, (qcls, k), tv) p = HidingClassDecl p cx qcls k tv++-- |Parser for an interface data declaration+iDataDecl :: Parser a Token IDecl+iDataDecl = iTypeDeclLhs IDataDecl KW_data <*> constrs <*> iHiddenPragma+ where constrs = equals <-*> constrDecl `sepBy1` bar `opt` []++-- |Parser for an interface newtype declaration+iNewtypeDecl :: Parser a Token IDecl+iNewtypeDecl = iTypeDeclLhs INewtypeDecl KW_newtype+ <*-> equals <*> newConstrDecl <*> iHiddenPragma++-- |Parser for an interface type synonym declaration+iTypeDecl :: Parser a Token IDecl+iTypeDecl = iTypeDeclLhs ITypeDecl KW_type+ <*-> equals <*> type0++-- |Parser for an interface hiding pragma+iHiddenPragma :: Parser a Token [Ident]+iHiddenPragma = token PragmaHiding+ <-*> (con `sepBy` comma)+ <*-> token PragmaEnd+ `opt` []++-- |Parser for an interface function declaration+iFunctionDecl :: Parser a Token IDecl+iFunctionDecl = IFunctionDecl <$> position <*> qfun <*> option iMethodPragma+ <*> arity <*-> token DoubleColon <*> qualType++-- |Parser for an interface method pragma+iMethodPragma :: Parser a Token Ident+iMethodPragma = token PragmaMethod <-*> clsvar <*-> token PragmaEnd++-- |Parser for function's arity+arity :: Parser a Token Int+arity = int `opt` 0++iTypeDeclLhs :: (Position -> QualIdent -> Maybe KindExpr -> [Ident] -> a)+ -> Category -> Parser b Token a+iTypeDeclLhs f kw = f' <$> tokenPos kw <*> withKind qtycon <*> many tyvar+ where f' p (tc, k) = f p tc k++-- |Parser for an interface class declaration+iClassDecl :: Parser a Token IDecl+iClassDecl = (\(sp, _, cx, (qcls, k), tv) ->+ IClassDecl (span2Pos sp) cx qcls k tv)+ <$> classInstHead KW_class (withKind qtycls) clsvar+ <*> braces (iMethod `sepBy` semicolon)+ <*> iClassHidden++-- |Parser for an interface method declaration+iMethod :: Parser a Token IMethodDecl+iMethod = IMethodDecl <$> position+ <*> fun <*> option int <*-> token DoubleColon <*> qualType++-- |Parser for an interface hiding pragma+iClassHidden :: Parser a Token [Ident]+iClassHidden = token PragmaHiding+ <-*> (fun `sepBy` comma)+ <*-> token PragmaEnd+ `opt` []++-- |Parser for an interface instance declaration+iInstanceDecl :: Parser a Token IDecl+iInstanceDecl = (\(sp, _, cx, qcls, inst) ->+ IInstanceDecl (span2Pos sp) cx qcls inst)+ <$> classInstHead KW_instance qtycls type2+ <*> braces (iImpl `sepBy` semicolon)+ <*> option iModulePragma++-- |Parser for an interface method implementation+iImpl :: Parser a Token IMethodImpl+iImpl = (,) <$> fun <*> arity++iModulePragma :: Parser a Token ModuleIdent+iModulePragma = token PragmaModule <-*> modIdent <*-> token PragmaEnd++-- ---------------------------------------------------------------------------+-- Top-Level Declarations+-- ---------------------------------------------------------------------------++topDecls :: Parser a Token ([Decl ()], [Span])+topDecls = topDecl `sepBySp` semicolon++topDecl :: Parser a Token (Decl ())+topDecl = choice [ dataDecl, externalDataDecl, newtypeDecl, typeDecl+ , classDecl, instanceDecl, defaultDecl+ , infixDecl, functionDecl ]++dataDecl :: Parser a Token (Decl ())+dataDecl = combineWithSpans+ <$> typeDeclLhs dataDecl' KW_data+ <*> ((addSpan <$> tokenSpan Equals <*> constrs) `opt` ([],[]))+ <*> deriv+ where constrs = constrDecl `sepBy1Sp` bar+ dataDecl' sp = DataDecl (spanInfo sp [sp])++externalDataDecl :: Parser a Token (Decl ())+externalDataDecl = decl <$> tokenSpan KW_external <*> typeDeclLhs (,,) KW_data+ where decl sp1 (sp2, tc, tvs) = updateEndPos $+ ExternalDataDecl (spanInfo sp1 [sp1, sp2]) tc tvs++newtypeDecl :: Parser a Token (Decl ())+newtypeDecl = combineWithSpans+ <$> typeDeclLhs newtypeDecl' KW_newtype+ <*> ((\sp c -> (c, [sp])) <$> tokenSpan Equals <*> newConstrDecl)+ <*> deriv+ where newtypeDecl' sp = NewtypeDecl (spanInfo sp [sp])++combineWithSpans :: HasSpanInfo a =>+ (t1 -> t2 -> a) -> (t1, [Span]) -> (t2, [Span]) -> a+combineWithSpans df (cs, sps1) (cls, sps2)+ = updateEndPos $ setSrcInfoPoints (getSrcInfoPoints res ++ sps1 ++ sps2) res+ where res = df cs cls++typeDecl :: Parser a Token (Decl ())+typeDecl = typeDeclLhs typeDecl' KW_type <*> tokenSpan Equals <*> type0+ where typeDecl' sp1 tyc tyv sp2 txp = updateEndPos $+ TypeDecl (spanInfo sp1 [sp1, sp2]) tyc tyv txp++typeDeclLhs :: (Span -> Ident -> [Ident] -> a) -> Category+ -> Parser b Token a+typeDeclLhs f kw = f <$> tokenSpan kw <*> tycon <*> many anonOrTyvar++constrDecl :: Parser a Token ConstrDecl+constrDecl = spanPosition <**> constr+ where+ constr = conId <**> identDecl+ <|> tokenSpan LeftParen <**> parenDecl+ <|> type1 <\> conId <\> leftParen <**> opDecl+ identDecl = many type2 <**> (conType <$> opDecl `opt` conDecl)+ <|> recDecl <$> recFields+ parenDecl = conOpDeclPrefix+ <$> conSym <*> tokenSpan RightParen <*> type2 <*> type2+ <|> tupleType <**> (tokenSpan RightParen <**> opDeclParen)+ opDecl = conOpDecl <$> conop <*> type1+ opDeclParen = conOpDeclParen <$> conop <*> type1+ recFields = layoutOff <-*> bracesSp (fieldDecl `sepBySp` comma)+ conType f tys c = f $ foldl mkApply (mkConstructorType $ qualify c) tys+ mkApply t1 t2 = updateEndPos $ ApplyType (fromSrcSpan (getSrcSpan t1)) t1 t2+ mkConstructorType qid = ConstructorType (fromSrcSpan (getSrcSpan qid)) qid+ conDecl tys c sp = updateEndPos $+ ConstrDecl (SpanInfo sp []) c tys+ conOpDecl op ty2 ty1 sp = updateEndPos $+ ConOpDecl (SpanInfo sp []) ty1 op ty2+ conOpDeclParen op ty2 sp1 ty1 sp2 sp5 = updateEndPos $+ ConOpDecl (SpanInfo sp5 [sp2, sp1]) ty1 op ty2+ conOpDeclPrefix op sp1 ty1 ty2 sp2 sp3 = updateEndPos $+ ConOpDecl (SpanInfo sp3 [sp2, sp1]) ty1 op ty2+ recDecl ((fs, ss), sp1, sp2) c sp3 = updateEndPos $+ RecordDecl (SpanInfo sp3 (sp1 : ss ++ [sp2])) c fs++fieldDecl :: Parser a Token FieldDecl+fieldDecl = mkFieldDecl <$> spanPosition <*> labels+ <*> tokenSpan DoubleColon <*> type0+ where labels = fun `sepBy1Sp` comma+ mkFieldDecl sp1 (idt,ss) sp2 ty = updateEndPos $+ FieldDecl (spanInfo sp1 (ss ++ [sp2])) idt ty++newConstrDecl :: Parser a Token NewConstrDecl+newConstrDecl = spanPosition <**> (con <**> newConstr)+ where newConstr = newConDecl <$> type2+ <|> newRecDecl <$> newFieldDecl+ newConDecl ty c sp = updateEndPos $ NewConstrDecl (spanInfo sp []) c ty+ newRecDecl ((idt, sp2, ty), sp3, sp4) c sp1 = updateEndPos $+ NewRecordDecl (spanInfo sp1 [sp3,sp2,sp4]) c (idt, ty)++newFieldDecl :: Parser a Token ((Ident, Span, TypeExpr), Span, Span)+newFieldDecl = layoutOff <-*> bracesSp labelDecl+ where labelDecl = (,,) <$> fun <*> tokenSpan DoubleColon <*> type0++deriv :: Parser a Token ([QualIdent], [Span])+deriv = (addSpan <$> tokenSpan KW_deriving <*> classes) `opt` ([], [])+ where classes = ((\q -> ([q], [])) <$> qtycls)+ <|> ((\sp1 (qs, ss) sp2 -> (qs, sp1 : (ss ++ [sp2])))+ <$> tokenSpan LeftParen+ <*> (qtycls `sepBySp` comma)+ <*> tokenSpan RightParen)++functionDecl :: Parser a Token (Decl ())+functionDecl = spanPosition <**> decl+ where decl = fun `sepBy1Sp` comma <**> funListDecl <|?> funRule++funRule :: Parser a Token (Span -> Decl ())+funRule = mkFunDecl <$> lhs <*> declRhs+ where lhs = (\f ->+ (f, updateEndPos $ FunLhs (fromSrcSpan (getSrcSpan f)) f []))+ <$> fun <|?> funLhs++funListDecl :: Parser a Token (([Ident],[Span]) -> Span -> Decl ())+funListDecl = typeSig <|> mkExtFun <$> tokenSpan KW_external+ where mkExtFun sp1 (vs,ss) sp2 = updateEndPos $+ ExternalDecl (spanInfo sp2 (ss++[sp1])) (map (Var ()) vs)+++typeSig :: Parser a Token (([Ident],[Span]) -> Span -> Decl ())+typeSig = sig <$> tokenSpan DoubleColon <*> qualType+ where sig sp1 qty (vs,ss) sp2 = updateEndPos $+ TypeSig (spanInfo sp2 (ss++[sp1])) vs qty++mkFunDecl :: (Ident, Lhs ()) -> Rhs () -> Span -> Decl ()+mkFunDecl (f, lhs) rhs' p = updateEndPos $+ FunctionDecl (spanInfo p []) () f [updateEndPos $+ Equation (spanInfo p []) lhs rhs']++funLhs :: Parser a Token (Ident, Lhs ())+funLhs = mkFunLhs <$> fun <*> many1 pattern2+ <|?> flip ($ updateEndPos) <$> pattern1 <*> opLhs+ <|?> curriedLhs+ where+ opLhs = opLHS funSym (gConSym <\> funSym)+ <|> tokenSpan Backquote <**>+ opLHSSp ((,) <$> funId <*> spanPosition+ <*-> expectBackquote)+ ((,) <$> qConId <\> funId <*> spanPosition+ <*-> expectBackquote)+ opLHS funP consP = mkOpLhs <$> funP <*> pattern0+ <|> mkInfixPat <$> consP <*> pattern1 <*> opLhs+ opLHSSp funP consP = mkOpLhsSp <$> funP <*> pattern0+ <|> mkInfixPatSp <$> consP <*> pattern1 <*> opLhs+ mkFunLhs f ts = (f , updateEndPos $ FunLhs (fromSrcSpan (getSrcSpan f)) f ts)+ mkOpLhs op t2 f t1 =+ let t1' = f t1+ in (op, updateEndPos $ OpLhs (fromSrcSpan (getSrcSpan t1')) t1' op t2)+ mkInfixPat op t2 f g t1 =+ f (g . InfixPattern (fromSrcSpan (getSrcSpan t1)) () t1 op) t2+ mkOpLhsSp (op, sp1) t2 sp2 f t1 =+ let t1' = f t1+ in (op, updateEndPos $+ OpLhs (spanInfo (getSrcSpan t1') [sp2, sp1]) t1' op t2)++ mkInfixPatSp (op, sp1) t2 g sp2 f t1 =+ g (f . InfixPattern (spanInfo (getSrcSpan t1) [sp2, sp1]) () t1 op) t2+++curriedLhs :: Parser a Token (Ident, Lhs ())+curriedLhs = apLhs <$> parensSp funLhs <*> many1 pattern2+ where apLhs ((f, lhs), sp1, sp2) ts =+ let spi = fromSrcSpan sp1+ in (f, updateEndPos $ setSrcInfoPoints [sp1, sp2] $ ApLhs spi lhs ts)++declRhs :: Parser a Token (Rhs ())+declRhs = rhs equals++rhs :: Parser a Token b -> Parser a Token (Rhs ())+rhs eq = rhsExpr <*> localDecls+ where rhsExpr = mkSimpleRhs <$> spanPosition <*-> eq <*> expr+ <|> mkGuardedRhs <$> spanPosition <*> many1 (condExpr eq)+ mkSimpleRhs sp1 e (Just sp2, ds, li) = updateEndPos $+ SimpleRhs (SpanInfo sp1 [sp1, sp2]) li e ds+ mkSimpleRhs sp1 e (Nothing, ds, li) = updateEndPos $+ SimpleRhs (SpanInfo sp1 [sp1]) li e ds+ mkGuardedRhs sp1 ce (Just sp2, ds, li) = updateEndPos $+ GuardedRhs (SpanInfo sp1 [sp1, sp2]) li ce ds+ mkGuardedRhs sp1 ce (Nothing, ds, li) = updateEndPos $+ GuardedRhs (SpanInfo sp1 [sp1]) li ce ds++whereClause :: Parser a Token b -> Parser a Token (Maybe Span, [b], LayoutInfo)+whereClause decl = (\sp (ds, li) -> (Just sp, ds, li))+ <$> tokenSpan KW_where+ <*> layoutWhere decl `opt` (Nothing, [], WhitespaceLayout)++localDecls :: Parser a Token (Maybe Span, [Decl ()], LayoutInfo)+localDecls = whereClause valueOrInfixDecl++valueDecls :: Parser a Token ([Decl ()], [Span])+valueDecls = valueOrInfixDecl `sepBySp` semicolon++valueOrInfixDecl :: Parser a Token (Decl ())+valueOrInfixDecl = choice [infixDecl, valueDecl]++infixDecl :: Parser a Token (Decl ())+infixDecl = infixDeclLhs infixDecl'+ <*> option ((,) <$> spanPosition <*> integer)+ <*> funop `sepBy1Sp` comma+ where infixDecl' sp1 inf (Just (sp2, pr)) (ids, ss) =+ updateEndPos $ InfixDecl (spanInfo sp1 (sp1:sp2:ss)) inf (Just pr) ids+ infixDecl' sp1 inf Nothing (ids, ss) =+ updateEndPos $ InfixDecl (spanInfo sp1 (sp1 :ss)) inf Nothing ids++infixDeclLhs :: (Span -> Infix -> a) -> Parser b Token a+infixDeclLhs f = f <$> spanPosition <*> tokenOps infixKW+ where infixKW = [(KW_infix, Infix), (KW_infixl, InfixL), (KW_infixr, InfixR)]++valueDecl :: Parser a Token (Decl ())+valueDecl = spanPosition <**> decl+ where+ decl = var `sepBy1Sp` comma <**> valListDecl+ <|?> patOrFunDecl <$> pattern0 <*> declRhs+ <|?> mkFunDecl <$> curriedLhs <*> declRhs++ valListDecl = funListDecl+ <|> mkFree <$> tokenSpan KW_free+ where mkFree sp1 (vs, ss) sp2 = updateEndPos $+ FreeDecl (spanInfo sp2 (ss ++ [sp1])) (map (Var ()) vs)++ patOrFunDecl (ConstructorPattern spi _ c ts)+ | not (isConstrId c) = mkFunDecl (f, FunLhs spi f ts)+ where f = unqualify c+ patOrFunDecl t = patOrOpDecl updateEndPos t++ patOrOpDecl f (InfixPattern spi a t1 op t2)+ | isConstrId op = patOrOpDecl (f . InfixPattern spi a t1 op) t2+ | otherwise = mkFunDecl (op', updateEndPos $ OpLhs spi (f t1) op' t2)+ where op' = unqualify op+ patOrOpDecl f t = mkPatDecl (f t)++ mkPatDecl t rhs' sp = updateEndPos $ PatternDecl (fromSrcSpan sp) t rhs'++ isConstrId c = c == qConsId || isQualified c || isQTupleId c++defaultDecl :: Parser a Token (Decl ())+defaultDecl = mkDefaultDecl <$> tokenSpan KW_default+ <*> parensSp (type0 `sepBySp` comma)+ where mkDefaultDecl sp1 ((ty, ss), sp2, sp3) = updateEndPos $+ DefaultDecl (spanInfo sp1 (sp1 : sp2 : (ss ++ [sp3]))) ty++classInstHead :: Category -> Parser a Token b -> Parser a Token c+ -> Parser a Token (Span, [Span], Context, b, c)+classInstHead kw cls ty = f <$> tokenSpan kw+ <*> optContext (,,) ((,) <$> cls <*> ty)+ where f sp (cx, ss, (cls', ty')) = (sp, ss, cx, cls', ty')++classDecl :: Parser a Token (Decl ())+classDecl = mkClass+ <$> classInstHead KW_class tycls clsvar+ <*> whereClause innerDecl+ where+ --TODO: Refactor by left-factorization+ --TODO: Support infixDecl+ innerDecl = foldr1 (<|?>)+ [ spanPosition <**> (fun `sepBy1Sp` comma <**> typeSig)+ , spanPosition <**> funRule+ {-, infixDecl-} ]+ mkClass (sp1, ss, cx, cls, tv) (Just sp2, ds, li) = updateEndPos $+ ClassDecl (SpanInfo sp1 (sp1 : (ss ++ [sp2]))) li cx cls tv ds+ mkClass (sp1, ss, cx, cls, tv) (Nothing, ds, li) = updateEndPos $+ ClassDecl (SpanInfo sp1 (sp1 : ss)) li cx cls tv ds++instanceDecl :: Parser a Token (Decl ())+instanceDecl = mkInstance+ <$> classInstHead KW_instance qtycls type2+ <*> whereClause innerDecl+ where+ innerDecl = spanPosition <**> funRule+ mkInstance (sp1, ss, cx, qcls, inst) (Just sp2, ds, li) = updateEndPos $+ InstanceDecl (SpanInfo sp1 (sp1 : (ss ++ [sp2]))) li cx qcls inst ds+ mkInstance (sp1, ss, cx, qcls, inst) (Nothing, ds, li) = updateEndPos $+ InstanceDecl (SpanInfo sp1 (sp1 : ss)) li cx qcls inst ds+-- ---------------------------------------------------------------------------+-- Type classes+-- ---------------------------------------------------------------------------++optContext :: (Context -> [Span] -> a -> b)+ -> Parser c Token a+ -> Parser c Token b+optContext f p = combine <$> context <*> tokenSpan DoubleArrow <*> p+ <|?> f [] [] <$> p+ where combine (ctx, ss) sp = f ctx (ss ++ [sp])++context :: Parser a Token (Context, [Span])+context = (\c -> ([c], [])) <$> constraint+ <|> combine <$> parensSp (constraint `sepBySp` comma)+ where combine ((ctx, ss), sp1, sp2) = (ctx, sp1 : (ss ++ [sp2]))++constraint :: Parser a Token Constraint+constraint = mkConstraint <$> spanPosition <*> qtycls <*> conType+ where varType = mkVariableType <$> spanPosition <*> clsvar+ conType = fmap ((,) []) varType+ <|> mk <$> parensSp+ (foldl mkApplyType <$> varType <*> many1 type2)+ mkConstraint sp qtc (ss, ty) = updateEndPos $+ Constraint (spanInfo sp ss) qtc ty+ mkVariableType sp = VariableType (fromSrcSpan sp)+ mkApplyType t1 t2 =+ ApplyType (fromSrcSpan (combineSpans (getSrcSpan t1)+ (getSrcSpan t2)))+ t1 t2+ mk (a, sp1, sp2) = ([sp1, sp2], a)++-- ---------------------------------------------------------------------------+-- Kinds+-- ---------------------------------------------------------------------------++withKind :: Parser a Token b -> Parser a Token (b, Maybe KindExpr)+withKind p = implicitKind <$> p+ <|?> parens (explicitKind <$> p <*-> token DoubleColon <*> kind0)+ where implicitKind x = (x, Nothing)+ explicitKind x k = (x, Just k)++-- kind0 ::= kind1 ['->' kind0]+kind0 :: Parser a Token KindExpr+kind0 = kind1 `chainr1` (ArrowKind <$-> token RightArrow)++-- kind1 ::= * | '(' kind0 ')'+kind1 :: Parser a Token KindExpr+kind1 = Star <$-> token SymStar+ <|> parens kind0++-- ---------------------------------------------------------------------------+-- Types+-- ---------------------------------------------------------------------------++-- qualType ::= [context '=>'] type0+qualType :: Parser a Token QualTypeExpr+qualType = mkQualTypeExpr <$> spanPosition <*> optContext (,,) type0+ where mkQualTypeExpr sp (cx, ss, ty) = updateEndPos $+ QualTypeExpr (spanInfo sp ss) cx ty++-- type0 ::= type1 ['->' type0]+type0 :: Parser a Token TypeExpr+type0 = type1 `chainr1` (mkArrowType <$> tokenSpan RightArrow)+ where mkArrowType sp ty1 ty2 = updateEndPos $+ ArrowType (spanInfo (getSrcSpan ty1) [sp]) ty1 ty2++-- type1 ::= [type1] type2+type1 :: Parser a Token TypeExpr+type1 = foldl1 mkApplyType <$> many1 type2+ where mkApplyType ty1 ty2 = updateEndPos $+ ApplyType (fromSrcSpan (getSrcSpan ty1)) ty1 ty2++-- type2 ::= anonType | identType | parenType | bracketType+type2 :: Parser a Token TypeExpr+type2 = anonType <|> identType <|> parenType <|> bracketType++-- anonType ::= '_'+anonType :: Parser a Token TypeExpr+anonType = mkVariableType <$> spanPosition <*> anonIdent+ where mkVariableType sp = VariableType (fromSrcSpan sp)++-- identType ::= <identifier>+identType :: Parser a Token TypeExpr+identType = mkVariableType <$> spanPosition <*> tyvar+ <|> mkConstructorType <$> spanPosition <*> qtycon <\> tyvar+ where mkVariableType sp = VariableType (fromSrcSpan sp)+ mkConstructorType sp = ConstructorType (fromSrcSpan sp)++-- parenType ::= '(' tupleType ')'+parenType :: Parser a Token TypeExpr+parenType = fmap updateSpanWithBrackets (parensSp tupleType)++-- tupleType ::= type0 (parenthesized type)+-- | type0 ',' type0 { ',' type0 } (tuple type)+-- | '->' (function type constructor)+-- | ',' { ',' } (tuple type constructor)+-- | (unit type)+tupleType :: Parser a Token TypeExpr+tupleType = type0 <**> (mkTuple <$> many1 ((,) <$> tokenSpan Comma <*> type0)+ `opt` ParenType NoSpanInfo)+ <|> tokenSpan RightArrow <**> succeed (mkConstructorType qArrowId)+ <|> mkConstructorTupleType <$> many1 (tokenSpan Comma)+ <|> succeed (ConstructorType NoSpanInfo qUnitId)+ where mkTuple stys ty = let (ss, tys) = unzip stys+ in TupleType (fromSrcInfoPoints ss) (ty : tys)+ mkConstructorType qid sp = ConstructorType (fromSrcInfoPoints [sp]) qid+ mkConstructorTupleType ss = ConstructorType (fromSrcInfoPoints ss)+ (qTupleId (length ss + 1))++-- bracketType ::= '[' listType ']'+bracketType :: Parser a Token TypeExpr+bracketType = fmap updateSpanWithBrackets (bracketsSp listType)++-- listType ::= type0 (list type)+-- | (list type constructor)+listType :: Parser a Token TypeExpr+listType = ListType NoSpanInfo <$> type0+ `opt` ConstructorType NoSpanInfo qListId++-- ---------------------------------------------------------------------------+-- Literals+-- ---------------------------------------------------------------------------++-- literal ::= '\'' <escaped character> '\''+-- | <integer>+-- | <float>+-- | '"' <escaped string> '"'+literal :: Parser a Token Literal+literal = Char <$> char+ <|> Int <$> integer+ <|> Float <$> float+ <|> String <$> string++-- ---------------------------------------------------------------------------+-- Patterns+-- ---------------------------------------------------------------------------++-- pattern0 ::= pattern1 [ gconop pattern0 ]+pattern0 :: Parser a Token (Pattern ())+pattern0 = pattern1 `chainr1` (mkInfixPattern <$> gconop)+ where mkInfixPattern qid p1 p2 =+ InfixPattern (fromSrcSpan (combineSpans (getSrcSpan p1)+ (getSrcSpan p2)))+ () p1 qid p2++-- pattern1 ::= varId+-- | QConId { pattern2 }+-- | '-' Integer+-- | '-.' Float+-- | '(' parenPattern'+-- | pattern2+pattern1 :: Parser a Token (Pattern ())+pattern1 = varId <**> identPattern' -- unqualified+ <|> qConId <\> varId <**> constrPattern -- qualified+ <|> mkNegNum <$> minus <*> negNum+ <|> tokenSpan LeftParen <**> parenPattern'+ <|> pattern2 <\> qConId <\> leftParen+ where+ identPattern' = optAsRecPattern+ <|> mkConsPattern qualify <$> many1 pattern2++ constrPattern = mkConsPattern id <$> many1 pattern2+ <|> optRecPattern+++ parenPattern' = minus <**> minusPattern+ <|> mkGconPattern <$> gconId <*> tokenSpan RightParen <*> many pattern2+ <|> mkFunIdentP <$> funSym <\> minus <*> tokenSpan RightParen+ <*> identPattern'+ <|> mkParenTuple <$> parenTuplePattern <\> minus <*> tokenSpan RightParen+ minusPattern = flip mkParenMinus <$> tokenSpan RightParen <*> identPattern'+ <|> mkParenMinus <$> parenMinusPattern <*> tokenSpan RightParen++ mkNegNum idt = setEndPosition (end (getSrcSpan idt))+ mkParenTuple p sp1 sp2 =+ setSpanInfo (spanInfo (combineSpans sp2 sp1) [sp2, sp1]) p+ mkFunIdentP idt sp1 f sp2 = setSrcSpan (combineSpans sp2 sp1) (f idt)+ mkParenMinus f sp1 idt sp2 = setSrcSpan (combineSpans sp2 sp1) (f idt)+ mkConsPattern f ts c = updateEndPos $+ ConstructorPattern (fromSrcSpan (getSrcSpan (f c))) () (f c) ts+ mkGconPattern qid sp1 ps sp2 = updateEndPos $+ ConstructorPattern (spanInfo (getSrcSpan qid) [sp2,sp1]) () qid ps++pattern2 :: Parser a Token (Pattern ())+pattern2 = literalPattern <|> anonPattern <|> identPattern+ <|> parenPattern <|> listPattern <|> lazyPattern++-- literalPattern ::= <integer> | <char> | <float> | <string>+literalPattern :: Parser a Token (Pattern ())+literalPattern = flip LiteralPattern () <$> fmap fromSrcSpan spanPosition+ <*> literal++-- anonPattern ::= '_'+anonPattern :: Parser a Token (Pattern ())+anonPattern = flip VariablePattern () <$> fmap fromSrcSpan spanPosition+ <*> anonIdent++-- identPattern ::= Variable [ '@' pattern2 | '{' fields '}'+-- | qConId [ '{' fields '}' ]+identPattern :: Parser a Token (Pattern ())+identPattern = varId <**> optAsRecPattern -- unqualified+ <|> qConId <\> varId <**> optRecPattern -- qualified++-- TODO: document me!+parenPattern :: Parser a Token (Pattern ())+parenPattern = tokenSpan LeftParen <**> parenPattern'+ where+ parenPattern' = minus <**> minusPattern+ <|> mkConstructorPattern <$> gconId <*> tokenSpan RightParen+ <|> mkFunAsRec <$> funSym <\> minus <*> tokenSpan RightParen+ <*> optAsRecPattern+ <|> mkParenTuple <$> parenTuplePattern <\> minus <*> tokenSpan RightParen+ minusPattern = mkOptAsRec <$> tokenSpan RightParen <*> optAsRecPattern+ <|> mkParen <$> parenMinusPattern <*> tokenSpan RightParen++ mkConstructorPattern qid sp1 sp2 =+ ConstructorPattern (fromSrcSpan (combineSpans sp2 sp1)) () qid []+ mkFunAsRec = flip (flip . mkOptAsRec)+ mkParenTuple p sp1 sp2 =+ let ss = getSrcInfoPoints p+ spi = spanInfo (combineSpans sp2 sp1) (sp2 : (ss ++ [sp1]))+ in setSpanInfo spi p+ mkOptAsRec sp1 f idt sp2 =+ let p = f idt+ ss = getSrcInfoPoints p+ spi = spanInfo (combineSpans sp2 sp1) ([sp2, sp1] ++ ss)+ in setSpanInfo spi p+ mkParen f sp1 idt sp2 =+ let p = f idt+ ss = getSrcInfoPoints p+ spi = spanInfo (combineSpans sp2 sp1) (sp2 : (ss ++ [sp1]))+ in setSpanInfo spi p++-- listPattern ::= '[' pattern0s ']'+-- pattern0s ::= {- empty -}+-- | pattern0 ',' pattern0s+listPattern :: Parser a Token (Pattern ())+listPattern = mkListPattern <$> bracketsSp (pattern0 `sepBySp` comma)+ where mkListPattern ((ps, ss), sp1, sp2) = updateEndPos $+ ListPattern (spanInfo sp1 (sp1 : (ss ++ [sp2]))) () ps++-- lazyPattern ::= '~' pattern2+lazyPattern :: Parser a Token (Pattern ())+lazyPattern = mkLazyPattern <$> tokenSpan Tilde <*> pattern2+ where mkLazyPattern sp p = updateEndPos $ LazyPattern (spanInfo sp [sp]) p++-- optRecPattern ::= [ '{' fields '}' ]+optRecPattern :: Parser a Token (QualIdent -> Pattern ())+optRecPattern = mkRecordPattern <$> fieldsSp pattern0 `opt` mkConPattern+ where+ mkRecordPattern ((fs, ss), sp1, sp2) c = updateEndPos $+ RecordPattern (spanInfo (getSrcSpan c) (sp1 : (ss ++ [sp2]))) () c fs+ mkConPattern c = ConstructorPattern (fromSrcSpan (getSrcSpan c)) () c []++-- ---------------------------------------------------------------------------+-- Partial patterns used in the combinators above, but also for parsing+-- the left-hand side of a declaration.+-- ---------------------------------------------------------------------------++gconId :: Parser a Token QualIdent+gconId = colon <|> tupleCommas++negNum :: Parser a Token (Pattern ())+negNum = mkNegativePattern <$> spanPosition <*>+ (Int <$> integer <|> Float <$> float)+ where mkNegativePattern sp = NegativePattern (fromSrcSpan sp) ()++optAsRecPattern :: Parser a Token (Ident -> Pattern ())+optAsRecPattern = mkAsPattern <$> tokenSpan At <*> pattern2+ <|> mkRecordPattern <$> fieldsSp pattern0+ `opt` mkVariablePattern+ where mkRecordPattern ((fs,ss),sp1,sp2) v =+ let s = getPosition v+ e = end sp2+ f = file s+ spi = spanInfo (Span f s e) (sp1 : (ss ++ [sp2]))+ in updateEndPos $ RecordPattern spi () (qualify v) fs+ mkAsPattern sp p idt =+ AsPattern (spanInfo (getSrcSpan idt) [sp]) idt p+ mkVariablePattern idt =+ VariablePattern (fromSrcSpan (getSrcSpan idt)) () idt++optInfixPattern :: Parser a Token (Pattern () -> Pattern ())+optInfixPattern = mkInfixPat <$> gconop <*> pattern0+ `opt` id+ where mkInfixPat op t2 t1 =+ let s = getPosition t1+ e = getSrcSpanEnd t2+ f = file s+ in InfixPattern (fromSrcSpan (Span f s e)) () t1 op t2++optTuplePattern :: Parser a Token (Pattern () -> Pattern ())+optTuplePattern = mkTuple <$> many1 ((,) <$> tokenSpan Comma <*> pattern0)+ `opt` ParenPattern NoSpanInfo+ where mkTuple ts t = let (ss, ps) = unzip ts+ in TuplePattern (fromSrcInfoPoints ss) (t:ps)++parenMinusPattern :: Parser a Token (Ident -> Pattern ())+parenMinusPattern = mkNeg <$> negNum <.> optInfixPattern <.> optTuplePattern+ where mkNeg neg idt = setEndPosition (end (getSrcSpan idt)) neg++parenTuplePattern :: Parser a Token (Pattern ())+parenTuplePattern = pattern0 <**> optTuplePattern+ `opt` ConstructorPattern NoSpanInfo () qUnitId []++-- ---------------------------------------------------------------------------+-- Expressions+-- ---------------------------------------------------------------------------++-- condExpr ::= '|' expr0 eq expr+--+-- Note: The guard is an `expr0` instead of `expr` since conditional expressions+-- may also occur in case expressions, and an expression like+-- @+-- case a of { _ -> True :: Bool -> a }+-- @+-- can not be parsed with a limited parser lookahead.+condExpr :: Parser a Token b -> Parser a Token (CondExpr ())+condExpr eq = mkCondExpr <$> spanPosition <*-> bar <*> expr0+ <*> spanPosition <*-> eq <*> expr+ where mkCondExpr sp1 e1 sp2 e2 = updateEndPos $+ CondExpr (spanInfo sp1 [sp1, sp2]) e1 e2++-- expr ::= expr0 [ '::' type0 ]+expr :: Parser a Token (Expression ())+expr = expr0 <??> (mkTyped <$> tokenSpan DoubleColon <*> qualType)+ where mkTyped sp qty e = updateEndPos $ setSrcSpan (getSrcSpan e) $+ Typed (fromSrcInfoPoints [sp]) e qty++-- expr0 ::= expr1 { infixOp expr1 }+expr0 :: Parser a Token (Expression ())+expr0 = expr1 `chainr1` (mkInfixApply <$> infixOp)+ where mkInfixApply op e1 e2 = InfixApply+ (fromSrcSpan (combineSpans (getSrcSpan e1) (getSrcSpan e2))) e1 op e2++-- expr1 ::= - expr2 | -. expr2 | expr2+expr1 :: Parser a Token (Expression ())+expr1 = mkUnaryMinus <$> minus <*> expr2+ <|> expr2+ where mkUnaryMinus idt ex =+ let p = getPosition idt+ e = getSrcSpanEnd ex+ f = file p+ in UnaryMinus (spanInfo (Span f p e) [Span f p (incr p 1)]) ex++-- expr2 ::= lambdaExpr | letExpr | doExpr | ifExpr | caseExpr | expr3+expr2 :: Parser a Token (Expression ())+expr2 = choice [ lambdaExpr, letExpr, doExpr, ifExpr, caseExpr+ , foldl1 mkApply <$> many1 expr3+ ]+ where mkApply e1 e2 = updateEndPos $ Apply (fromSrcSpan (getSrcSpan e1)) e1 e2++expr3 :: Parser a Token (Expression ())+expr3 = foldl mkRecordUpdate <$> expr4 <*> many recUpdate+ where recUpdate = layoutOff <-*> bracesSp (field expr0 `sepBy1Sp` comma)+ mkRecordUpdate e ((fs,ss), sp1, sp2) = updateEndPos $+ setSrcInfoPoints (sp1 : (ss ++ [sp2])) $+ RecordUpdate (fromSrcSpan (getSrcSpan e)) e fs++expr4 :: Parser a Token (Expression ())+expr4 = choice+ [constant, anonFreeVariable, variable, parenExpr, listExpr]++constant :: Parser a Token (Expression ())+constant = mkLiteral <$> spanPosition <*> literal+ where mkLiteral sp = Literal (fromSrcSpan sp) ()++anonFreeVariable :: Parser a Token (Expression ())+anonFreeVariable = (\ p v -> mkVariable $ qualify $ addPositionIdent p v)+ <$> position <*> anonIdent+ where mkVariable qid = Variable (fromSrcSpan (getSrcSpan qid)) () qid++variable :: Parser a Token (Expression ())+variable = qFunId <**> optRecord+ where optRecord = mkRecord <$> fieldsSp expr0 `opt` mkVariable+ mkRecord ((fs,ss), sp1, sp2) qid =+ let spi = spanInfo (getSrcSpan qid) (sp1 : (ss ++ [sp2]))+ in updateEndPos $ Record spi () qid fs+ mkVariable qid = Variable (fromSrcSpan (getSrcSpan qid)) () qid++parenExpr :: Parser a Token (Expression ())+parenExpr = fmap updateSpanWithBrackets (parensSp pExpr)+ where+ pExpr = minus <**> minusOrTuple+ <|> mkConstructor () <$> tupleCommas+ <|> leftSectionOrTuple <\> minus+ <|> opOrRightSection <\> minus+ `opt` Constructor (fromSrcInfoPoints []) () qUnitId+ minusOrTuple = mkUnaryMinus <$> expr1 <.> infixOrTuple+ `opt` mkVariable . qualify+ leftSectionOrTuple = expr1 <**> infixOrTuple+ infixOrTuple = ($ updateEndPos) <$> infixOrTuple'+ infixOrTuple' = infixOp <**> leftSectionOrExp+ <|> (.) <$> (optType <.> tupleExpr)+ leftSectionOrExp = expr1 <**> (infixApp <$> infixOrTuple')+ `opt` leftSection+ optType = mkTyped <$> tokenSpan DoubleColon <*> qualType `opt` id+ tupleExpr = mkTuple <$> many1 ((,) <$> tokenSpan Comma <*> expr)+ `opt` Paren NoSpanInfo+ opOrRightSection = qFunSym <**> optRightSection+ <|> colon <**> optCRightSection+ <|> infixOp <\> colon <\> qFunSym <**> rightSection+ optRightSection = (. InfixOp () ) <$> rightSection+ `opt` Variable NoSpanInfo ()+ optCRightSection = (. InfixConstr ()) <$> rightSection+ `opt` Constructor NoSpanInfo ()+ rightSection = mkRightSection <$> expr0+ infixApp f e2 op g e1 = f (g . mkInfixApply e1 op) e2+ leftSection op f e = mkLeftSection (f e) op+ mkTuple ses e = let (ss,es) = unzip ses+ in Tuple (fromSrcInfoPoints ss) (e:es)+ mkConstructor = Constructor NoSpanInfo+ mkTyped sp ty e = Typed (fromSrcInfoPoints [sp]) e ty+ mkRightSection = flip (RightSection NoSpanInfo)+ mkLeftSection = LeftSection NoSpanInfo+ mkInfixApply e1 op e2 = InfixApply (fromSrcSpan+ (combineSpans (getSrcSpan e1) (getSrcSpan e2))) e1 op e2+ mkVariable = Variable NoSpanInfo ()+ mkUnaryMinus ex idt =+ let p = getPosition idt+ e = getSrcSpanEnd ex+ f = file p+ in UnaryMinus (spanInfo (Span f p e) [Span f p (incr p 1)]) ex++infixOp :: Parser a Token (InfixOp ())+infixOp = InfixOp () <$> qfunop <|> InfixConstr () <$> colon++listExpr :: Parser a Token (Expression ())+listExpr = updateSpanWithBrackets <$>+ bracketsSp (elements `opt` List (fromSrcInfoPoints []) () [])+ where+ elements = expr <**> rest+ rest = comprehension+ <|> enumeration mkEnumFromTo mkEnumFrom+ <|> (tokenSpan Comma <**> (expr <**>(+ enumeration mkEnumFromThenTo mkEnumFromThen+ <|> list <$> many ((,) <$> tokenSpan Comma <*> expr)))+ `opt` (\ e -> List (fromSrcInfoPoints []) () [e]))+ comprehension = mkListCompr <$> tokenSpan Bar <*> quals+ enumeration enumTo enum =+ tokenSpan DotDot <**> (enumTo <$> expr `opt` enum)++ mkEnumFrom sp =+ EnumFrom (fromSrcInfoPoints [sp])+ mkEnumFromTo e1 sp e2 =+ EnumFromTo (fromSrcInfoPoints [sp]) e2 e1+ mkEnumFromThen sp1 e1 sp2 e2 =+ EnumFromThen (fromSrcInfoPoints [sp2,sp1]) e2 e1+ mkEnumFromThenTo e1 sp1 e2 sp2 e3 =+ EnumFromThenTo (fromSrcInfoPoints [sp2,sp1]) e3 e2 e1+ mkListCompr sp qu e = ListCompr (fromSrcInfoPoints [sp]) e qu++ list xs e2 sp e1 = let (ss, es) = unzip xs+ in List (fromSrcInfoPoints (sp:ss)) () (e1:e2:es)++updateSpanWithBrackets :: HasSpanInfo a => (a, Span, Span) -> a+updateSpanWithBrackets (ex, sp1, sp2) =+ let ss = getSrcInfoPoints ex+ s = getPosition sp1+ e = end sp2+ f = file s+ spi = spanInfo (Span f s e) (sp1 : (ss ++ [sp2]))+ in setSpanInfo spi ex++lambdaExpr :: Parser a Token (Expression ())+lambdaExpr = mkLambda <$> tokenSpan Backslash <*> many1 pattern2+ <*> spanPosition <*-> expectRightArrow+ <*> expr+ where mkLambda sp1 ps sp2 e = updateEndPos $ Lambda (spanInfo sp1 [sp1, sp2]) ps e++letExpr :: Parser a Token (Expression ())+letExpr = mkLet <$> tokenSpan KW_let <*> layout valueDecls+ <*> (tokenSpan KW_in <?> "in expected") <*> expr+ where+ mkLet sp1 (ds, lay) sp2 e = updateEndPos $+ Let (spanInfo sp1 [sp1, sp2])lay ds e++doExpr :: Parser a Token (Expression ())+doExpr = mkDo <$> tokenSpan KW_do <*> layout stmts+ where+ mkDo sp ((stms, ex), lay) = updateEndPos $+ Do (spanInfo sp [sp]) lay stms ex++ifExpr :: Parser a Token (Expression ())+ifExpr = mkIfThenElse+ <$> tokenSpan KW_if <*> expr+ <*> (tokenSpan KW_then <?> "then expected") <*> expr+ <*> (tokenSpan KW_else <?> "else expected") <*> expr+ where mkIfThenElse sp1 e1 sp2 e2 sp3 e3 = updateEndPos $+ IfThenElse (spanInfo sp1 [sp1, sp2, sp3]) e1 e2 e3++caseExpr :: Parser a Token (Expression ())+caseExpr = (mkCase Flex <$> tokenSpan KW_fcase+ <|> mkCase Rigid <$> tokenSpan KW_case)+ <*> expr+ <*> (tokenSpan KW_of <?> "of expected")+ <*> layout (alt `sepBy1Sp` semicolon)+ where+ mkCase ct sp1 e sp2 (alts, lay) = updateEndPos $+ Case (spanInfo sp1 [sp1, sp2]) lay ct e alts++alt :: Parser a Token (Alt ())+alt = mkAlt <$> spanPosition <*> pattern0+ <*> spanPosition <*> rhs expectRightArrow+ where mkAlt sp1 p sp2 = updateEndPos . Alt (spanInfo sp1 [sp2]) p++fieldsSp :: Parser a Token b -> Parser a Token (([Field b], [Span]), Span, Span)+fieldsSp p = layoutOff <-*> bracesSp (field p `sepBySp` comma)++field :: Parser a Token b -> Parser a Token (Field b)+field p = mkField <$> spanPosition <*> qfun+ <*> spanPosition <*-> expectEquals+ <*> p+ where mkField sp1 q sp2 = updateEndPos . Field (spanInfo sp1 [sp2]) q++-- ---------------------------------------------------------------------------+-- \paragraph{Statements in list comprehensions and \texttt{do} expressions}+-- Parsing statements is a bit difficult because the syntax of patterns+-- and expressions largely overlaps. The parser will first try to+-- recognize the prefix \emph{Pattern}~\texttt{<-} of a binding statement+-- and if this fails fall back into parsing an expression statement. In+-- addition, we have to be prepared that the sequence+-- \texttt{let}~\emph{LocalDefs} can be either a let-statement or the+-- prefix of a let expression.+-- ---------------------------------------------------------------------------++stmts :: Parser a Token (([Statement ()], Expression ()), [Span])+stmts = stmt reqStmts optStmts++reqStmts :: Parser a Token (Statement ()+ -> (([Statement ()], Expression ()), [Span]))+reqStmts = mkStmts <$> spanPosition <*-> semicolon <*> stmts+ where mkStmts sp ((sts, e), sps) st = ((st : sts, e), sp:sps)++optStmts :: Parser a Token (Expression ()+ -> (([Statement ()], Expression ()), [Span]))+optStmts = succeed mkStmtExpr <.> reqStmts `opt` (\e -> (([], e), []))+ where mkStmtExpr e = StmtExpr (fromSrcSpan (getSrcSpan e)) e++quals :: Parser a Token [Statement ()]+quals = stmt (succeed id) (succeed mkStmtExpr) `sepBy1` comma+ where mkStmtExpr e = StmtExpr (fromSrcSpan (getSrcSpan e)) e++stmt :: Parser a Token (Statement () -> b)+ -> Parser a Token (Expression () -> b) -> Parser a Token b+stmt stmtCont exprCont = letStmt stmtCont exprCont+ <|> exprOrBindStmt stmtCont exprCont++letStmt :: Parser a Token (Statement () -> b)+ -> Parser a Token (Expression () -> b) -> Parser a Token b+letStmt stmtCont exprCont = ((,) <$> tokenSpan KW_let <*> layout valueDecls)+ <**> optExpr+ where optExpr = let' <$> tokenSpan KW_in <*> expr <.> exprCont+ <|> succeed stmtDecl' <.> stmtCont+ where+ let' sp1 e (sp2, (ds, lay)) = updateEndPos $+ Let (spanInfo sp2 [sp2, sp1]) lay ds e+ stmtDecl' (sp2, (ds, lay)) = updateEndPos $+ StmtDecl (spanInfo sp2 [sp2]) lay ds++exprOrBindStmt :: Parser a Token (Statement () -> b)+ -> Parser a Token (Expression () -> b)+ -> Parser a Token b+exprOrBindStmt stmtCont exprCont =+ stmtBind' <$> spanPosition <*> pattern0 <*> tokenSpan LeftArrow <*> expr+ <**> stmtCont+ <|?> expr <\> token KW_let <**> exprCont+ where+ stmtBind' sp1 p sp2 e = updateEndPos $+ StmtBind (spanInfo sp1 [sp2]) p e++-- ---------------------------------------------------------------------------+-- Goals+-- ---------------------------------------------------------------------------++goal :: Parser a Token (Goal ())+goal = mkGoal <$> spanPosition <*> expr <*> localDecls+ where+ mkGoal sp1 ex (Just sp2, ds, li) = updateEndPos $+ Goal (SpanInfo sp1 [sp2]) li ex ds+ mkGoal sp1 ex (Nothing, ds, li) = updateEndPos $+ Goal (SpanInfo sp1 []) li ex ds++-- ---------------------------------------------------------------------------+-- Literals, identifiers, and (infix) operators+-- ---------------------------------------------------------------------------++char :: Parser a Token Char+char = cval <$> token CharTok++float :: Parser a Token Double+float = fval <$> token FloatTok++int :: Parser a Token Int+int = fromInteger <$> integer++integer :: Parser a Token Integer+integer = ival <$> token IntTok++string :: Parser a Token String+string = sval <$> token StringTok++tycon :: Parser a Token Ident+tycon = conId++anonOrTyvar :: Parser a Token Ident+anonOrTyvar = anonIdent <|> tyvar++tyvar :: Parser a Token Ident+tyvar = varId++clsvar :: Parser a Token Ident+clsvar = tyvar++tycls :: Parser a Token Ident+tycls = conId++qtycls :: Parser a Token QualIdent+qtycls = qConId++qtycon :: Parser a Token QualIdent+qtycon = qConId++varId :: Parser a Token Ident+varId = ident++funId :: Parser a Token Ident+funId = ident++conId :: Parser a Token Ident+conId = ident++funSym :: Parser a Token Ident+funSym = sym++conSym :: Parser a Token Ident+conSym = sym++modIdent :: Parser a Token ModuleIdent+modIdent = mIdent <?> "module name expected"++var :: Parser a Token Ident+var = varId <|> updateSpanWithBrackets+ <$> parensSp (funSym <?> "operator symbol expected")++fun :: Parser a Token Ident+fun = funId <|> updateSpanWithBrackets+ <$> parensSp (funSym <?> "operator symbol expected")++con :: Parser a Token Ident+con = conId <|> updateSpanWithBrackets+ <$> parensSp (conSym <?> "operator symbol expected")++funop :: Parser a Token Ident+funop = funSym <|> updateSpanWithBrackets+ <$> backquotesSp (funId <?> "operator name expected")++conop :: Parser a Token Ident+conop = conSym <|> updateSpanWithBrackets+ <$> backquotesSp (conId <?> "operator name expected")++qFunId :: Parser a Token QualIdent+qFunId = qIdent++qConId :: Parser a Token QualIdent+qConId = qIdent++qFunSym :: Parser a Token QualIdent+qFunSym = qSym++qConSym :: Parser a Token QualIdent+qConSym = qSym++gConSym :: Parser a Token QualIdent+gConSym = qConSym <|> colon++qfun :: Parser a Token QualIdent+qfun = qFunId <|> updateSpanWithBrackets+ <$> parensSp (qFunSym <?> "operator symbol expected")++qfunop :: Parser a Token QualIdent+qfunop = qFunSym <|> updateSpanWithBrackets+ <$> backquotesSp (qFunId <?> "operator name expected")++gconop :: Parser a Token QualIdent+gconop = gConSym <|> updateSpanWithBrackets+ <$> backquotesSp (qConId <?> "operator name expected")++anonIdent :: Parser a Token Ident+anonIdent = (`setSpanInfo` anonId) . fromSrcSpanBoth <$> tokenSpan Underscore++mIdent :: Parser a Token ModuleIdent+mIdent = mIdent' <$> spanPosition <*>+ tokens [Id,QId,Id_as,Id_ccall,Id_forall,Id_hiding,+ Id_interface,Id_primitive,Id_qualified]+ where mIdent' sp a = ModuleIdent (fromSrcSpanBoth sp) (modulVal a ++ [sval a])++ident :: Parser a Token Ident+ident = (\ sp t -> setSpanInfo (fromSrcSpanBoth sp) (mkIdent (sval t)))+ <$> spanPosition <*> tokens [Id,Id_as,Id_ccall,Id_forall,Id_hiding,+ Id_interface,Id_primitive,Id_qualified]++qIdent :: Parser a Token QualIdent+qIdent = qualify <$> ident <|> qIdentWith QId++sym :: Parser a Token Ident+sym = (\ sp t -> setSpanInfo (fromSrcSpanBoth sp) (mkIdent (sval t)))+ <$> spanPosition <*> tokens [Sym, SymDot, SymMinus, SymStar]++qSym :: Parser a Token QualIdent+qSym = qualify <$> sym <|> qIdentWith QSym++qIdentWith :: Category -> Parser a Token QualIdent+qIdentWith c = mkQIdent <$> spanPosition <*> token c+ where mkQIdent :: Span -> Attributes -> QualIdent+ mkQIdent sp a =+ let mid = ModuleIdent (fromSrcSpan sp) (modulVal a)+ p = incr (getPosition sp) (mIdentLength mid - 1)+ mid' = setEndPosition p mid+ idt = setSrcSpan sp $ mkIdent (sval a)+ idt' = setPosition (incr p 1) idt+ in QualIdent (fromSrcSpanBoth sp) (Just mid') idt'++colon :: Parser a Token QualIdent+colon = qualify . (`setSpanInfo` consId) . fromSrcSpanBoth <$> tokenSpan Colon++minus :: Parser a Token Ident+minus = (`setSpanInfo` minusId) . fromSrcSpanBoth <$> tokenSpan SymMinus++tupleCommas :: Parser a Token QualIdent+tupleCommas = (\ sp ss -> qualify $ updateEndPos $ setSpanInfo (spanInfo sp ss)+ $ tupleId $ succ $ length ss)+ <$> spanPosition <*> many1 (tokenSpan Comma)++-- ---------------------------------------------------------------------------+-- Layout+-- ---------------------------------------------------------------------------++-- |This function starts a new layout block but does not wait for its end.+-- This is only used for parsing the module header.+startLayout :: Parser a Token (b, [Span]) -> Parser a Token (b, LayoutInfo)+startLayout p = layoutOff <-*>+ (createExpli1Layout <$> tokenSpan LeftBrace <*> p)+ <|> layoutOn <-*>+ (createWhiteLayout <$> p)++layout :: Parser a Token (b, [Span]) -> Parser a Token (b, LayoutInfo)+layout p = (createExpliLayout+ <$> (layoutOff <-*> bracesSp p))+ <|> (createWhiteLayout+ <$> (layoutOn <-*> p <*-> (token VRightBrace <|> layoutEnd)))++createExpli1Layout :: Span -> (b, [Span]) -> (b, LayoutInfo)+createExpli1Layout sp1 (b, ss) = (b, ExplicitLayout (sp1:ss))++createExpliLayout :: ((b, [Span]), Span, Span) -> (b, LayoutInfo)+createExpliLayout ((b, ss), sp1, spe) = (b, ExplicitLayout (sp1:ss ++ [spe]))++createWhiteLayout :: (b, [Span]) -> (b, LayoutInfo)+createWhiteLayout (b, _) = (b, WhitespaceLayout)++-- We have to remove an additional context on an empty where-clause+layoutWhere :: Parser a Token b -> Parser a Token ([b], LayoutInfo)+layoutWhere p = (createExpliLayout+ <$> (layoutOff <-*> bracesSp (p `sepBySp` semicolon)))+ <|> (createWhiteLayout+ <$> (layoutOn <-*> (p `sepBy1Sp` semicolon)+ <*-> (token VRightBrace <|> layoutEnd)))+ <|> succeed ([], WhitespaceLayout)++-- ---------------------------------------------------------------------------+-- Bracket combinators+-- ---------------------------------------------------------------------------++braces :: Parser a Token b -> Parser a Token b+braces p = between leftBrace p rightBrace++bracesSp :: Parser a Token b -> Parser a Token (b, Span, Span)+bracesSp p = (\sp1 b sp2 -> (b, sp1, sp2))+ <$> tokenSpan LeftBrace+ <*> p+ <*> tokenSpan RightBrace++bracketsSp :: Parser a Token b -> Parser a Token (b, Span, Span)+bracketsSp p = (\sp1 b sp2 -> (b, sp1, sp2))+ <$> tokenSpan LeftBracket+ <*> p+ <*> tokenSpan RightBracket++parens :: Parser a Token b -> Parser a Token b+parens p = between leftParen p rightParen++parensSp :: Parser a Token b -> Parser a Token (b, Span, Span)+parensSp p = (\sp1 b sp2 -> (b, sp1, sp2))+ <$> tokenSpan LeftParen+ <*> p+ <*> tokenSpan RightParen++backquotesSp :: Parser a Token b -> Parser a Token (b, Span, Span)+backquotesSp p = (\sp1 b sp2 -> (b, sp1, sp2))+ <$> tokenSpan Backquote+ <*> p+ <*> spanPosition <*-> expectBackquote++-- ---------------------------------------------------------------------------+-- Simple token parsers+-- ---------------------------------------------------------------------------++token :: Category -> Parser a Token Attributes+token c = attr <$> symbol (Token c NoAttributes)+ where attr (Token _ a) = a++tokens :: [Category] -> Parser a Token Attributes+tokens = foldr1 (<|>) . map token++tokenPos :: Category -> Parser a Token Position+tokenPos c = position <*-> token c++tokenSpan :: Category -> Parser a Token Span+tokenSpan c = spanPosition <*-> token c++tokenOps :: [(Category, b)] -> Parser a Token b+tokenOps cs = ops [(Token c NoAttributes, x) | (c, x) <- cs]++comma :: Parser a Token Attributes+comma = token Comma++semicolon :: Parser a Token Attributes+semicolon = token Semicolon <|> token VSemicolon++bar :: Parser a Token Attributes+bar = token Bar++equals :: Parser a Token Attributes+equals = token Equals++expectEquals :: Parser a Token Attributes+expectEquals = equals <?> "= expected"++expectWhere :: Parser a Token Attributes+expectWhere = token KW_where <?> "where expected"++expectRightArrow :: Parser a Token Attributes+expectRightArrow = token RightArrow <?> "-> expected"++backquote :: Parser a Token Attributes+backquote = token Backquote++expectBackquote :: Parser a Token Attributes+expectBackquote = backquote <?> "backquote (`) expected"++leftParen :: Parser a Token Attributes+leftParen = token LeftParen++rightParen :: Parser a Token Attributes+rightParen = token RightParen++leftBrace :: Parser a Token Attributes+leftBrace = token LeftBrace++rightBrace :: Parser a Token Attributes+rightBrace = token RightBrace
+ src/Curry/Syntax/Pretty.hs view
@@ -0,0 +1,463 @@+{- |+ Module : $Header$+ Description : A pretty printer for Curry+ Copyright : (c) 1999 - 2004 Wolfgang Lux+ 2005 Martin Engelke+ 2011 - 2015 Björn Peemöller+ 2016 Finn Teegen+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This module implements a pretty printer for Curry expressions. It was+ derived from the Haskell pretty printer provided in Simon Marlow's+ Haskell parser.+-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Curry.Syntax.Pretty+ ( pPrint, pPrintPrec, ppContext, ppInstanceType, ppIMethodImpl+ , ppIdent, ppQIdent, ppInfixOp, ppQInfixOp, ppMIdent+ ) where++import Prelude hiding ((<>))++import Curry.Base.Ident+import Curry.Base.Pretty++import Curry.Syntax.Type+import Curry.Syntax.Utils (opName)++instance Pretty (Module a) where+ pPrint (Module _ _ ps m es is ds) = ppModuleHeader ps m es is $$ ppSepBlock ds++ppModuleHeader :: [ModulePragma] -> ModuleIdent -> Maybe ExportSpec+ -> [ImportDecl] -> Doc+ppModuleHeader ps m es is+ | null is = header+ | otherwise = header $+$ text "" $+$ vcat (map pPrint is)+ where header = vcat (map pPrint ps)+ $+$ text "module" <+> ppMIdent m+ <+> maybePP pPrint es <+> text "where"++instance Pretty ModulePragma where+ pPrint (LanguagePragma _ exts) =+ ppPragma "LANGUAGE" $ list $ map pPrint exts+ pPrint (OptionsPragma _ tool args) =+ ppPragma "OPTIONS" $ maybe empty ((text "_" <>) . pPrint) tool <+> text args++ppPragma :: String -> Doc -> Doc+ppPragma kw doc = text "{-#" <+> text kw <+> doc <+> text "#-}"++instance Pretty Extension where+ pPrint (KnownExtension _ e) = text (show e)+ pPrint (UnknownExtension _ e) = text e++instance Pretty Tool where+ pPrint (UnknownTool t) = text t+ pPrint t = text (show t)++instance Pretty ExportSpec where+ pPrint (Exporting _ es) = parenList (map pPrint es)++instance Pretty Export where+ pPrint (Export _ x) = ppQIdent x+ pPrint (ExportTypeWith _ tc cs) = ppQIdent tc <> parenList (map ppIdent cs)+ pPrint (ExportTypeAll _ tc) = ppQIdent tc <> text "(..)"+ pPrint (ExportModule _ m) = text "module" <+> ppMIdent m++instance Pretty ImportDecl where+ pPrint (ImportDecl _ m q asM is) =+ text "import" <+> ppQualified q <+> ppMIdent m <+> maybePP ppAs asM+ <+> maybePP pPrint is+ where+ ppQualified q' = if q' then text "qualified" else empty+ ppAs m' = text "as" <+> ppMIdent m'++instance Pretty ImportSpec where+ pPrint (Importing _ is) = parenList (map pPrint is)+ pPrint (Hiding _ is) = text "hiding" <+> parenList (map pPrint is)++instance Pretty Import where+ pPrint (Import _ x) = ppIdent x+ pPrint (ImportTypeWith _ tc cs) = ppIdent tc <> parenList (map ppIdent cs)+ pPrint (ImportTypeAll _ tc) = ppIdent tc <> text "(..)"++ppBlock :: Pretty a => [a] -> Doc+ppBlock = vcat . map pPrint++ppSepBlock :: Pretty a => [a] -> Doc+ppSepBlock = vcat . map (\d -> text "" $+$ pPrint d)++instance Pretty (Decl a) where+ pPrint (InfixDecl _ fix p ops) = ppPrec fix p <+> list (map ppInfixOp ops)+ pPrint (DataDecl _ tc tvs cs clss) =+ sep (ppTypeDeclLhs "data" tc tvs :+ map indent (zipWith (<+>) (equals : repeat vbar) (map pPrint cs) +++ [ppDeriving clss]))+ pPrint (ExternalDataDecl _ tc tvs) = ppTypeDeclLhs "external data" tc tvs+ pPrint (NewtypeDecl _ tc tvs nc clss) =+ sep (ppTypeDeclLhs "newtype" tc tvs <+> equals :+ map indent [pPrint nc, ppDeriving clss])+ pPrint (TypeDecl _ tc tvs ty) =+ sep [ppTypeDeclLhs "type" tc tvs <+> equals,indent (pPrintPrec 0 ty)]+ pPrint (TypeSig _ fs ty) =+ list (map ppIdent fs) <+> text "::" <+> pPrintPrec 0 ty+ pPrint (FunctionDecl _ _ _ eqs) = vcat (map pPrint eqs)+ pPrint (ExternalDecl _ vs) = list (map pPrint vs) <+> text "external"+ pPrint (PatternDecl _ t rhs) = ppRule (pPrintPrec 0 t) equals rhs+ pPrint (FreeDecl _ vs) = list (map pPrint vs) <+> text "free"+ pPrint (DefaultDecl _ tys) =+ text "default" <+> parenList (map (pPrintPrec 0) tys)+ pPrint (ClassDecl _ _ cx cls clsvar ds) =+ ppClassInstHead "class" cx (ppIdent cls) (ppIdent clsvar) <+>+ ppIf (not $ null ds) (text "where") $$+ ppIf (not $ null ds) (indent $ ppBlock ds)+ pPrint (InstanceDecl _ _ cx qcls inst ds) =+ ppClassInstHead "instance" cx (ppQIdent qcls) (ppInstanceType inst) <+>+ ppIf (not $ null ds) (text "where") $$+ ppIf (not $ null ds) (indent $ ppBlock ds)++ppClassInstHead :: String -> Context -> Doc -> Doc -> Doc+ppClassInstHead kw cx cls ty = text kw <+> ppContext cx <+> cls <+> ty++ppContext :: Context -> Doc+ppContext [] = empty+ppContext [c] = pPrint c <+> darrow+ppContext cs = parenList (map pPrint cs) <+> darrow++instance Pretty Constraint where+ pPrint (Constraint _ qcls ty) = ppQIdent qcls <+> pPrintPrec 2 ty++ppInstanceType :: InstanceType -> Doc+ppInstanceType = pPrintPrec 2++ppDeriving :: [QualIdent] -> Doc+ppDeriving [] = empty+ppDeriving [qcls] = text "deriving" <+> ppQIdent qcls+ppDeriving qclss = text "deriving" <+> parenList (map ppQIdent qclss)++ppPrec :: Infix -> Maybe Precedence -> Doc+ppPrec fix p = pPrint fix <+> ppPrio p+ where+ ppPrio Nothing = empty+ ppPrio (Just p') = integer p'++ppTypeDeclLhs :: String -> Ident -> [Ident] -> Doc+ppTypeDeclLhs kw tc tvs = text kw <+> ppIdent tc <+> hsep (map ppIdent tvs)++instance Pretty ConstrDecl where+ pPrint (ConstrDecl _ c tys) =+ sep [ ppIdent c <+> fsep (map (pPrintPrec 2) tys) ]+ pPrint (ConOpDecl _ ty1 op ty2) =+ sep [ pPrintPrec 1 ty1, ppInfixOp op <+> pPrintPrec 1 ty2 ]+ pPrint (RecordDecl _ c fs) =+ sep [ ppIdent c <+> record (list (map pPrint fs)) ]++instance Pretty FieldDecl where+ pPrint (FieldDecl _ ls ty) = list (map ppIdent ls)+ <+> text "::" <+> pPrintPrec 0 ty++instance Pretty NewConstrDecl where+ pPrint (NewConstrDecl _ c ty) = sep [ppIdent c <+> pPrintPrec 2 ty]+ pPrint (NewRecordDecl _ c (i,ty)) =+ sep [ppIdent c <+> record (ppIdent i <+> text "::" <+> pPrintPrec 0 ty)]++ppQuantifiedVars :: [Ident] -> Doc+ppQuantifiedVars tvs+ | null tvs = empty+ | otherwise = text "forall" <+> hsep (map ppIdent tvs) <+> char '.'++instance Pretty (Equation a) where+ pPrint (Equation _ lhs rhs) = ppRule (pPrint lhs) equals rhs++instance Pretty (Lhs a) where+ pPrint (FunLhs _ f ts) =+ ppIdent f <+> fsep (map (pPrintPrec 2) ts)+ pPrint (OpLhs _ t1 f t2) =+ pPrintPrec 1 t1 <+> ppInfixOp f <+> pPrintPrec 1 t2+ pPrint (ApLhs _ lhs ts) =+ parens (pPrint lhs) <+> fsep (map (pPrintPrec 2) ts)++ppRule :: Doc -> Doc -> Rhs a -> Doc+ppRule lhs eq (SimpleRhs _ _ e ds) =+ sep [lhs <+> eq, indent (pPrintPrec 0 e)] $$ ppLocalDefs ds+ppRule lhs eq (GuardedRhs _ _ es ds) =+ sep [lhs, indent (vcat (map (ppCondExpr eq) es))] $$ ppLocalDefs ds++ppLocalDefs :: [Decl a] -> Doc+ppLocalDefs ds+ | null ds = empty+ | otherwise = indent (text "where" <+> ppBlock ds)++-- ---------------------------------------------------------------------------+-- Interfaces+-- ---------------------------------------------------------------------------++instance Pretty Interface where+ pPrint (Interface m is ds) =+ text "interface" <+> ppMIdent m <+> text "where" <+> lbrace+ $$ vcat (punctuate semi $ map pPrint is ++ map pPrint ds)+ $$ rbrace++instance Pretty IImportDecl where+ pPrint (IImportDecl _ m) = text "import" <+> ppMIdent m++instance Pretty IDecl where+ pPrint (IInfixDecl _ fix p op) = ppPrec fix (Just p) <+> ppQInfixOp op+ pPrint (HidingDataDecl _ tc k tvs) =+ text "hiding" <+> ppITypeDeclLhs "data" tc k tvs+ pPrint (IDataDecl _ tc k tvs cs hs) =+ sep (ppITypeDeclLhs "data" tc k tvs :+ map indent (zipWith (<+>) (equals : repeat vbar) (map pPrint cs)) +++ [indent (ppHiding hs)])+ pPrint (INewtypeDecl _ tc k tvs nc hs) =+ sep [ ppITypeDeclLhs "newtype" tc k tvs <+> equals+ , indent (pPrint nc)+ , indent (ppHiding hs)+ ]+ pPrint (ITypeDecl _ tc k tvs ty) =+ sep [ppITypeDeclLhs "type" tc k tvs <+> equals,indent (pPrintPrec 0 ty)]+ pPrint (IFunctionDecl _ f cm a ty) =+ sep [ ppQIdent f, maybePP (ppPragma "METHOD" . ppIdent) cm+ , int a, text "::", pPrintPrec 0 ty ]+ pPrint (HidingClassDecl _ cx qcls k clsvar) = text "hiding" <+>+ ppClassInstHead "class" cx (ppQIdentWithKind qcls k) (ppIdent clsvar)+ pPrint (IClassDecl _ cx qcls k clsvar ms hs) =+ ppClassInstHead "class" cx (ppQIdentWithKind qcls k) (ppIdent clsvar) <+>+ lbrace $$+ vcat (punctuate semi $ map (indent . pPrint) ms) $$+ rbrace <+> ppHiding hs+ pPrint (IInstanceDecl _ cx qcls inst impls m) =+ ppClassInstHead "instance" cx (ppQIdent qcls) (ppInstanceType inst) <+>+ lbrace $$+ vcat (punctuate semi $ map (indent . ppIMethodImpl) impls) $$+ rbrace <+> maybePP (ppPragma "MODULE" . ppMIdent) m++ppITypeDeclLhs :: String -> QualIdent -> Maybe KindExpr -> [Ident] -> Doc+ppITypeDeclLhs kw tc k tvs =+ text kw <+> ppQIdentWithKind tc k <+> hsep (map ppIdent tvs)++instance Pretty IMethodDecl where+ pPrint (IMethodDecl _ f a qty) =+ ppIdent f <+> maybePP int a <+> text "::" <+> pPrintPrec 0 qty++ppIMethodImpl :: IMethodImpl -> Doc+ppIMethodImpl (f, a) = ppIdent f <+> int a++ppQIdentWithKind :: QualIdent -> Maybe KindExpr -> Doc+ppQIdentWithKind tc (Just k) =+ parens $ ppQIdent tc <+> text "::" <+> pPrintPrec 0 k+ppQIdentWithKind tc Nothing = ppQIdent tc++ppHiding :: [Ident] -> Doc+ppHiding hs+ | null hs = empty+ | otherwise = ppPragma "HIDING" $ list $ map ppIdent hs++-- ---------------------------------------------------------------------------+-- Kinds+-- ---------------------------------------------------------------------------++instance Pretty KindExpr where+ pPrintPrec _ Star = char '*'+ pPrintPrec p (ArrowKind k1 k2) =+ parenIf (p > 0) (fsep (ppArrowKind (ArrowKind k1 k2)))+ where+ ppArrowKind (ArrowKind k1' k2') =+ pPrintPrec 1 k1' <+> rarrow : ppArrowKind k2'+ ppArrowKind k =+ [pPrintPrec 0 k]++-- ---------------------------------------------------------------------------+-- Types+-- ---------------------------------------------------------------------------++instance Pretty QualTypeExpr where+ pPrint (QualTypeExpr _ cx ty) = ppContext cx <+> pPrintPrec 0 ty++instance Pretty TypeExpr where+ pPrintPrec _ (ConstructorType _ tc) = ppQIdent tc+ pPrintPrec p (ApplyType _ ty1 ty2) = parenIf (p > 1) (ppApplyType ty1 [ty2])+ where+ ppApplyType (ApplyType _ ty1' ty2') tys =+ ppApplyType ty1' (ty2' : tys)+ ppApplyType ty tys =+ pPrintPrec 1 ty <+> fsep (map (pPrintPrec 2) tys)+ pPrintPrec _ (VariableType _ tv) = ppIdent tv+ pPrintPrec _ (TupleType _ tys) = parenList (map (pPrintPrec 0) tys)+ pPrintPrec _ (ListType _ ty) = brackets (pPrintPrec 0 ty)+ pPrintPrec p (ArrowType spi ty1 ty2) = parenIf (p > 0)+ (fsep (ppArrowType (ArrowType spi ty1 ty2)))+ where+ ppArrowType (ArrowType _ ty1' ty2') =+ pPrintPrec 1 ty1' <+> rarrow : ppArrowType ty2'+ ppArrowType ty =+ [pPrintPrec 0 ty]+ pPrintPrec _ (ParenType _ ty) = parens (pPrintPrec 0 ty)+ pPrintPrec p (ForallType _ vs ty)+ | null vs = pPrintPrec p ty+ | otherwise = parenIf (p > 0) $ ppQuantifiedVars vs <+> pPrintPrec 0 ty++-- ---------------------------------------------------------------------------+-- Literals+-- ---------------------------------------------------------------------------++instance Pretty Literal where+ pPrint (Char c) = text (show c)+ pPrint (Int i) = integer i+ pPrint (Float f) = double f+ pPrint (String s) = text (show s)++-- ---------------------------------------------------------------------------+-- Patterns+-- ---------------------------------------------------------------------------++instance Pretty (Pattern a) where+ pPrintPrec p (LiteralPattern _ _ l) =+ parenIf (p > 1 && isNegative l) (pPrint l)+ where+ isNegative (Char _) = False+ isNegative (Int i) = i < 0+ isNegative (Float f) = f < 0.0+ isNegative (String _) = False+ pPrintPrec p (NegativePattern _ _ l) = parenIf (p > 1)+ (ppInfixOp minusId <> pPrint l)+ pPrintPrec _ (VariablePattern _ _ v) = ppIdent v+ pPrintPrec p (ConstructorPattern _ _ c ts) = parenIf (p > 1 && not (null ts))+ (ppQIdent c <+> fsep (map (pPrintPrec 2) ts))+ pPrintPrec p (InfixPattern _ _ t1 c t2) = parenIf (p > 0)+ (sep [pPrintPrec 1 t1 <+> ppQInfixOp c, indent (pPrintPrec 0 t2)])+ pPrintPrec _ (ParenPattern _ t) = parens (pPrintPrec 0 t)+ pPrintPrec _ (TuplePattern _ ts) =+ parenList (map (pPrintPrec 0) ts)+ pPrintPrec _ (ListPattern _ _ ts) =+ bracketList (map (pPrintPrec 0) ts)+ pPrintPrec _ (AsPattern _ v t) =+ ppIdent v <> char '@' <> pPrintPrec 2 t+ pPrintPrec _ (LazyPattern _ t) = char '~' <> pPrintPrec 2 t+ pPrintPrec p (FunctionPattern _ _ f ts) = parenIf (p > 1 && not (null ts))+ (ppQIdent f <+> fsep (map (pPrintPrec 2) ts))+ pPrintPrec p (InfixFuncPattern _ _ t1 f t2) = parenIf (p > 0)+ (sep [pPrintPrec 1 t1 <+> ppQInfixOp f, indent (pPrintPrec 0 t2)])+ pPrintPrec p (RecordPattern _ _ c fs) = parenIf (p > 1)+ (ppQIdent c <+> record (list (map pPrint fs)))++instance Pretty a => Pretty (Field a) where+ pPrint (Field _ l t) = ppQIdent l <+> equals <+> pPrintPrec 0 t++-- ---------------------------------------------------------------------------+-- Expressions+-- ---------------------------------------------------------------------------++ppCondExpr :: Doc -> CondExpr a -> Doc+ppCondExpr eq (CondExpr _ g e) =+ vbar <+> sep [pPrintPrec 0 g <+> eq, indent (pPrintPrec 0 e)]++instance Pretty (Expression a) where+ pPrintPrec _ (Literal _ _ l) = pPrint l+ pPrintPrec _ (Variable _ _ v) = ppQIdent v+ pPrintPrec _ (Constructor _ _ c) = ppQIdent c+ pPrintPrec _ (Paren _ e) = parens (pPrintPrec 0 e)+ pPrintPrec p (Typed _ e ty) =+ parenIf (p > 0) (pPrintPrec 0 e <+> text "::" <+> pPrintPrec 0 ty)+ pPrintPrec _ (Tuple _ es) = parenList (map (pPrintPrec 0) es)+ pPrintPrec _ (List _ _ es) = bracketList (map (pPrintPrec 0) es)+ pPrintPrec _ (ListCompr _ e qs) =+ brackets (pPrintPrec 0 e <+> vbar <+> list (map pPrint qs))+ pPrintPrec _ (EnumFrom _ e) =+ brackets (pPrintPrec 0 e <+> text "..")+ pPrintPrec _ (EnumFromThen _ e1 e2) =+ brackets (pPrintPrec 0 e1 <> comma <+> pPrintPrec 0 e2 <+> text "..")+ pPrintPrec _ (EnumFromTo _ e1 e2) =+ brackets (pPrintPrec 0 e1 <+> text ".." <+> pPrintPrec 0 e2)+ pPrintPrec _ (EnumFromThenTo _ e1 e2 e3) =+ brackets (pPrintPrec 0 e1 <> comma <+> pPrintPrec 0 e2+ <+> text ".." <+> pPrintPrec 0 e3)+ pPrintPrec p (UnaryMinus _ e) =+ parenIf (p > 1) (ppInfixOp minusId <> pPrintPrec 1 e)+ pPrintPrec p (Apply _ e1 e2) =+ parenIf (p > 1) (sep [pPrintPrec 1 e1, indent (pPrintPrec 2 e2)])+ pPrintPrec p (InfixApply _ e1 op e2) = parenIf (p > 0)+ (sep [pPrintPrec 1 e1 <+> ppQInfixOp (opName op), indent (pPrintPrec 1 e2)])+ pPrintPrec _ (LeftSection _ e op) =+ parens (pPrintPrec 1 e <+> ppQInfixOp (opName op))+ pPrintPrec _ (RightSection _ op e) =+ parens (ppQInfixOp (opName op) <+> pPrintPrec 1 e)+ pPrintPrec p (Lambda _ t e) = parenIf (p > 0) $+ sep [backsl <> fsep (map (pPrintPrec 2) t) <+> rarrow,+ indent (pPrintPrec 0 e)]+ pPrintPrec p (Let _ _ ds e) = parenIf (p > 0)+ (sep [text "let" <+> ppBlock ds, text "in" <+> pPrintPrec 0 e])+ pPrintPrec p (Do _ _ sts e) = parenIf (p > 0)+ (text "do" <+> (vcat (map pPrint sts) $$ pPrintPrec 0 e))+ pPrintPrec p (IfThenElse _ e1 e2 e3) = parenIf (p > 0)+ (text "if" <+>+ sep [pPrintPrec 0 e1,+ text "then" <+> pPrintPrec 0 e2,+ text "else" <+> pPrintPrec 0 e3])+ pPrintPrec p (Case _ _ ct e alts) = parenIf (p > 0)+ (pPrint ct <+> pPrintPrec 0 e <+> text "of" $$+ indent (vcat (map pPrint alts)))+ pPrintPrec p (Record _ _ c fs) = parenIf (p > 0)+ (ppQIdent c <+> record (list (map pPrint fs)))+ pPrintPrec _ (RecordUpdate _ e fs) =+ pPrintPrec 0 e <+> record (list (map pPrint fs))++instance Pretty (Statement a) where+ pPrint (StmtExpr _ e) = pPrintPrec 0 e+ pPrint (StmtBind _ t e) =+ sep [pPrintPrec 0 t <+> larrow, indent (pPrintPrec 0 e)]+ pPrint (StmtDecl _ _ ds) = text "let" <+> ppBlock ds++instance Pretty CaseType where+ pPrint Rigid = text "case"+ pPrint Flex = text "fcase"++instance Pretty (Alt a) where+ pPrint (Alt _ t rhs) = ppRule (pPrintPrec 0 t) rarrow rhs++instance Pretty (Var a) where+ pPrint (Var _ ident) = ppIdent ident++instance Pretty (InfixOp a) where+ pPrint (InfixOp _ op) = ppQInfixOp op+ pPrint (InfixConstr _ op) = ppQInfixOp op++-- ---------------------------------------------------------------------------+-- Names+-- ---------------------------------------------------------------------------++-- |Pretty print an identifier+ppIdent :: Ident -> Doc+ppIdent x = parenIf (isInfixOp x) (text (idName x))++ppQIdent :: QualIdent -> Doc+ppQIdent x = parenIf (isQInfixOp x) (text (qualName x))++ppInfixOp :: Ident -> Doc+ppInfixOp x = bquotesIf (not (isInfixOp x)) (text (idName x))++ppQInfixOp :: QualIdent -> Doc+ppQInfixOp x = bquotesIf (not (isQInfixOp x)) (text (qualName x))++ppMIdent :: ModuleIdent -> Doc+ppMIdent m = text (moduleName m)++-- ---------------------------------------------------------------------------+-- Print printing utilities+-- ---------------------------------------------------------------------------++indent :: Doc -> Doc+indent = nest 2++parenList :: [Doc] -> Doc+parenList = parens . list++record :: Doc -> Doc+record doc | isEmpty doc = braces empty+ | otherwise = braces $ space <> doc <> space++bracketList :: [Doc] -> Doc+bracketList = brackets . list
+ src/Curry/Syntax/ShowModule.hs view
@@ -0,0 +1,777 @@+{- |+ Module : $Header$+ Copyright : (c) 2008 Sebastian Fischer+ 2011 - 2015 Björn Peemöller+ 2016 Finn Teegen+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ Transform a CurrySyntax module into a string representation without any+ pretty printing.++ Behaves like a derived Show instance even on parts with a specific one.+-}+module Curry.Syntax.ShowModule (showModule) where++import Curry.Base.Ident+import Curry.Base.Position+import Curry.Base.Span+import Curry.Base.SpanInfo++import Curry.Syntax.Type++-- |Show a Curry module like by an devired 'Show' instance+showModule :: Show a => Module a -> String+showModule m = showsModule m "\n"++showsModule :: Show a => Module a -> ShowS+showsModule (Module spi li ps mident espec imps decls)+ = showsString "Module "+ . showsLayoutInfo li . space+ . showsSpanInfo spi . space+ . showsList (\p -> showsPragma p . newline) ps . space+ . showsModuleIdent mident . newline+ . showsMaybe showsExportSpec espec . newline+ . showsList (\i -> showsImportDecl i . newline) imps+ . showsList (\d -> showsDecl d . newline) decls++showsPragma :: ModulePragma -> ShowS+showsPragma (LanguagePragma pos exts)+ = showsString "(LanguagePragma "+ . showsSpanInfo pos . space+ . showsList showsExtension exts+ . showsString ")"+showsPragma (OptionsPragma pos mbTool args)+ = showsString "(OptionsPragma "+ . showsSpanInfo pos . space+ . showsMaybe shows mbTool+ . shows args+ . showsString ")"++showsExtension :: Extension -> ShowS+showsExtension (KnownExtension p e)+ = showsString "(KnownExtension "+ . showsSpanInfo p . space+ . shows e+ . showString ")"+showsExtension (UnknownExtension p s)+ = showsString "(UnknownExtension "+ . showsSpanInfo p . space+ . shows s+ . showString ")"++showsExportSpec :: ExportSpec -> ShowS+showsExportSpec (Exporting pos exports)+ = showsString "(Exporting "+ . showsSpanInfo pos . space+ . showsList showsExport exports+ . showsString ")"++showsExport :: Export -> ShowS+showsExport (Export spi qident)+ = showsString "(Export "+ . showsSpanInfo spi . space+ . showsQualIdent qident+ . showsString ")"+showsExport (ExportTypeWith spi qident ids)+ = showsString "(ExportTypeWith "+ . showsSpanInfo spi . space+ . showsQualIdent qident . space+ . showsList showsIdent ids+ . showsString ")"+showsExport (ExportTypeAll spi qident)+ = showsString "(ExportTypeAll "+ . showsSpanInfo spi . space+ . showsQualIdent qident+ . showsString ")"+showsExport (ExportModule spi m)+ = showsString "(ExportModule "+ . showsSpanInfo spi . space+ . showsModuleIdent m+ . showsString ")"++showsImportDecl :: ImportDecl -> ShowS+showsImportDecl (ImportDecl spi mident quali mmident mimpspec)+ = showsString "(ImportDecl "+ . showsSpanInfo spi . space+ . showsModuleIdent mident . space+ . shows quali . space+ . showsMaybe showsModuleIdent mmident . space+ . showsMaybe showsImportSpec mimpspec+ . showsString ")"++showsImportSpec :: ImportSpec -> ShowS+showsImportSpec (Importing spi imports)+ = showsString "(Importing "+ . showsSpanInfo spi . space+ . showsList showsImport imports+ . showsString ")"+showsImportSpec (Hiding spi imports)+ = showsString "(Hiding "+ . showsSpanInfo spi . space+ . showsList showsImport imports+ . showsString ")"++showsImport :: Import -> ShowS+showsImport (Import spi ident)+ = showsString "(Import "+ . showsSpanInfo spi . space+ . showsIdent ident+ . showsString ")"+showsImport (ImportTypeWith spi ident idents)+ = showsString "(ImportTypeWith "+ . showsSpanInfo spi . space+ . showsIdent ident . space+ . showsList showsIdent idents+ . showsString ")"+showsImport (ImportTypeAll spi ident)+ = showsString "(ImportTypeAll "+ . showsSpanInfo spi . space+ . showsIdent ident+ . showsString ")"++showsDecl :: Show a => Decl a -> ShowS+showsDecl (InfixDecl spi infx prec idents)+ = showsString "(InfixDecl "+ . showsSpanInfo spi . space+ . shows infx . space+ . showsMaybe shows prec . space+ . showsList showsIdent idents+ . showsString ")"+showsDecl (DataDecl spi ident idents consdecls classes)+ = showsString "(DataDecl "+ . showsSpanInfo spi . space+ . showsIdent ident . space+ . showsList showsIdent idents . space+ . showsList showsConsDecl consdecls . space+ . showsList showsQualIdent classes+ . showsString ")"+showsDecl (ExternalDataDecl spi ident idents)+ = showsString "(ExternalDataDecl "+ . showsSpanInfo spi . space+ . showsIdent ident . space+ . showsList showsIdent idents+ . showsString ")"+showsDecl (NewtypeDecl spi ident idents newconsdecl classes)+ = showsString "(NewtypeDecl "+ . showsSpanInfo spi . space+ . showsIdent ident . space+ . showsList showsIdent idents . space+ . showsNewConsDecl newconsdecl . space+ . showsList showsQualIdent classes+ . showsString ")"+showsDecl (TypeDecl spi ident idents typ)+ = showsString "(TypeDecl "+ . showsSpanInfo spi . space+ . showsIdent ident . space+ . showsList showsIdent idents . space+ . showsTypeExpr typ+ . showsString ")"+showsDecl (TypeSig spi idents qtype)+ = showsString "(TypeSig "+ . showsSpanInfo spi . space+ . showsList showsIdent idents . space+ . showsQualTypeExpr qtype+ . showsString ")"+showsDecl (FunctionDecl spi a ident eqs)+ = showsString "(FunctionDecl "+ . showsSpanInfo spi . space+ . showsPrec 11 a . space+ . showsIdent ident . space+ . showsList showsEquation eqs+ . showsString ")"+showsDecl (ExternalDecl spi vars)+ = showsString "(ExternalDecl "+ . showsSpanInfo spi . space+ . showsList showsVar vars+ . showsString ")"+showsDecl (PatternDecl spi cons rhs)+ = showsString "(PatternDecl "+ . showsSpanInfo spi . space+ . showsConsTerm cons . space+ . showsRhs rhs+ . showsString ")"+showsDecl (FreeDecl spi vars)+ = showsString "(FreeDecl "+ . showsSpanInfo spi . space+ . showsList showsVar vars+ . showsString ")"+showsDecl (DefaultDecl spi types)+ = showsString "(DefaultDecl "+ . showsSpanInfo spi . space+ . showsList showsTypeExpr types+ . showsString ")"+showsDecl (ClassDecl spi li context cls clsvar decls)+ = showsString "(ClassDecl "+ . showsSpanInfo spi . space+ . showsLayoutInfo li . space+ . showsContext context . space+ . showsIdent cls . space+ . showsIdent clsvar . space+ . showsList showsDecl decls+ . showsString ")"+showsDecl (InstanceDecl spi li context qcls inst decls)+ = showsString "(InstanceDecl "+ . showsSpanInfo spi . space+ . showsLayoutInfo li . space+ . showsContext context . space+ . showsQualIdent qcls . space+ . showsInstanceType inst . space+ . showsList showsDecl decls+ . showsString ")"++showsContext :: Context -> ShowS+showsContext = showsList showsConstraint++showsConstraint :: Constraint -> ShowS+showsConstraint (Constraint spi qcls ty)+ = showsString "(Constraint "+ . showsSpanInfo spi . space+ . showsQualIdent qcls . space+ . showsTypeExpr ty+ . showsString ")"++showsInstanceType :: InstanceType -> ShowS+showsInstanceType = showsTypeExpr++showsConsDecl :: ConstrDecl -> ShowS+showsConsDecl (ConstrDecl spi ident types)+ = showsString "(ConstrDecl "+ . showsSpanInfo spi . space+ . showsIdent ident . space+ . showsList showsTypeExpr types+ . showsString ")"+showsConsDecl (ConOpDecl spi ty1 ident ty2)+ = showsString "(ConOpDecl "+ . showsSpanInfo spi . space+ . showsTypeExpr ty1 . space+ . showsIdent ident . space+ . showsTypeExpr ty2+ . showsString ")"+showsConsDecl (RecordDecl spi ident fs)+ = showsString "(RecordDecl "+ . showsSpanInfo spi . space+ . showsIdent ident . space+ . showsList showsFieldDecl fs+ . showsString ")"++showsFieldDecl :: FieldDecl -> ShowS+showsFieldDecl (FieldDecl spi labels ty)+ = showsString "(FieldDecl "+ . showsSpanInfo spi . space+ . showsList showsIdent labels . space+ . showsTypeExpr ty+ . showsString ")"++showsNewConsDecl :: NewConstrDecl -> ShowS+showsNewConsDecl (NewConstrDecl spi ident typ)+ = showsString "(NewConstrDecl "+ . showsSpanInfo spi . space+ . showsIdent ident . space+ . showsTypeExpr typ+ . showsString ")"+showsNewConsDecl (NewRecordDecl spi ident fld)+ = showsString "(NewRecordDecl "+ . showsSpanInfo spi . space+ . showsIdent ident . space+ . showsPair showsIdent showsTypeExpr fld+ . showsString ")"++showsQualTypeExpr :: QualTypeExpr -> ShowS+showsQualTypeExpr (QualTypeExpr spi context typ)+ = showsString "(QualTypeExpr "+ . showsSpanInfo spi . space+ . showsContext context . space+ . showsTypeExpr typ+ . showsString ")"++showsTypeExpr :: TypeExpr -> ShowS+showsTypeExpr (ConstructorType spi qident)+ = showsString "(ConstructorType "+ . showsSpanInfo spi . space+ . showsQualIdent qident . space+ . showsString ")"+showsTypeExpr (ApplyType spi type1 type2)+ = showsString "(ApplyType "+ . showsSpanInfo spi . space+ . showsTypeExpr type1 . space+ . showsTypeExpr type2 . space+ . showsString ")"+showsTypeExpr (VariableType spi ident)+ = showsString "(VariableType "+ . showsSpanInfo spi . space+ . showsIdent ident+ . showsString ")"+showsTypeExpr (TupleType spi types)+ = showsString "(TupleType "+ . showsSpanInfo spi . space+ . showsList showsTypeExpr types+ . showsString ")"+showsTypeExpr (ListType spi typ)+ = showsString "(ListType "+ . showsSpanInfo spi . space+ . showsTypeExpr typ+ . showsString ")"+showsTypeExpr (ArrowType spi dom ran)+ = showsString "(ArrowType "+ . showsSpanInfo spi . space+ . showsTypeExpr dom . space+ . showsTypeExpr ran+ . showsString ")"+showsTypeExpr (ParenType spi ty)+ = showsString "(ParenType "+ . showsSpanInfo spi . space+ . showsTypeExpr ty+ . showsString ")"+showsTypeExpr (ForallType spi vars ty)+ = showsString "(ForallType "+ . showsSpanInfo spi . space+ . showsList showsIdent vars+ . showsTypeExpr ty+ . showsString ")"++showsEquation :: Show a => Equation a -> ShowS+showsEquation (Equation spi lhs rhs)+ = showsString "(Equation "+ . showsSpanInfo spi . space+ . showsLhs lhs . space+ . showsRhs rhs+ . showsString ")"++showsLhs :: Show a => Lhs a -> ShowS+showsLhs (FunLhs spi ident conss)+ = showsString "(FunLhs "+ . showsSpanInfo spi . space+ . showsIdent ident . space+ . showsList showsConsTerm conss+ . showsString ")"+showsLhs (OpLhs spi cons1 ident cons2)+ = showsString "(OpLhs "+ . showsSpanInfo spi . space+ . showsConsTerm cons1 . space+ . showsIdent ident . space+ . showsConsTerm cons2+ . showsString ")"+showsLhs (ApLhs spi lhs conss)+ = showsString "(ApLhs "+ . showsSpanInfo spi . space+ . showsLhs lhs . space+ . showsList showsConsTerm conss+ . showsString ")"++showsRhs :: Show a => Rhs a -> ShowS+showsRhs (SimpleRhs spi li expr decls)+ = showsString "(SimpleRhs "+ . showsSpanInfo spi . space+ . showsLayoutInfo li . space+ . showsExpression expr . space+ . showsList showsDecl decls+ . showsString ")"+showsRhs (GuardedRhs spi li cexps decls)+ = showsString "(GuardedRhs "+ . showsSpanInfo spi . space+ . showsLayoutInfo li . space+ . showsList showsCondExpr cexps . space+ . showsList showsDecl decls+ . showsString ")"++showsCondExpr :: Show a => CondExpr a -> ShowS+showsCondExpr (CondExpr spi exp1 exp2)+ = showsString "(CondExpr "+ . showsSpanInfo spi . space+ . showsExpression exp1 . space+ . showsExpression exp2+ . showsString ")"++showsLiteral :: Literal -> ShowS+showsLiteral (Char c)+ = showsString "(Char "+ . shows c+ . showsString ")"+showsLiteral (Int n)+ = showsString "(Int "+ . shows n+ . showsString ")"+showsLiteral (Float x)+ = showsString "(Float "+ . shows x+ . showsString ")"+showsLiteral (String s)+ = showsString "(String "+ . shows s+ . showsString ")"++showsConsTerm :: Show a => Pattern a -> ShowS+showsConsTerm (LiteralPattern spi a lit)+ = showsString "(LiteralPattern "+ . showsSpanInfo spi . space+ . showsPrec 11 a . space+ . showsLiteral lit+ . showsString ")"+showsConsTerm (NegativePattern spi a lit)+ = showsString "(NegativePattern "+ . showsSpanInfo spi . space+ . showsPrec 11 a . space+ . showsLiteral lit+ . showsString ")"+showsConsTerm (VariablePattern spi a ident)+ = showsString "(VariablePattern "+ . showsSpanInfo spi . space+ . showsPrec 11 a . space+ . showsIdent ident+ . showsString ")"+showsConsTerm (ConstructorPattern spi a qident conss)+ = showsString "(ConstructorPattern "+ . showsSpanInfo spi . space+ . showsPrec 11 a . space+ . showsQualIdent qident . space+ . showsList showsConsTerm conss+ . showsString ")"+showsConsTerm (InfixPattern spi a cons1 qident cons2)+ = showsString "(InfixPattern "+ . showsSpanInfo spi . space+ . showsPrec 11 a . space+ . showsConsTerm cons1 . space+ . showsQualIdent qident . space+ . showsConsTerm cons2+ . showsString ")"+showsConsTerm (ParenPattern spi cons)+ = showsString "(ParenPattern "+ . showsSpanInfo spi . space+ . showsConsTerm cons+ . showsString ")"+showsConsTerm (TuplePattern spi conss)+ = showsString "(TuplePattern "+ . showsSpanInfo spi . space+ . showsList showsConsTerm conss+ . showsString ")"+showsConsTerm (ListPattern spi a conss)+ = showsString "(ListPattern "+ . showsSpanInfo spi . space+ . showsPrec 11 a . space+ . showsList showsConsTerm conss+ . showsString ")"+showsConsTerm (AsPattern spi ident cons)+ = showsString "(AsPattern "+ . showsSpanInfo spi . space+ . showsIdent ident . space+ . showsConsTerm cons+ . showsString ")"+showsConsTerm (LazyPattern spi cons)+ = showsString "(LazyPattern "+ . showsSpanInfo spi . space+ . showsConsTerm cons+ . showsString ")"+showsConsTerm (FunctionPattern spi a qident conss)+ = showsString "(FunctionPattern "+ . showsSpanInfo spi . space+ . showsPrec 11 a . space+ . showsQualIdent qident . space+ . showsList showsConsTerm conss+ . showsString ")"+showsConsTerm (InfixFuncPattern spi a cons1 qident cons2)+ = showsString "(InfixFuncPattern "+ . showsSpanInfo spi . space+ . showsPrec 11 a . space+ . showsConsTerm cons1 . space+ . showsQualIdent qident . space+ . showsConsTerm cons2+ . showsString ")"+showsConsTerm (RecordPattern spi a qident cfields)+ = showsString "(RecordPattern "+ . showsSpanInfo spi . space+ . showsPrec 11 a . space+ . showsQualIdent qident . space+ . showsList (showsField showsConsTerm) cfields . space+ . showsString ")"++showsExpression :: Show a => Expression a -> ShowS+showsExpression (Literal spi a lit)+ = showsString "(Literal "+ . showsSpanInfo spi . space+ . showsPrec 11 a . space+ . showsLiteral lit+ . showsString ")"+showsExpression (Variable spi a qident)+ = showsString "(Variable "+ . showsSpanInfo spi . space+ . showsPrec 11 a . space+ . showsQualIdent qident+ . showsString ")"+showsExpression (Constructor spi a qident)+ = showsString "(Constructor "+ . showsSpanInfo spi . space+ . showsPrec 11 a . space+ . showsQualIdent qident+ . showsString ")"+showsExpression (Paren spi expr)+ = showsString "(Paren "+ . showsSpanInfo spi . space+ . showsExpression expr+ . showsString ")"+showsExpression (Typed spi expr qtype)+ = showsString "(Typed "+ . showsSpanInfo spi . space+ . showsExpression expr . space+ . showsQualTypeExpr qtype+ . showsString ")"+showsExpression (Tuple spi exps)+ = showsString "(Tuple "+ . showsSpanInfo spi . space+ . showsList showsExpression exps+ . showsString ")"+showsExpression (List spi a exps)+ = showsString "(List "+ . showsSpanInfo spi . space+ . showsPrec 11 a . space+ . showsList showsExpression exps+ . showsString ")"+showsExpression (ListCompr spi expr stmts)+ = showsString "(ListCompr "+ . showsSpanInfo spi . space+ . showsExpression expr . space+ . showsList showsStatement stmts+ . showsString ")"+showsExpression (EnumFrom spi expr)+ = showsString "(EnumFrom "+ . showsSpanInfo spi . space+ . showsExpression expr+ . showsString ")"+showsExpression (EnumFromThen spi exp1 exp2)+ = showsString "(EnumFromThen "+ . showsSpanInfo spi . space+ . showsExpression exp1 . space+ . showsExpression exp2+ . showsString ")"+showsExpression (EnumFromTo spi exp1 exp2)+ = showsString "(EnumFromTo "+ . showsSpanInfo spi . space+ . showsExpression exp1 . space+ . showsExpression exp2+ . showsString ")"+showsExpression (EnumFromThenTo spi exp1 exp2 exp3)+ = showsString "(EnumFromThenTo "+ . showsSpanInfo spi . space+ . showsExpression exp1 . space+ . showsExpression exp2 . space+ . showsExpression exp3+ . showsString ")"+showsExpression (UnaryMinus spi expr)+ = showsString "(UnaryMinus "+ . showsSpanInfo spi . space+ . showsExpression expr+ . showsString ")"+showsExpression (Apply spi exp1 exp2)+ = showsString "(Apply "+ . showsSpanInfo spi . space+ . showsExpression exp1 . space+ . showsExpression exp2+ . showsString ")"+showsExpression (InfixApply spi exp1 op exp2)+ = showsString "(InfixApply "+ . showsSpanInfo spi . space+ . showsExpression exp1 . space+ . showsInfixOp op . space+ . showsExpression exp2+ . showsString ")"+showsExpression (LeftSection spi expr op)+ = showsString "(LeftSection "+ . showsSpanInfo spi . space+ . showsExpression expr . space+ . showsInfixOp op+ . showsString ")"+showsExpression (RightSection spi op expr)+ = showsString "(RightSection "+ . showsSpanInfo spi . space+ . showsInfixOp op . space+ . showsExpression expr+ . showsString ")"+showsExpression (Lambda spi conss expr)+ = showsString "(Lambda "+ . showsSpanInfo spi . space+ . showsList showsConsTerm conss . space+ . showsExpression expr+ . showsString ")"+showsExpression (Let spi li decls expr)+ = showsString "(Let "+ . showsSpanInfo spi . space+ . showsLayoutInfo li . space+ . showsList showsDecl decls . space+ . showsExpression expr+ . showsString ")"+showsExpression (Do spi li stmts expr)+ = showsString "(Do "+ . showsSpanInfo spi . space+ . showsLayoutInfo li . space+ . showsList showsStatement stmts . space+ . showsExpression expr+ . showsString ")"+showsExpression (IfThenElse spi exp1 exp2 exp3)+ = showsString "(IfThenElse "+ . showsSpanInfo spi . space+ . showsExpression exp1 . space+ . showsExpression exp2 . space+ . showsExpression exp3+ . showsString ")"+showsExpression (Case spi li ct expr alts)+ = showsString "(Case "+ . showsSpanInfo spi . space+ . showsLayoutInfo li . space+ . showsCaseType ct . space+ . showsExpression expr . space+ . showsList showsAlt alts+ . showsString ")"+showsExpression (RecordUpdate spi expr efields)+ = showsString "(RecordUpdate "+ . showsSpanInfo spi . space+ . showsExpression expr . space+ . showsList (showsField showsExpression) efields+ . showsString ")"+showsExpression (Record spi a qident efields)+ = showsString "(Record "+ . showsSpanInfo spi . space+ . showsPrec 11 a . space+ . showsQualIdent qident . space+ . showsList (showsField showsExpression) efields+ . showsString ")"++showsInfixOp :: Show a => InfixOp a -> ShowS+showsInfixOp (InfixOp a qident)+ = showsString "(InfixOp "+ . showsPrec 11 a . space+ . showsQualIdent qident+ . showsString ")"+showsInfixOp (InfixConstr a qident)+ = showsString "(InfixConstr "+ . showsPrec 11 a . space+ . showsQualIdent qident+ . showsString ")"++showsStatement :: Show a => Statement a -> ShowS+showsStatement (StmtExpr spi expr)+ = showsString "(StmtExpr "+ . showsSpanInfo spi . space+ . showsExpression expr+ . showsString ")"+showsStatement (StmtDecl spi li decls)+ = showsString "(StmtDecl "+ . showsSpanInfo spi . space+ . showsLayoutInfo li . space+ . showsList showsDecl decls+ . showsString ")"+showsStatement (StmtBind spi cons expr)+ = showsString "(StmtBind "+ . showsSpanInfo spi . space+ . showsConsTerm cons . space+ . showsExpression expr+ . showsString ")"++showsCaseType :: CaseType -> ShowS+showsCaseType Rigid = showsString "Rigid"+showsCaseType Flex = showsString "Flex"++showsAlt :: Show a => Alt a -> ShowS+showsAlt (Alt spi cons rhs)+ = showsString "(Alt "+ . showsSpanInfo spi . space+ . showsConsTerm cons . space+ . showsRhs rhs+ . showsString ")"++showsField :: (a -> ShowS) -> Field a -> ShowS+showsField sa (Field spi ident a)+ = showsString "(Field "+ . showsSpanInfo spi . space+ . showsQualIdent ident . space+ . sa a+ . showsString ")"++showsVar :: Show a => Var a -> ShowS+showsVar (Var a ident)+ = showsString "(Var "+ . showsPrec 11 a . space+ . showsIdent ident+ . showsString ")"++showsPosition :: Position -> ShowS+showsPosition NoPos = showsString "NoPos"+showsPosition Position { line = l, column = c }+ = showsString "(Position "+ . shows l . space+ . shows c+ . showsString ")"++showsSpanInfo :: SpanInfo -> ShowS+showsSpanInfo NoSpanInfo = showsString "NoSpanInfo"+showsSpanInfo SpanInfo { srcSpan = sp, srcInfoPoints = ss }+ = showsString "(SpanInfo "+ . showsSpan sp . space+ . showsList showsSpan ss+ . showsString ")"++showsLayoutInfo :: LayoutInfo -> ShowS+showsLayoutInfo WhitespaceLayout = showsString "WhitespaceLayout"+showsLayoutInfo (ExplicitLayout ss)+ = showsString "(ExplicitLayout "+ . showsList showsSpan ss+ . showsString ")"++showsSpan :: Span -> ShowS+showsSpan NoSpan = showsString "NoSpan"+showsSpan Span { start = s, end = e }+ = showsString "(Span "+ . showsPosition s . space+ . showsPosition e+ . showsString ")"++showsString :: String -> ShowS+showsString = (++)++space :: ShowS+space = showsString " "++newline :: ShowS+newline = showsString "\n"++showsMaybe :: (a -> ShowS) -> Maybe a -> ShowS+showsMaybe shs = maybe (showsString "Nothing")+ (\x -> showsString "(Just " . shs x . showsString ")")++showsList :: (a -> ShowS) -> [a] -> ShowS+showsList _ [] = showsString "[]"+showsList shs (x:xs)+ = showsString "["+ . foldl (\sys y -> sys . showsString "," . shs y) (shs x) xs+ . showsString "]"++showsPair :: (a -> ShowS) -> (b -> ShowS) -> (a,b) -> ShowS+showsPair sa sb (a,b)+ = showsString "(" . sa a . showsString "," . sb b . showsString ")"++showsIdent :: Ident -> ShowS+showsIdent (Ident spi x n)+ = showsString "(Ident " . showsSpanInfo spi . space+ . shows x . space . shows n . showsString ")"++showsQualIdent :: QualIdent -> ShowS+showsQualIdent (QualIdent spi mident ident)+ = showsString "(QualIdent "+ . showsSpanInfo spi . space+ . showsMaybe showsModuleIdent mident+ . space+ . showsIdent ident+ . showsString ")"++showsModuleIdent :: ModuleIdent -> ShowS+showsModuleIdent (ModuleIdent spi ss)+ = showsString "(ModuleIdent "+ . showsSpanInfo spi . space+ . showsList (showsQuotes showsString) ss+ . showsString ")"++showsQuotes :: (a -> ShowS) -> a -> ShowS+showsQuotes sa a+ = showsString "\"" . sa a . showsString "\""
+ src/Curry/Syntax/Type.hs view
@@ -0,0 +1,1540 @@+{- |+ Module : $Header$+ Description : Abstract syntax for Curry+ Copyright : (c) 1999 - 2004 Wolfgang Lux+ 2005 Martin Engelke+ 2011 - 2015 Björn Peemöller+ 2014 Jan Rasmus Tikovsky+ 2016 Finn Teegen+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This module provides the necessary data structures to maintain the+ parsed representation of a Curry program.+-}++module Curry.Syntax.Type+ ( -- * Module header+ Module (..)+ -- ** Module pragmas+ , ModulePragma (..), Extension (..), KnownExtension (..), Tool (..)+ -- ** Export specification+ , ExportSpec (..), Export (..)+ -- ** Import declarations+ , ImportDecl (..), ImportSpec (..), Import (..), Qualified+ -- * Interface+ , Interface (..), IImportDecl (..), Arity, IDecl (..), KindExpr (..)+ , IMethodDecl (..), IMethodImpl+ -- * Declarations+ , Decl (..), Precedence, Infix (..), ConstrDecl (..), NewConstrDecl (..)+ , FieldDecl (..)+ , TypeExpr (..), QualTypeExpr (..)+ , Equation (..), Lhs (..), Rhs (..), CondExpr (..)+ , Literal (..), Pattern (..), Expression (..), InfixOp (..)+ , Statement (..), CaseType (..), Alt (..), Field (..), Var (..)+ -- * Type classes+ , Context, Constraint (..), InstanceType+ -- * Goals+ , Goal (..)+ ) where++import Data.Binary+import Control.Monad++import Curry.Base.Ident+import Curry.Base.Position+import Curry.Base.SpanInfo+import Curry.Base.Span+import Curry.Base.Pretty (Pretty(..))++import Curry.Syntax.Extension++import Text.PrettyPrint++-- ---------------------------------------------------------------------------+-- Modules+-- ---------------------------------------------------------------------------++-- |Curry module+data Module a = Module SpanInfo LayoutInfo [ModulePragma] ModuleIdent+ (Maybe ExportSpec) [ImportDecl] [Decl a]+ deriving (Eq, Read, Show)++-- |Module pragma+data ModulePragma+ = LanguagePragma SpanInfo [Extension] -- ^ language pragma+ | OptionsPragma SpanInfo (Maybe Tool) String -- ^ options pragma+ deriving (Eq, Read, Show)++-- |Export specification+data ExportSpec = Exporting SpanInfo [Export]+ deriving (Eq, Read, Show)++-- |Single exported entity+data Export+ = Export SpanInfo QualIdent -- f/T+ | ExportTypeWith SpanInfo QualIdent [Ident] -- T (C1,...,Cn)+ | ExportTypeAll SpanInfo QualIdent -- T (..)+ | ExportModule SpanInfo ModuleIdent -- module M+ deriving (Eq, Read, Show)++-- |Import declaration+data ImportDecl = ImportDecl SpanInfo ModuleIdent Qualified+ (Maybe ModuleIdent) (Maybe ImportSpec)+ deriving (Eq, Read, Show)++-- |Flag to signal qualified import+type Qualified = Bool++-- |Import specification+data ImportSpec+ = Importing SpanInfo [Import]+ | Hiding SpanInfo [Import]+ deriving (Eq, Read, Show)++-- |Single imported entity+data Import+ = Import SpanInfo Ident -- f/T+ | ImportTypeWith SpanInfo Ident [Ident] -- T (C1,...,Cn)+ | ImportTypeAll SpanInfo Ident -- T (..)+ deriving (Eq, Read, Show)++-- ---------------------------------------------------------------------------+-- Module interfaces+-- ---------------------------------------------------------------------------++-- | Module interface+--+-- Interface declarations are restricted to type declarations and signatures.+-- Note that an interface function declaration additionaly contains the+-- function arity (= number of parameters) in order to generate+-- correct FlatCurry function applications.+data Interface = Interface ModuleIdent [IImportDecl] [IDecl]+ deriving (Eq, Read, Show)++-- |Interface import declaration+data IImportDecl = IImportDecl Position ModuleIdent+ deriving (Eq, Read, Show)++-- |Arity of a function+type Arity = Int++-- |Interface declaration+data IDecl+ = IInfixDecl Position Infix Precedence QualIdent+ | HidingDataDecl Position QualIdent (Maybe KindExpr) [Ident]+ | IDataDecl Position QualIdent (Maybe KindExpr) [Ident] [ConstrDecl] [Ident]+ | INewtypeDecl Position QualIdent (Maybe KindExpr) [Ident] NewConstrDecl [Ident]+ | ITypeDecl Position QualIdent (Maybe KindExpr) [Ident] TypeExpr+ | IFunctionDecl Position QualIdent (Maybe Ident) Arity QualTypeExpr+ | HidingClassDecl Position Context QualIdent (Maybe KindExpr) Ident+ | IClassDecl Position Context QualIdent (Maybe KindExpr) Ident [IMethodDecl] [Ident]+ | IInstanceDecl Position Context QualIdent InstanceType [IMethodImpl] (Maybe ModuleIdent)+ deriving (Eq, Read, Show)++-- |Class methods+data IMethodDecl = IMethodDecl Position Ident (Maybe Arity) QualTypeExpr+ deriving (Eq, Read, Show)++-- |Class method implementations+type IMethodImpl = (Ident, Arity)++-- |Kind expressions+data KindExpr+ = Star+ | ArrowKind KindExpr KindExpr+ deriving (Eq, Read, Show)++-- ---------------------------------------------------------------------------+-- Declarations (local or top-level)+-- ---------------------------------------------------------------------------++-- |Declaration in a module+data Decl a+ = InfixDecl SpanInfo Infix (Maybe Precedence) [Ident] -- infixl 5 (op), `fun`+ | DataDecl SpanInfo Ident [Ident] [ConstrDecl] [QualIdent] -- data C a b = C1 a | C2 b deriving (D, ...)+ | ExternalDataDecl SpanInfo Ident [Ident] -- external data C a b+ | NewtypeDecl SpanInfo Ident [Ident] NewConstrDecl [QualIdent] -- newtype C a b = C a b deriving (D, ...)+ | TypeDecl SpanInfo Ident [Ident] TypeExpr -- type C a b = D a b+ | TypeSig SpanInfo [Ident] QualTypeExpr -- f, g :: Bool+ | FunctionDecl SpanInfo a Ident [Equation a] -- f True = 1 ; f False = 0+ | ExternalDecl SpanInfo [Var a] -- f, g external+ | PatternDecl SpanInfo (Pattern a) (Rhs a) -- Just x = ...+ | FreeDecl SpanInfo [Var a] -- x, y free+ | DefaultDecl SpanInfo [TypeExpr] -- default (Int, Float)+ | ClassDecl SpanInfo LayoutInfo Context Ident Ident [Decl a] -- class C a => D a where {TypeSig|InfixDecl|FunctionDecl}+ | InstanceDecl SpanInfo LayoutInfo Context QualIdent InstanceType [Decl a] -- instance C a => M.D (N.T a b c) where {FunctionDecl}+ deriving (Eq, Read, Show)++-- ---------------------------------------------------------------------------+-- Infix declaration+-- ---------------------------------------------------------------------------++-- |Operator precedence+type Precedence = Integer++-- |Fixity of operators+data Infix+ = InfixL -- ^ left-associative+ | InfixR -- ^ right-associative+ | Infix -- ^ no associativity+ deriving (Eq, Read, Show)++-- |Constructor declaration for algebraic data types+data ConstrDecl+ = ConstrDecl SpanInfo Ident [TypeExpr]+ | ConOpDecl SpanInfo TypeExpr Ident TypeExpr+ | RecordDecl SpanInfo Ident [FieldDecl]+ deriving (Eq, Read, Show)++-- |Constructor declaration for renaming types (newtypes)+data NewConstrDecl+ = NewConstrDecl SpanInfo Ident TypeExpr+ | NewRecordDecl SpanInfo Ident (Ident, TypeExpr)+ deriving (Eq, Read, Show)++-- |Declaration for labelled fields+data FieldDecl = FieldDecl SpanInfo [Ident] TypeExpr+ deriving (Eq, Read, Show)++-- |Type expressions+data TypeExpr+ = ConstructorType SpanInfo QualIdent+ | ApplyType SpanInfo TypeExpr TypeExpr+ | VariableType SpanInfo Ident+ | TupleType SpanInfo [TypeExpr]+ | ListType SpanInfo TypeExpr+ | ArrowType SpanInfo TypeExpr TypeExpr+ | ParenType SpanInfo TypeExpr+ | ForallType SpanInfo [Ident] TypeExpr+ deriving (Eq, Read, Show)++-- |Qualified type expressions+data QualTypeExpr = QualTypeExpr SpanInfo Context TypeExpr+ deriving (Eq, Read, Show)++-- ---------------------------------------------------------------------------+-- Type classes+-- ---------------------------------------------------------------------------++type Context = [Constraint]++data Constraint = Constraint SpanInfo QualIdent TypeExpr+ deriving (Eq, Read, Show)++type InstanceType = TypeExpr++-- ---------------------------------------------------------------------------+-- Functions+-- ---------------------------------------------------------------------------++-- |Function defining equation+data Equation a = Equation SpanInfo (Lhs a) (Rhs a)+ deriving (Eq, Read, Show)++-- |Left-hand-side of an 'Equation' (function identifier and patterns)+data Lhs a+ = FunLhs SpanInfo Ident [Pattern a] -- f x y+ | OpLhs SpanInfo (Pattern a) Ident (Pattern a) -- x $ y+ | ApLhs SpanInfo (Lhs a) [Pattern a] -- ($) x y+ deriving (Eq, Read, Show)++-- |Right-hand-side of an 'Equation'+data Rhs a+ = SimpleRhs SpanInfo LayoutInfo (Expression a) [Decl a] -- @expr where decls@+ | GuardedRhs SpanInfo LayoutInfo [CondExpr a] [Decl a] -- @| cond = expr where decls@+ deriving (Eq, Read, Show)++-- |Conditional expression (expression conditioned by a guard)+data CondExpr a = CondExpr SpanInfo (Expression a) (Expression a)+ deriving (Eq, Read, Show)++-- |Literal+data Literal+ = Char Char+ | Int Integer+ | Float Double+ | String String+ deriving (Eq, Read, Show)++-- |Constructor term (used for patterns)+data Pattern a+ = LiteralPattern SpanInfo a Literal+ | NegativePattern SpanInfo a Literal+ | VariablePattern SpanInfo a Ident+ | ConstructorPattern SpanInfo a QualIdent [Pattern a]+ | InfixPattern SpanInfo a (Pattern a) QualIdent (Pattern a)+ | ParenPattern SpanInfo (Pattern a)+ | RecordPattern SpanInfo a QualIdent [Field (Pattern a)] -- C { l1 = p1, ..., ln = pn }+ | TuplePattern SpanInfo [Pattern a]+ | ListPattern SpanInfo a [Pattern a]+ | AsPattern SpanInfo Ident (Pattern a)+ | LazyPattern SpanInfo (Pattern a)+ | FunctionPattern SpanInfo a QualIdent [Pattern a]+ | InfixFuncPattern SpanInfo a (Pattern a) QualIdent (Pattern a)+ deriving (Eq, Read, Show)++-- |Expression+data Expression a+ = Literal SpanInfo a Literal+ | Variable SpanInfo a QualIdent+ | Constructor SpanInfo a QualIdent+ | Paren SpanInfo (Expression a)+ | Typed SpanInfo (Expression a) QualTypeExpr+ | Record SpanInfo a QualIdent [Field (Expression a)] -- C {l1 = e1,..., ln = en}+ | RecordUpdate SpanInfo (Expression a) [Field (Expression a)] -- e {l1 = e1,..., ln = en}+ | Tuple SpanInfo [Expression a]+ | List SpanInfo a [Expression a]+ | ListCompr SpanInfo (Expression a) [Statement a] -- the ref corresponds to the main list+ | EnumFrom SpanInfo (Expression a)+ | EnumFromThen SpanInfo (Expression a) (Expression a)+ | EnumFromTo SpanInfo (Expression a) (Expression a)+ | EnumFromThenTo SpanInfo (Expression a) (Expression a) (Expression a)+ | UnaryMinus SpanInfo (Expression a)+ | Apply SpanInfo (Expression a) (Expression a)+ | InfixApply SpanInfo (Expression a) (InfixOp a) (Expression a)+ | LeftSection SpanInfo (Expression a) (InfixOp a)+ | RightSection SpanInfo (InfixOp a) (Expression a)+ | Lambda SpanInfo [Pattern a] (Expression a)+ | Let SpanInfo LayoutInfo [Decl a] (Expression a)+ | Do SpanInfo LayoutInfo [Statement a] (Expression a)+ | IfThenElse SpanInfo (Expression a) (Expression a) (Expression a)+ | Case SpanInfo LayoutInfo CaseType (Expression a) [Alt a]+ deriving (Eq, Read, Show)++-- |Infix operation+data InfixOp a+ = InfixOp a QualIdent+ | InfixConstr a QualIdent+ deriving (Eq, Read, Show)++-- |Statement (used for do-sequence and list comprehensions)+data Statement a+ = StmtExpr SpanInfo (Expression a)+ | StmtDecl SpanInfo LayoutInfo [Decl a]+ | StmtBind SpanInfo (Pattern a) (Expression a)+ deriving (Eq, Read, Show)++-- |Type of case expressions+data CaseType+ = Rigid+ | Flex+ deriving (Eq, Read, Show)++-- |Single case alternative+data Alt a = Alt SpanInfo (Pattern a) (Rhs a)+ deriving (Eq, Read, Show)++-- |Record field+data Field a = Field SpanInfo QualIdent a+ deriving (Eq, Read, Show)++-- |Annotated identifier+data Var a = Var a Ident+ deriving (Eq, Read, Show)++-- ---------------------------------------------------------------------------+-- Goals+-- ---------------------------------------------------------------------------++-- |Goal in REPL (expression to evaluate)+data Goal a = Goal SpanInfo LayoutInfo (Expression a) [Decl a]+ deriving (Eq, Read, Show)++-- ---------------------------------------------------------------------------+-- instances+-- ---------------------------------------------------------------------------++instance Functor Module where+ fmap f (Module sp li ps m es is ds) = Module sp li ps m es is (map (fmap f) ds)++instance Functor Decl where+ fmap _ (InfixDecl sp fix prec ops) = InfixDecl sp fix prec ops+ fmap _ (DataDecl sp tc tvs cs clss) = DataDecl sp tc tvs cs clss+ fmap _ (ExternalDataDecl sp tc tvs) = ExternalDataDecl sp tc tvs+ fmap _ (NewtypeDecl sp tc tvs nc clss) = NewtypeDecl sp tc tvs nc clss+ fmap _ (TypeDecl sp tc tvs ty) = TypeDecl sp tc tvs ty+ fmap _ (TypeSig sp fs qty) = TypeSig sp fs qty+ fmap f (FunctionDecl sp a f' eqs) = FunctionDecl sp (f a) f' (map (fmap f) eqs)+ fmap f (ExternalDecl sp vs) = ExternalDecl sp (map (fmap f) vs)+ fmap f (PatternDecl sp t rhs) = PatternDecl sp (fmap f t) (fmap f rhs)+ fmap f (FreeDecl sp vs) = FreeDecl sp (map (fmap f) vs)+ fmap _ (DefaultDecl sp tys) = DefaultDecl sp tys+ fmap f (ClassDecl sp li cx cls clsvar ds) =+ ClassDecl sp li cx cls clsvar (map (fmap f) ds)+ fmap f (InstanceDecl sp li cx qcls inst ds) =+ InstanceDecl sp li cx qcls inst (map (fmap f) ds)++instance Functor Equation where+ fmap f (Equation p lhs rhs) = Equation p (fmap f lhs) (fmap f rhs)++instance Functor Lhs where+ fmap f (FunLhs p f' ts) = FunLhs p f' (map (fmap f) ts)+ fmap f (OpLhs p t1 op t2) = OpLhs p (fmap f t1) op (fmap f t2)+ fmap f (ApLhs p lhs ts) = ApLhs p (fmap f lhs) (map (fmap f) ts)++instance Functor Rhs where+ fmap f (SimpleRhs p li e ds) = SimpleRhs p li (fmap f e) (map (fmap f) ds)+ fmap f (GuardedRhs p li cs ds) = GuardedRhs p li (map (fmap f) cs) (map (fmap f) ds)++instance Functor CondExpr where+ fmap f (CondExpr p g e) = CondExpr p (fmap f g) (fmap f e)++instance Functor Pattern where+ fmap f (LiteralPattern p a l) = LiteralPattern p (f a) l+ fmap f (NegativePattern p a l) = NegativePattern p (f a) l+ fmap f (VariablePattern p a v) = VariablePattern p (f a) v+ fmap f (ConstructorPattern p a c ts) =+ ConstructorPattern p (f a) c (map (fmap f) ts)+ fmap f (InfixPattern p a t1 op t2) =+ InfixPattern p (f a) (fmap f t1) op (fmap f t2)+ fmap f (ParenPattern p t) = ParenPattern p (fmap f t)+ fmap f (RecordPattern p a c fs) =+ RecordPattern p (f a) c (map (fmap (fmap f)) fs)+ fmap f (TuplePattern p ts) = TuplePattern p (map (fmap f) ts)+ fmap f (ListPattern p a ts) = ListPattern p (f a) (map (fmap f) ts)+ fmap f (AsPattern p v t) = AsPattern p v (fmap f t)+ fmap f (LazyPattern p t) = LazyPattern p (fmap f t)+ fmap f (FunctionPattern p a f' ts) =+ FunctionPattern p (f a) f' (map (fmap f) ts)+ fmap f (InfixFuncPattern p a t1 op t2) =+ InfixFuncPattern p (f a) (fmap f t1) op (fmap f t2)++instance Functor Expression where+ fmap f (Literal p a l) = Literal p (f a) l+ fmap f (Variable p a v) = Variable p (f a) v+ fmap f (Constructor p a c) = Constructor p (f a) c+ fmap f (Paren p e) = Paren p (fmap f e)+ fmap f (Typed p e qty) = Typed p (fmap f e) qty+ fmap f (Record p a c fs) = Record p (f a) c (map (fmap (fmap f)) fs)+ fmap f (RecordUpdate p e fs) = RecordUpdate p (fmap f e) (map (fmap (fmap f)) fs)+ fmap f (Tuple p es) = Tuple p (map (fmap f) es)+ fmap f (List p a es) = List p (f a) (map (fmap f) es)+ fmap f (ListCompr p e stms) = ListCompr p (fmap f e) (map (fmap f) stms)+ fmap f (EnumFrom p e) = EnumFrom p (fmap f e)+ fmap f (EnumFromThen p e1 e2) = EnumFromThen p (fmap f e1) (fmap f e2)+ fmap f (EnumFromTo p e1 e2) = EnumFromTo p (fmap f e1) (fmap f e2)+ fmap f (EnumFromThenTo p e1 e2 e3) =+ EnumFromThenTo p (fmap f e1) (fmap f e2) (fmap f e3)+ fmap f (UnaryMinus p e) = UnaryMinus p (fmap f e)+ fmap f (Apply p e1 e2) = Apply p (fmap f e1) (fmap f e2)+ fmap f (InfixApply p e1 op e2) =+ InfixApply p (fmap f e1) (fmap f op) (fmap f e2)+ fmap f (LeftSection p e op) = LeftSection p (fmap f e) (fmap f op)+ fmap f (RightSection p op e) = RightSection p (fmap f op) (fmap f e)+ fmap f (Lambda p ts e) = Lambda p (map (fmap f) ts) (fmap f e)+ fmap f (Let p li ds e) = Let p li (map (fmap f) ds) (fmap f e)+ fmap f (Do p li stms e) = Do p li (map (fmap f) stms) (fmap f e)+ fmap f (IfThenElse p e1 e2 e3) =+ IfThenElse p (fmap f e1) (fmap f e2) (fmap f e3)+ fmap f (Case p li ct e as) = Case p li ct (fmap f e) (map (fmap f) as)++instance Functor InfixOp where+ fmap f (InfixOp a op) = InfixOp (f a) op+ fmap f (InfixConstr a op) = InfixConstr (f a) op++instance Functor Statement where+ fmap f (StmtExpr p e) = StmtExpr p (fmap f e)+ fmap f (StmtDecl p li ds) = StmtDecl p li (map (fmap f) ds)+ fmap f (StmtBind p t e) = StmtBind p (fmap f t) (fmap f e)++instance Functor Alt where+ fmap f (Alt p t rhs) = Alt p (fmap f t) (fmap f rhs)++instance Functor Field where+ fmap f (Field p l x) = Field p l (f x)++instance Functor Var where+ fmap f (Var a v) = Var (f a) v++instance Functor Goal where+ fmap f (Goal p li e ds) = Goal p li (fmap f e) (map (fmap f) ds)++instance Pretty Infix where+ pPrint InfixL = text "infixl"+ pPrint InfixR = text "infixr"+ pPrint Infix = text "infix"++instance HasSpanInfo (Module a) where+ getSpanInfo (Module sp _ _ _ _ _ _) = sp++ setSpanInfo sp (Module _ li ps m es is ds) = Module sp li ps m es is ds++ updateEndPos m@(Module _ _ _ _ _ _ (d:ds)) =+ setEndPosition (getSrcSpanEnd (last (d:ds))) m+ updateEndPos m@(Module _ _ _ _ _ (i:is) _) =+ setEndPosition (getSrcSpanEnd (last (i:is))) m+ updateEndPos m@(Module (SpanInfo _ (s:ss)) _ _ _ _ _ _) =+ setEndPosition (end (last (s:ss))) m+ updateEndPos m@(Module _ _ (p:ps) _ _ _ _) =+ setEndPosition (getSrcSpanEnd (last (p:ps))) m+ updateEndPos m = m++ getLayoutInfo (Module _ li _ _ _ _ _) = li++instance HasSpanInfo (Decl a) where+ getSpanInfo (InfixDecl sp _ _ _) = sp+ getSpanInfo (DataDecl sp _ _ _ _) = sp+ getSpanInfo (ExternalDataDecl sp _ _) = sp+ getSpanInfo (NewtypeDecl sp _ _ _ _) = sp+ getSpanInfo (TypeDecl sp _ _ _) = sp+ getSpanInfo (TypeSig sp _ _) = sp+ getSpanInfo (FunctionDecl sp _ _ _) = sp+ getSpanInfo (ExternalDecl sp _) = sp+ getSpanInfo (PatternDecl sp _ _) = sp+ getSpanInfo (FreeDecl sp _) = sp+ getSpanInfo (DefaultDecl sp _) = sp+ getSpanInfo (ClassDecl sp _ _ _ _ _) = sp+ getSpanInfo (InstanceDecl sp _ _ _ _ _) = sp++ setSpanInfo sp (InfixDecl _ fix prec ops) = InfixDecl sp fix prec ops+ setSpanInfo sp (DataDecl _ tc tvs cs clss) = DataDecl sp tc tvs cs clss+ setSpanInfo sp (ExternalDataDecl _ tc tvs) = ExternalDataDecl sp tc tvs+ setSpanInfo sp (NewtypeDecl _ tc tvs nc clss) = NewtypeDecl sp tc tvs nc clss+ setSpanInfo sp (TypeDecl _ tc tvs ty) = TypeDecl sp tc tvs ty+ setSpanInfo sp (TypeSig _ fs qty) = TypeSig sp fs qty+ setSpanInfo sp (FunctionDecl _ a f' eqs) = FunctionDecl sp a f' eqs+ setSpanInfo sp (ExternalDecl _ vs) = ExternalDecl sp vs+ setSpanInfo sp (PatternDecl _ t rhs) = PatternDecl sp t rhs+ setSpanInfo sp (FreeDecl _ vs) = FreeDecl sp vs+ setSpanInfo sp (DefaultDecl _ tys) = DefaultDecl sp tys+ setSpanInfo sp (ClassDecl _ li cx cls clsvar ds) = ClassDecl sp li cx cls clsvar ds+ setSpanInfo sp (InstanceDecl _ li cx qcls inst ds) = InstanceDecl sp li cx qcls inst ds++ updateEndPos d@(InfixDecl _ _ _ ops) =+ let i' = last ops+ in setEndPosition (incr (getPosition i') (identLength i' - 1)) d+ updateEndPos d@(DataDecl _ _ _ _ (c:cs)) =+ let i' = last (c:cs)+ in setEndPosition (incr (getPosition i') (qIdentLength i' - 1)) d+ updateEndPos d@(DataDecl _ _ _ (c:cs) _) =+ setEndPosition (getSrcSpanEnd (last (c:cs))) d+ updateEndPos d@(DataDecl _ _ (i:is) _ _) =+ let i' = last (i:is)+ in setEndPosition (incr (getPosition i') (identLength i' - 1)) d+ updateEndPos d@(DataDecl _ i _ _ _) =+ setEndPosition (incr (getPosition i) (identLength i - 1)) d+ updateEndPos d@(ExternalDataDecl _ _ (i:is)) =+ let i' = last (i:is)+ in setEndPosition (incr (getPosition i') (identLength i' - 1)) d+ updateEndPos d@(ExternalDataDecl _ i _) =+ setEndPosition (incr (getPosition i) (identLength i - 1)) d+ updateEndPos d@(NewtypeDecl _ _ _ _ (c:cs)) =+ let i' = last (c:cs)+ in setEndPosition (incr (getPosition i') (qIdentLength i' - 1)) d+ updateEndPos d@(NewtypeDecl _ _ _ c _) =+ setEndPosition (getSrcSpanEnd c) d+ updateEndPos d@(TypeDecl _ _ _ ty) =+ setEndPosition (getSrcSpanEnd ty) d+ updateEndPos d@(TypeSig _ _ qty) =+ setEndPosition (getSrcSpanEnd qty) d+ updateEndPos d@(FunctionDecl _ _ _ eqs) =+ setEndPosition (getSrcSpanEnd (last eqs)) d+ updateEndPos d@(ExternalDecl (SpanInfo _ ss) _) =+ setEndPosition (end (last ss)) d+ updateEndPos d@(ExternalDecl _ _) = d+ updateEndPos d@(PatternDecl _ _ rhs) =+ setEndPosition (getSrcSpanEnd rhs) d+ updateEndPos d@(FreeDecl (SpanInfo _ ss) _) =+ setEndPosition (end (last ss)) d+ updateEndPos d@(FreeDecl _ _) = d+ updateEndPos d@(DefaultDecl (SpanInfo _ ss) _) =+ setEndPosition (end (last ss)) d+ updateEndPos d@(DefaultDecl _ _) = d+ updateEndPos d@(ClassDecl _ _ _ _ _ (d':ds)) =+ setEndPosition (getSrcSpanEnd (last (d':ds))) d+ updateEndPos d@(ClassDecl (SpanInfo _ ss) _ _ _ _ _) =+ setEndPosition (end (last ss)) d+ updateEndPos d@(ClassDecl _ _ _ _ _ _) = d+ updateEndPos d@(InstanceDecl _ _ _ _ _ (d':ds)) =+ setEndPosition (getSrcSpanEnd (last (d':ds))) d+ updateEndPos d@(InstanceDecl (SpanInfo _ ss) _ _ _ _ _) =+ setEndPosition (end (last ss)) d+ updateEndPos d@(InstanceDecl _ _ _ _ _ _) = d++ getLayoutInfo (ClassDecl _ li _ _ _ _) = li+ getLayoutInfo (InstanceDecl _ li _ _ _ _) = li+ getLayoutInfo _ = WhitespaceLayout++instance HasSpanInfo (Equation a) where+ getSpanInfo (Equation spi _ _) = spi+ setSpanInfo spi (Equation _ lhs rhs) = Equation spi lhs rhs+ updateEndPos e@(Equation _ _ rhs) =+ setEndPosition (getSrcSpanEnd rhs) e++instance HasSpanInfo ModulePragma where+ getSpanInfo (LanguagePragma sp _ ) = sp+ getSpanInfo (OptionsPragma sp _ _) = sp++ setSpanInfo sp (LanguagePragma _ ex ) = LanguagePragma sp ex+ setSpanInfo sp (OptionsPragma _ t a) = OptionsPragma sp t a++ updateEndPos p@(LanguagePragma (SpanInfo _ ss) _) =+ setEndPosition (end (last ss)) p+ updateEndPos p@(LanguagePragma _ _) = p+ updateEndPos p@(OptionsPragma (SpanInfo _ ss) _ _) =+ setEndPosition (end (last ss)) p+ updateEndPos p@(OptionsPragma _ _ _) = p++instance HasSpanInfo ExportSpec where+ getSpanInfo (Exporting sp _) = sp+ setSpanInfo sp (Exporting _ ex) = Exporting sp ex++ updateEndPos e@(Exporting (SpanInfo _ ss) _) =+ setEndPosition (end (last ss)) e+ updateEndPos e@(Exporting _ _) = e++instance HasSpanInfo Export where+ getSpanInfo (Export sp _) = sp+ getSpanInfo (ExportTypeWith sp _ _) = sp+ getSpanInfo (ExportTypeAll sp _) = sp+ getSpanInfo (ExportModule sp _) = sp++ setSpanInfo sp (Export _ qid) = Export sp qid+ setSpanInfo sp (ExportTypeWith _ qid cs) = ExportTypeWith sp qid cs+ setSpanInfo sp (ExportTypeAll _ qid) = ExportTypeAll sp qid+ setSpanInfo sp (ExportModule _ mid) = ExportModule sp mid++ updateEndPos e@(Export _ idt) =+ setEndPosition (incr (getPosition idt) (qIdentLength idt - 1)) e+ updateEndPos e@(ExportTypeWith (SpanInfo _ ss) _ _) =+ setEndPosition (end (last ss)) e+ updateEndPos e@(ExportTypeWith _ _ _) = e+ updateEndPos e@(ExportTypeAll (SpanInfo _ ss) _) =+ setEndPosition (end (last ss)) e+ updateEndPos e@(ExportTypeAll _ _) = e+ updateEndPos e@(ExportModule _ mid) =+ setEndPosition (incr (getPosition mid) (mIdentLength mid - 1)) e++instance HasSpanInfo ImportDecl where+ getSpanInfo (ImportDecl sp _ _ _ _) = sp+ setSpanInfo sp (ImportDecl _ mid q as spec) = ImportDecl sp mid q as spec++ updateEndPos i@(ImportDecl _ _ _ _ (Just spec)) =+ setEndPosition (getSrcSpanEnd spec) i+ updateEndPos i@(ImportDecl _ _ _ (Just mid) _) =+ setEndPosition (incr (getPosition mid) (mIdentLength mid - 1)) i+ updateEndPos i@(ImportDecl _ mid _ _ _) =+ setEndPosition (incr (getPosition mid) (mIdentLength mid - 1)) i++instance HasSpanInfo ImportSpec where+ getSpanInfo (Importing sp _) = sp+ getSpanInfo (Hiding sp _) = sp++ setSpanInfo sp (Importing _ im) = Importing sp im+ setSpanInfo sp (Hiding _ im) = Hiding sp im++ updateEndPos i@(Importing (SpanInfo _ ss) _) =+ setEndPosition (end (last ss)) i+ updateEndPos i@(Importing _ _) = i+ updateEndPos i@(Hiding (SpanInfo _ ss) _) =+ setEndPosition (end (last ss)) i+ updateEndPos i@(Hiding _ _) = i++instance HasSpanInfo Import where+ getSpanInfo (Import sp _) = sp+ getSpanInfo (ImportTypeWith sp _ _) = sp+ getSpanInfo (ImportTypeAll sp _) = sp++ setSpanInfo sp (Import _ qid) = Import sp qid+ setSpanInfo sp (ImportTypeWith _ qid cs) = ImportTypeWith sp qid cs+ setSpanInfo sp (ImportTypeAll _ qid) = ImportTypeAll sp qid++ updateEndPos i@(Import _ idt) =+ setEndPosition (incr (getPosition idt) (identLength idt - 1)) i+ updateEndPos i@(ImportTypeWith (SpanInfo _ ss) _ _) =+ setEndPosition (end (last ss)) i+ updateEndPos i@(ImportTypeWith _ _ _) = i+ updateEndPos i@(ImportTypeAll (SpanInfo _ ss) _) =+ setEndPosition (end (last ss)) i+ updateEndPos i@(ImportTypeAll _ _) = i++instance HasSpanInfo ConstrDecl where+ getSpanInfo (ConstrDecl sp _ _) = sp+ getSpanInfo (ConOpDecl sp _ _ _) = sp+ getSpanInfo (RecordDecl sp _ _) = sp++ setSpanInfo sp (ConstrDecl _ idt ty) = ConstrDecl sp idt ty+ setSpanInfo sp (ConOpDecl _ ty1 idt ty2) = ConOpDecl sp ty1 idt ty2+ setSpanInfo sp (RecordDecl _ idt fd) = RecordDecl sp idt fd++ updateEndPos c@(ConstrDecl _ _ (t:ts)) =+ setEndPosition (getSrcSpanEnd (last (t:ts))) c+ updateEndPos c@(ConstrDecl _ idt _) =+ setEndPosition (incr (getPosition idt) (identLength idt - 1)) c+ updateEndPos c@(ConOpDecl _ _ _ ty) =+ setEndPosition (getSrcSpanEnd ty) c+ updateEndPos c@(RecordDecl (SpanInfo _ ss) _ _) =+ setEndPosition (end (last ss)) c+ updateEndPos c@(RecordDecl _ _ _) = c++instance HasSpanInfo NewConstrDecl where+ getSpanInfo (NewConstrDecl sp _ _) = sp+ getSpanInfo (NewRecordDecl sp _ _) = sp++ setSpanInfo sp (NewConstrDecl _ idt ty) = NewConstrDecl sp idt ty+ setSpanInfo sp (NewRecordDecl _ idt fty) = NewRecordDecl sp idt fty++ updateEndPos c@(NewConstrDecl _ _ ty) =+ setEndPosition (getSrcSpanEnd ty) c+ updateEndPos c@(NewRecordDecl (SpanInfo _ ss) _ _) =+ setEndPosition (end (last ss)) c+ updateEndPos c@(NewRecordDecl _ _ _) = c++instance HasSpanInfo FieldDecl where+ getSpanInfo (FieldDecl sp _ _) = sp+ setSpanInfo sp (FieldDecl _ idt ty) = FieldDecl sp idt ty+ updateEndPos d@(FieldDecl _ _ ty) =+ setEndPosition (getSrcSpanEnd ty) d++instance HasSpanInfo TypeExpr where+ getSpanInfo (ConstructorType sp _) = sp+ getSpanInfo (ApplyType sp _ _) = sp+ getSpanInfo (VariableType sp _) = sp+ getSpanInfo (TupleType sp _) = sp+ getSpanInfo (ListType sp _) = sp+ getSpanInfo (ArrowType sp _ _) = sp+ getSpanInfo (ParenType sp _) = sp+ getSpanInfo (ForallType sp _ _) = sp++ setSpanInfo sp (ConstructorType _ qid) = ConstructorType sp qid+ setSpanInfo sp (ApplyType _ ty1 ty2) = ApplyType sp ty1 ty2+ setSpanInfo sp (VariableType _ idt) = VariableType sp idt+ setSpanInfo sp (TupleType _ tys) = TupleType sp tys+ setSpanInfo sp (ListType _ ty) = ListType sp ty+ setSpanInfo sp (ArrowType _ ty1 ty2) = ArrowType sp ty1 ty2+ setSpanInfo sp (ParenType _ ty) = ParenType sp ty+ setSpanInfo sp (ForallType _ idt ty) = ForallType sp idt ty++ updateEndPos t@(ConstructorType _ qid) =+ setEndPosition (incr (getPosition qid) (qIdentLength qid - 1)) t+ updateEndPos t@(ApplyType _ _ t2) =+ setEndPosition (getSrcSpanEnd t2) t+ updateEndPos t@(VariableType _ idt) =+ setEndPosition (incr (getPosition idt) (identLength idt - 1)) t+ updateEndPos t@(ListType (SpanInfo _ (s:ss)) _) =+ setEndPosition (end (last (s:ss))) t+ updateEndPos t@(ListType _ _) = t+ updateEndPos t@(TupleType _ tys) =+ setEndPosition (getSrcSpanEnd (last tys)) t+ updateEndPos t@(ArrowType _ _ t2) =+ setEndPosition (getSrcSpanEnd t2) t+ updateEndPos t@(ParenType (SpanInfo _ (s:ss)) _) =+ setEndPosition (end (last (s:ss))) t+ updateEndPos t@(ParenType _ _) = t+ updateEndPos t@(ForallType _ _ _) = t -- not a parseable type++instance HasSpanInfo QualTypeExpr where+ getSpanInfo (QualTypeExpr sp _ _) = sp+ setSpanInfo sp (QualTypeExpr _ cx ty) = QualTypeExpr sp cx ty+ updateEndPos t@(QualTypeExpr _ _ ty) =+ setEndPosition (getSrcSpanEnd ty) t++instance HasSpanInfo Constraint where+ getSpanInfo (Constraint sp _ _) = sp+ setSpanInfo sp (Constraint _ qid ty) = Constraint sp qid ty+ updateEndPos c@(Constraint (SpanInfo _ (s:ss)) _ _) =+ setEndPosition (end (last (s:ss))) c+ updateEndPos c@(Constraint _ _ ty) =+ setEndPosition (getSrcSpanEnd ty) c++instance HasSpanInfo (Lhs a) where+ getSpanInfo (FunLhs sp _ _) = sp+ getSpanInfo (OpLhs sp _ _ _) = sp+ getSpanInfo (ApLhs sp _ _) = sp++ setSpanInfo sp (FunLhs _ idt ps) = FunLhs sp idt ps+ setSpanInfo sp (OpLhs _ p1 idt p2) = OpLhs sp p1 idt p2+ setSpanInfo sp (ApLhs _ lhs ps) = ApLhs sp lhs ps++ updateEndPos l@(FunLhs _ _ (p:ps)) =+ setEndPosition (getSrcSpanEnd (last (p:ps))) l+ updateEndPos l@(FunLhs _ idt _) =+ setEndPosition (incr (getPosition idt) (identLength idt - 1)) l+ updateEndPos l@(OpLhs _ _ _ p) =+ setEndPosition (getSrcSpanEnd p) l+ updateEndPos l@(ApLhs _ _ (p:ps)) =+ setEndPosition (getSrcSpanEnd (last (p:ps))) l+ updateEndPos l@(ApLhs (SpanInfo _ [_,s]) _ _) =+ setEndPosition (end s) l+ updateEndPos l@(ApLhs _ _ _) = l+++instance HasSpanInfo (Rhs a) where+ getSpanInfo (SimpleRhs sp _ _ _) = sp+ getSpanInfo (GuardedRhs sp _ _ _) = sp++ setSpanInfo sp (SimpleRhs _ li ex ds) = SimpleRhs sp li ex ds+ setSpanInfo sp (GuardedRhs _ li cs ds) = GuardedRhs sp li cs ds++ updateEndPos r@(SimpleRhs (SpanInfo _ [_,_]) _ _ (d:ds)) =+ setEndPosition (getSrcSpanEnd (last (d:ds))) r+ updateEndPos r@(SimpleRhs (SpanInfo _ [_,s]) _ _ _) =+ setEndPosition (end s) r+ updateEndPos r@(SimpleRhs _ _ e _) =+ setEndPosition (getSrcSpanEnd e) r+ updateEndPos r@(GuardedRhs (SpanInfo _ [_,_]) _ _ (d:ds)) =+ setEndPosition (getSrcSpanEnd (last (d:ds))) r+ updateEndPos r@(GuardedRhs (SpanInfo _ [_,s]) _ _ _) =+ setEndPosition (end s) r+ updateEndPos r@(GuardedRhs _ _ cs _) =+ setEndPosition (getSrcSpanEnd (last cs)) r++ getLayoutInfo (SimpleRhs _ li _ _) = li+ getLayoutInfo (GuardedRhs _ li _ _) = li++instance HasSpanInfo (CondExpr a) where+ getSpanInfo (CondExpr sp _ _) = sp+ setSpanInfo sp (CondExpr _ e1 e2) = CondExpr sp e1 e2+ updateEndPos ce@(CondExpr _ _ e) =+ setEndPosition (getSrcSpanEnd e) ce++instance HasSpanInfo (Pattern a) where+ getSpanInfo (LiteralPattern sp _ _) = sp+ getSpanInfo (NegativePattern sp _ _) = sp+ getSpanInfo (VariablePattern sp _ _) = sp+ getSpanInfo (ConstructorPattern sp _ _ _) = sp+ getSpanInfo (InfixPattern sp _ _ _ _) = sp+ getSpanInfo (ParenPattern sp _) = sp+ getSpanInfo (RecordPattern sp _ _ _) = sp+ getSpanInfo (TuplePattern sp _) = sp+ getSpanInfo (ListPattern sp _ _) = sp+ getSpanInfo (AsPattern sp _ _) = sp+ getSpanInfo (LazyPattern sp _) = sp+ getSpanInfo (FunctionPattern sp _ _ _) = sp+ getSpanInfo (InfixFuncPattern sp _ _ _ _) = sp++ setSpanInfo sp (LiteralPattern _ a l) = LiteralPattern sp a l+ setSpanInfo sp (NegativePattern _ a l) = NegativePattern sp a l+ setSpanInfo sp (VariablePattern _ a v) = VariablePattern sp a v+ setSpanInfo sp (ConstructorPattern _ a c ts) = ConstructorPattern sp a c ts+ setSpanInfo sp (InfixPattern _ a t1 op t2) = InfixPattern sp a t1 op t2+ setSpanInfo sp (ParenPattern _ t) = ParenPattern sp t+ setSpanInfo sp (RecordPattern _ a c fs) = RecordPattern sp a c fs+ setSpanInfo sp (TuplePattern _ ts) = TuplePattern sp ts+ setSpanInfo sp (ListPattern _ a ts) = ListPattern sp a ts+ setSpanInfo sp (AsPattern _ v t) = AsPattern sp v t+ setSpanInfo sp (LazyPattern _ t) = LazyPattern sp t+ setSpanInfo sp (FunctionPattern _ a f' ts) = FunctionPattern sp a f' ts+ setSpanInfo sp (InfixFuncPattern _ a t1 op t2) = InfixFuncPattern sp a t1 op t2++ updateEndPos p@(LiteralPattern _ _ _) = p+ updateEndPos p@(NegativePattern _ _ _) = p+ updateEndPos p@(VariablePattern _ _ v) =+ setEndPosition (incr (getPosition v) (identLength v - 1)) p+ updateEndPos p@(ConstructorPattern _ _ _ (t:ts)) =+ setEndPosition (getSrcSpanEnd (last (t:ts))) p+ updateEndPos p@(ConstructorPattern _ _ c _) =+ setEndPosition (incr (getPosition c) (qIdentLength c - 1)) p+ updateEndPos p@(InfixPattern _ _ _ _ t2) =+ setEndPosition (getSrcSpanEnd t2) p+ updateEndPos p@(ParenPattern (SpanInfo _ (s:ss)) _) =+ setEndPosition (end (last (s:ss))) p+ updateEndPos p@(ParenPattern _ _) = p+ updateEndPos p@(RecordPattern (SpanInfo _ (s:ss)) _ _ _) =+ setEndPosition (end (last (s:ss))) p+ updateEndPos p@(RecordPattern _ _ _ _) = p+ updateEndPos p@(TuplePattern (SpanInfo _ (s:ss)) _) =+ setEndPosition (end (last (s:ss))) p+ updateEndPos p@(TuplePattern _ _) = p+ updateEndPos p@(ListPattern (SpanInfo _ (s:ss)) _ _) =+ setEndPosition (end (last (s:ss))) p+ updateEndPos p@(ListPattern _ _ _) = p+ updateEndPos p@(AsPattern _ _ t) =+ setEndPosition (getSrcSpanEnd t) p+ updateEndPos p@(LazyPattern _ t) =+ setEndPosition (getSrcSpanEnd t) p+ updateEndPos p@(FunctionPattern _ _ _ _) = p+ updateEndPos p@(InfixFuncPattern _ _ _ _ _) = p++instance HasSpanInfo (Expression a) where+ getSpanInfo (Literal sp _ _) = sp+ getSpanInfo (Variable sp _ _) = sp+ getSpanInfo (Constructor sp _ _) = sp+ getSpanInfo (Paren sp _) = sp+ getSpanInfo (Typed sp _ _) = sp+ getSpanInfo (Record sp _ _ _) = sp+ getSpanInfo (RecordUpdate sp _ _) = sp+ getSpanInfo (Tuple sp _) = sp+ getSpanInfo (List sp _ _) = sp+ getSpanInfo (ListCompr sp _ _) = sp+ getSpanInfo (EnumFrom sp _) = sp+ getSpanInfo (EnumFromThen sp _ _) = sp+ getSpanInfo (EnumFromTo sp _ _) = sp+ getSpanInfo (EnumFromThenTo sp _ _ _) = sp+ getSpanInfo (UnaryMinus sp _) = sp+ getSpanInfo (Apply sp _ _) = sp+ getSpanInfo (InfixApply sp _ _ _) = sp+ getSpanInfo (LeftSection sp _ _) = sp+ getSpanInfo (RightSection sp _ _) = sp+ getSpanInfo (Lambda sp _ _) = sp+ getSpanInfo (Let sp _ _ _) = sp+ getSpanInfo (Do sp _ _ _) = sp+ getSpanInfo (IfThenElse sp _ _ _) = sp+ getSpanInfo (Case sp _ _ _ _) = sp++ setSpanInfo sp (Literal _ a l) = Literal sp a l+ setSpanInfo sp (Variable _ a v) = Variable sp a v+ setSpanInfo sp (Constructor _ a c) = Constructor sp a c+ setSpanInfo sp (Paren _ e) = Paren sp e+ setSpanInfo sp (Typed _ e qty) = Typed sp e qty+ setSpanInfo sp (Record _ a c fs) = Record sp a c fs+ setSpanInfo sp (RecordUpdate _ e fs) = RecordUpdate sp e fs+ setSpanInfo sp (Tuple _ es) = Tuple sp es+ setSpanInfo sp (List _ a es) = List sp a es+ setSpanInfo sp (ListCompr _ e stms) = ListCompr sp e stms+ setSpanInfo sp (EnumFrom _ e) = EnumFrom sp e+ setSpanInfo sp (EnumFromThen _ e1 e2) = EnumFromThen sp e1 e2+ setSpanInfo sp (EnumFromTo _ e1 e2) = EnumFromTo sp e1 e2+ setSpanInfo sp (EnumFromThenTo _ e1 e2 e3) = EnumFromThenTo sp e1 e2 e3+ setSpanInfo sp (UnaryMinus _ e) = UnaryMinus sp e+ setSpanInfo sp (Apply _ e1 e2) = Apply sp e1 e2+ setSpanInfo sp (InfixApply _ e1 op e2) = InfixApply sp e1 op e2+ setSpanInfo sp (LeftSection _ e op) = LeftSection sp e op+ setSpanInfo sp (RightSection _ op e) = RightSection sp op e+ setSpanInfo sp (Lambda _ ts e) = Lambda sp ts e+ setSpanInfo sp (Let _ li ds e) = Let sp li ds e+ setSpanInfo sp (Do _ li stms e) = Do sp li stms e+ setSpanInfo sp (IfThenElse _ e1 e2 e3) = IfThenElse sp e1 e2 e3+ setSpanInfo sp (Case _ li ct e as) = Case sp li ct e as++ updateEndPos e@(Literal _ _ _) = e+ updateEndPos e@(Variable _ _ v) =+ setEndPosition (incr (getPosition v) (qIdentLength v - 1)) e+ updateEndPos e@(Constructor _ _ c) =+ setEndPosition (incr (getPosition c) (qIdentLength c - 1)) e+ updateEndPos e@(Paren (SpanInfo _ [_,s]) _) =+ setEndPosition (end s) e+ updateEndPos e@(Paren _ _) = e+ updateEndPos e@(Typed _ _ qty) =+ setEndPosition (getSrcSpanEnd qty) e+ updateEndPos e@(Record (SpanInfo _ (s:ss)) _ _ _) =+ setEndPosition (end (last (s:ss))) e+ updateEndPos e@(Record _ _ _ _) = e+ updateEndPos e@(RecordUpdate (SpanInfo _ (s:ss)) _ _) =+ setEndPosition (end (last (s:ss))) e+ updateEndPos e@(RecordUpdate _ _ _) = e+ updateEndPos e@(Tuple (SpanInfo _ [_,s]) _) =+ setEndPosition (end s) e+ updateEndPos e@(Tuple _ _) = e+ updateEndPos e@(List (SpanInfo _ (s:ss)) _ _) =+ setEndPosition (end (last (s:ss))) e+ updateEndPos e@(List _ _ _) = e+ updateEndPos e@(ListCompr (SpanInfo _ (s:ss)) _ _) =+ setEndPosition (end (last (s:ss))) e+ updateEndPos e@(ListCompr _ _ _) = e+ updateEndPos e@(EnumFrom (SpanInfo _ [_,_,s]) _) =+ setEndPosition (end s) e+ updateEndPos e@(EnumFrom _ _) = e+ updateEndPos e@(EnumFromTo (SpanInfo _ [_,_,s]) _ _) =+ setEndPosition (end s) e+ updateEndPos e@(EnumFromTo _ _ _) = e+ updateEndPos e@(EnumFromThen (SpanInfo _ [_,_,_,s]) _ _) =+ setEndPosition (end s) e+ updateEndPos e@(EnumFromThen _ _ _) = e+ updateEndPos e@(EnumFromThenTo (SpanInfo _ [_,_,_,s]) _ _ _) =+ setEndPosition (end s) e+ updateEndPos e@(EnumFromThenTo _ _ _ _) = e+ updateEndPos e@(UnaryMinus _ e') =+ setEndPosition (getSrcSpanEnd e') e+ updateEndPos e@(Apply _ _ e') =+ setEndPosition (getSrcSpanEnd e') e+ updateEndPos e@(InfixApply _ _ _ e') =+ setEndPosition (getSrcSpanEnd e') e+ updateEndPos e@(LeftSection (SpanInfo _ [_,s]) _ _) =+ setEndPosition (end s) e+ updateEndPos e@(LeftSection _ _ _) = e+ updateEndPos e@(RightSection (SpanInfo _ [_,s]) _ _) =+ setEndPosition (end s) e+ updateEndPos e@(RightSection _ _ _) = e+ updateEndPos e@(Lambda _ _ e') =+ setEndPosition (getSrcSpanEnd e') e+ updateEndPos e@(Let _ _ _ e') =+ setEndPosition (getSrcSpanEnd e') e+ updateEndPos e@(Do _ _ _ e') =+ setEndPosition (getSrcSpanEnd e') e+ updateEndPos e@(IfThenElse _ _ _ e') =+ setEndPosition (getSrcSpanEnd e') e+ updateEndPos e@(Case _ _ _ _ (a:as)) =+ setEndPosition (getSrcSpanEnd (last (a:as))) e+ updateEndPos e@(Case (SpanInfo _ (s:ss)) _ _ _ _) =+ setEndPosition (end (last (s:ss))) e+ updateEndPos e@(Case _ _ _ _ _) = e++ getLayoutInfo (Let _ li _ _) = li+ getLayoutInfo (Do _ li _ _) = li+ getLayoutInfo (Case _ li _ _ _) = li+ getLayoutInfo _ = WhitespaceLayout++instance HasSpanInfo (Statement a) where+ getSpanInfo (StmtExpr sp _) = sp+ getSpanInfo (StmtDecl sp _ _) = sp+ getSpanInfo (StmtBind sp _ _) = sp++ setSpanInfo sp (StmtExpr _ ex) = StmtExpr sp ex+ setSpanInfo sp (StmtDecl _ li ds) = StmtDecl sp li ds+ setSpanInfo sp (StmtBind _ p ex) = StmtBind sp p ex++ updateEndPos s@(StmtExpr _ e) =+ setEndPosition (getSrcSpanEnd e) s+ updateEndPos s@(StmtBind _ _ e) =+ setEndPosition (getSrcSpanEnd e) s+ updateEndPos s@(StmtDecl _ _ (d:ds)) =+ setEndPosition (getSrcSpanEnd (last (d:ds))) s+ updateEndPos s@(StmtDecl (SpanInfo _ [s']) _ _) = -- empty let+ setEndPosition (end s') s+ updateEndPos s@(StmtDecl _ _ _) = s++ getLayoutInfo (StmtDecl _ li _) = li+ getLayoutInfo _ = WhitespaceLayout++instance HasSpanInfo (Alt a) where+ getSpanInfo (Alt sp _ _) = sp+ setSpanInfo sp (Alt _ p rhs) = Alt sp p rhs+ updateEndPos a@(Alt _ _ rhs) =+ setEndPosition (getSrcSpanEnd rhs) a++instance HasSpanInfo (Field a) where+ getSpanInfo (Field sp _ _) = sp+ setSpanInfo sp (Field _ qid a) = Field sp qid a+ updateEndPos f@(Field (SpanInfo _ ss) _ _) =+ setEndPosition (end (last ss)) f+ updateEndPos f@ (Field _ _ _) = f++instance HasSpanInfo (Goal a) where+ getSpanInfo (Goal sp _ _ _) = sp+ setSpanInfo sp (Goal _ li e ds) = Goal sp li e ds++ updateEndPos g@(Goal (SpanInfo _ [_]) _ _ (d:ds)) =+ setEndPosition (getSrcSpanEnd (last (d:ds))) g+ updateEndPos g@(Goal (SpanInfo _ [s]) _ _ _) =+ setEndPosition (end s) g+ updateEndPos g@(Goal _ _ _ _) = g++ getLayoutInfo (Goal _ li _ _) = li++instance HasPosition (Module a) where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition (Decl a) where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition (Equation a) where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition ModulePragma where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition ExportSpec where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition ImportDecl where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition ImportSpec where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition Export where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition Import where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition ConstrDecl where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition TypeExpr where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition QualTypeExpr where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition NewConstrDecl where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition Constraint where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition FieldDecl where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition (Lhs a) where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition (Rhs a) where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition (CondExpr a) where+ getPosition = getStartPosition++instance HasPosition (Pattern a) where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition (Expression a) where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition (Alt a) where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition (Goal a) where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition (Field a) where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition (Statement a) where+ getPosition = getStartPosition+ setPosition = setStartPosition++instance HasPosition (InfixOp a) where+ getPosition (InfixOp _ q) = getPosition q+ getPosition (InfixConstr _ q) = getPosition q++ setPosition p (InfixOp a q) = InfixOp a (setPosition p q)+ setPosition p (InfixConstr a q) = InfixConstr a (setPosition p q)++instance Binary a => Binary (Module a) where+ put (Module spi li ps mid ex im ds) = put spi >> put li >> put ps >>+ put mid >> put ex >> put im >> put ds+ get = Module <$> get <*> get <*> get <*> get <*> get <*> get <*> get++instance Binary ModulePragma where+ put (LanguagePragma spi ex ) = putWord8 0 >> put spi >> put ex+ put (OptionsPragma spi t s) = putWord8 1 >> put spi >> put t >> put s++ get = do+ x <- getWord8+ case x of+ 0 -> liftM2 LanguagePragma get get+ 1 -> liftM3 OptionsPragma get get get+ _ -> fail "Invalid encoding for ModulePragma"++instance Binary ExportSpec where+ put (Exporting spi es) = put spi >> put es+ get = liftM2 Exporting get get++instance Binary Export where+ put (Export spi qid ) = putWord8 0 >> put spi >> put qid+ put (ExportTypeWith spi qid is) = putWord8 1 >> put spi >> put qid >> put is+ put (ExportTypeAll spi qid ) = putWord8 2 >> put spi >> put qid+ put (ExportModule spi mid ) = putWord8 3 >> put spi >> put mid++ get = do+ x <- getWord8+ case x of+ 0 -> liftM2 Export get get+ 1 -> liftM3 ExportTypeWith get get get+ 2 -> liftM2 ExportTypeAll get get+ 3 -> liftM2 ExportModule get get+ _ -> fail "Invalid encoding for Export"++instance Binary ImportDecl where+ put (ImportDecl spi mid q al im) = put spi >> put mid >> put q >>+ put al >> put im+ get = ImportDecl <$> get <*> get <*> get <*> get <*> get++instance Binary ImportSpec where+ put (Importing spi im) = putWord8 0 >> put spi >> put im+ put (Hiding spi im) = putWord8 1 >> put spi >> put im++ get = do+ x <- getWord8+ case x of+ 0 -> liftM2 Importing get get+ 1 -> liftM2 Hiding get get+ _ -> fail "Invalid encoding for ImportSpec"++instance Binary Import where+ put (Import spi idt ) = putWord8 0 >> put spi >> put idt+ put (ImportTypeWith spi idt is) = putWord8 1 >> put spi >> put idt >> put is+ put (ImportTypeAll spi idt ) = putWord8 2 >> put spi >> put idt++ get = do+ x <- getWord8+ case x of+ 0 -> liftM2 Import get get+ 1 -> liftM3 ImportTypeWith get get get+ 2 -> liftM2 ImportTypeAll get get+ _ -> fail "Invalid encoding for Import"++instance Binary a => Binary (Decl a) where+ put (InfixDecl spi i pr is) =+ putWord8 0 >> put spi >> put i >> put pr >> put is+ put (DataDecl spi idt vs cns cls) =+ putWord8 1 >> put spi >> put idt >> put vs >> put cns >> put cls+ put (ExternalDataDecl spi idt vs) =+ putWord8 2 >> put spi >> put idt >> put vs+ put (NewtypeDecl spi idt vs cn cls) =+ putWord8 3 >> put spi >> put idt >> put vs >> put cn >> put cls >> put cls+ put (TypeDecl spi idt vs ty) =+ putWord8 4 >> put spi >> put idt >> put vs >> put ty+ put (TypeSig spi fs ty) =+ putWord8 5 >> put spi >> put fs >> put ty+ put (FunctionDecl spi a f eqs) =+ putWord8 6 >> put spi >> put a >> put f >> put eqs+ put (ExternalDecl spi vs) =+ putWord8 7 >> put spi >> put vs+ put (PatternDecl spi p rhs) =+ putWord8 8 >> put spi >> put p >> put rhs+ put (FreeDecl spi vs) =+ putWord8 9 >> put spi >> put vs+ put (DefaultDecl spi tys) =+ putWord8 10 >> put spi >> put tys+ put (ClassDecl spi li cx cls v ds) =+ putWord8 11 >> put spi >> put li >> put cx >> put cls >> put v >> put ds+ put (InstanceDecl spi li cx cls ty ds) =+ putWord8 12 >> put spi >> put li >> put cx >> put cls >> put ty >> put ds++ get = do+ x <- getWord8+ case x of+ 0 -> InfixDecl <$> get <*> get <*> get <*> get+ 1 -> DataDecl <$> get <*> get <*> get <*> get <*> get+ 2 -> ExternalDataDecl <$> get <*> get <*> get+ 3 -> NewtypeDecl <$> get <*> get <*> get <*> get <*> get+ 4 -> TypeDecl <$> get <*> get <*> get <*> get+ 5 -> TypeSig <$> get <*> get <*> get+ 6 -> FunctionDecl <$> get <*> get <*> get <*> get+ 7 -> ExternalDecl <$> get <*> get+ 8 -> PatternDecl <$> get <*> get <*> get+ 9 -> FreeDecl <$> get <*> get+ 10 -> DefaultDecl <$> get <*> get+ 11 -> ClassDecl <$> get <*> get <*> get <*> get <*> get <*> get+ 12 -> InstanceDecl <$> get <*> get <*> get <*> get <*> get <*> get+ _ -> fail "Invalid encoding for Decl"++instance Binary Infix where+ put InfixL = putWord8 0+ put InfixR = putWord8 1+ put Infix = putWord8 2++ get = do+ x <- getWord8+ case x of+ 0 -> return InfixL+ 1 -> return InfixR+ 2 -> return Infix+ _ -> fail "Invalid encoding for Infix"++instance Binary ConstrDecl where+ put (ConstrDecl spi idt tys) =+ putWord8 0 >> put spi >> put idt >> put tys+ put (ConOpDecl spi ty1 idt ty2) =+ putWord8 1 >> put spi >> put ty1 >> put idt >> put ty2+ put (RecordDecl spi idt fs) =+ putWord8 2 >> put spi >> put idt >> put fs++ get = do+ x <- getWord8+ case x of+ 0 -> liftM3 ConstrDecl get get get+ 1 -> ConOpDecl <$> get <*> get <*> get <*> get+ 2 -> liftM3 RecordDecl get get get+ _ -> fail "Invalid encoding for ConstrDecl"++instance Binary NewConstrDecl where+ put (NewConstrDecl spi c ty) =+ putWord8 0 >> put spi >> put c >> put ty+ put (NewRecordDecl spi c fs) =+ putWord8 1 >> put spi >> put c >> put fs++ get = do+ x <- getWord8+ case x of+ 0 -> liftM3 NewConstrDecl get get get+ 1 -> liftM3 NewRecordDecl get get get+ _ -> fail "Invalid encoding for NewConstrDecl"++instance Binary FieldDecl where+ put (FieldDecl spi is ty) = put spi >> put is >> put ty+ get = liftM3 FieldDecl get get get++instance Binary QualTypeExpr where+ put (QualTypeExpr spi ctx te) = put spi >> put ctx >> put te+ get = liftM3 QualTypeExpr get get get++instance Binary TypeExpr where+ put (ConstructorType spi qid) =+ putWord8 0 >> put spi >> put qid+ put (ApplyType spi ty1 ty2) =+ putWord8 1 >> put spi >> put ty1 >> put ty2+ put (VariableType spi idt) =+ putWord8 2 >> put spi >> put idt+ put (TupleType spi tys) =+ putWord8 3 >> put spi >> put tys+ put (ListType spi ty) =+ putWord8 4 >> put spi >> put ty+ put (ArrowType spi ty1 ty2) =+ putWord8 5 >> put spi >> put ty1 >> put ty2+ put (ParenType spi ty) =+ putWord8 6 >> put spi >> put ty+ put (ForallType spi is ty) =+ putWord8 7 >> put spi >> put is >> put ty++ get = do+ x <- getWord8+ case x of+ 0 -> liftM2 ConstructorType get get+ 1 -> liftM3 ApplyType get get get+ 2 -> liftM2 VariableType get get+ 3 -> liftM2 TupleType get get+ 4 -> liftM2 ListType get get+ 5 -> liftM3 ArrowType get get get+ 6 -> liftM2 ParenType get get+ 7 -> liftM3 ForallType get get get+ _ -> fail "Invalid encoding for TypeExpr"++instance Binary Constraint where+ put (Constraint spi cls ty) = put spi >> put cls >> put ty+ get = liftM3 Constraint get get get++instance Binary a => Binary (Equation a) where+ put (Equation spi lhs rhs) = put spi >> put lhs >> put rhs+ get = liftM3 Equation get get get++instance Binary a => Binary (Lhs a) where+ put (FunLhs spi f ps) =+ putWord8 0 >> put spi >> put f >> put ps+ put (OpLhs spi p1 op p2) =+ putWord8 1 >> put spi >> put p1 >> put op >> put p2+ put (ApLhs spi lhs ps) =+ putWord8 2 >> put spi >> put lhs >> put ps++ get = do+ x <- getWord8+ case x of+ 0 -> liftM3 FunLhs get get get+ 1 -> OpLhs <$> get <*> get <*> get <*> get+ 2 -> liftM3 ApLhs get get get+ _ -> fail "Invalid encoding for Lhs"++instance Binary a => Binary (Rhs a) where+ put (SimpleRhs spi li e ds) =+ putWord8 0 >> put spi >> put li >> put e >> put ds+ put (GuardedRhs spi li gs ds) =+ putWord8 1 >> put spi >> put li >> put gs >> put ds++ get = do+ x <- getWord8+ case x of+ 0 -> SimpleRhs <$> get <*> get <*> get <*> get+ 1 -> GuardedRhs <$> get <*> get <*> get <*> get+ _ -> fail "Invalid encoding for Rhs"++instance Binary a => Binary (CondExpr a) where+ put (CondExpr spi g e) = put spi >> put g >> put e+ get = liftM3 CondExpr get get get++instance Binary Literal where+ put (Char c) = putWord8 0 >> put c+ put (Int i) = putWord8 1 >> put i+ put (Float f) = putWord8 2 >> put (show f)+ put (String s) = putWord8 3 >> put s++ get = do+ x <- getWord8+ case x of+ 0 -> fmap Char get+ 1 -> fmap Int get+ 2 -> fmap (Float . read) get+ 3 -> fmap String get+ _ -> fail "Invalid encoding for Literal"++instance Binary a => Binary (Pattern a) where+ put (LiteralPattern spi a l) =+ putWord8 0 >> put spi >> put a >> put l+ put (NegativePattern spi a l) =+ putWord8 1 >> put spi >> put a >> put l+ put (VariablePattern spi a idt) =+ putWord8 2 >> put spi >> put a >> put idt+ put (ConstructorPattern spi a qid ps) =+ putWord8 3 >> put spi >> put a >> put qid >> put ps+ put (InfixPattern spi a p1 qid p2) =+ putWord8 4 >> put spi >> put a >> put p1 >> put qid >> put p2+ put (ParenPattern spi p) =+ putWord8 5 >> put spi >> put p+ put (RecordPattern spi a qid fs) =+ putWord8 6 >> put spi >> put a >> put qid >> put fs+ put (TuplePattern spi ps) =+ putWord8 7 >> put spi >> put ps+ put (ListPattern spi a ps) =+ putWord8 8 >> put spi >> put a >> put ps+ put (AsPattern spi idt p) =+ putWord8 9 >> put spi >> put idt >> put p+ put (LazyPattern spi p) =+ putWord8 10 >> put spi >> put p+ put (FunctionPattern spi a qid ps) =+ putWord8 11 >> put spi >> put a >> put qid >> put ps+ put (InfixFuncPattern spi a p1 qid p2) =+ putWord8 12 >> put spi >> put a >> put p1 >> put qid >> put p2++ get = do+ x <- getWord8+ case x of+ 0 -> liftM3 LiteralPattern get get get+ 1 -> liftM3 NegativePattern get get get+ 2 -> liftM3 VariablePattern get get get+ 3 -> ConstructorPattern <$> get <*> get <*> get <*> get+ 4 -> InfixPattern <$> get <*> get <*> get <*> get <*> get+ 5 -> liftM2 ParenPattern get get+ 6 -> RecordPattern <$> get <*> get <*> get <*> get+ 7 -> liftM2 TuplePattern get get+ 8 -> liftM3 ListPattern get get get+ 9 -> liftM3 AsPattern get get get+ 10 -> liftM2 LazyPattern get get+ 11 -> FunctionPattern <$> get <*> get <*> get <*> get+ 12 -> InfixFuncPattern <$> get <*> get <*> get <*> get <*> get+ _ -> fail "Invalid encoding for Pattern"++instance Binary a => Binary (Expression a) where+ put (Literal spi a l) =+ putWord8 0 >> put spi >> put a >> put l+ put (Variable spi a qid) =+ putWord8 1 >> put spi >> put a >> put qid+ put (Constructor spi a qid) =+ putWord8 2 >> put spi >> put a >> put qid+ put (Paren spi e) =+ putWord8 3 >> put spi >> put e+ put (Typed spi e ty) =+ putWord8 4 >> put spi >> put e >> put ty+ put (Record spi a qid fs) =+ putWord8 5 >> put spi >> put a >> put qid >> put fs+ put (RecordUpdate spi e fs) =+ putWord8 6 >> put spi >> put e >> put fs+ put (Tuple spi es) =+ putWord8 7 >> put spi >> put es+ put (List spi a es) =+ putWord8 8 >> put spi >> put a >> put es+ put (ListCompr spi e stms) =+ putWord8 9 >> put spi >> put e >> put stms+ put (EnumFrom spi e1) =+ putWord8 10 >> put spi >> put e1+ put (EnumFromThen spi e1 e2) =+ putWord8 11 >> put spi >> put e1 >> put e2+ put (EnumFromTo spi e1 e2) =+ putWord8 12 >> put spi >> put e1 >> put e2+ put (EnumFromThenTo spi e1 e2 e3) =+ putWord8 13 >> put spi >> put e1 >> put e2 >> put e3+ put (UnaryMinus spi e) =+ putWord8 14 >> put spi >> put e+ put (Apply spi e1 e2) =+ putWord8 15 >> put spi >> put e1 >> put e2+ put (InfixApply spi e1 op e2) =+ putWord8 16 >> put spi >> put e1 >> put op >> put e2+ put (LeftSection spi e op) =+ putWord8 17 >> put spi >> put e >> put op+ put (RightSection spi op e) =+ putWord8 18 >> put spi >> put op >> put e+ put (Lambda spi ps e) =+ putWord8 19 >> put spi >> put ps >> put e+ put (Let spi li ds e) =+ putWord8 20 >> put spi >> put li >> put ds >> put e+ put (Do spi li stms e) =+ putWord8 21 >> put spi >> put li >> put stms >> put e+ put (IfThenElse spi e1 e2 e3) =+ putWord8 22 >> put spi >> put e1 >> put e2 >> put e3+ put (Case spi li cty e as) =+ putWord8 23 >> put spi >> put li >> put cty >> put e >> put as++ get = do+ x <- getWord8+ case x of+ 0 -> liftM3 Literal get get get+ 1 -> liftM3 Variable get get get+ 2 -> liftM3 Constructor get get get+ 3 -> liftM2 Paren get get+ 4 -> liftM3 Typed get get get+ 5 -> Record <$> get <*> get <*> get <*> get+ 6 -> RecordUpdate <$> get <*> get <*> get+ 7 -> liftM2 Tuple get get+ 8 -> liftM3 List get get get+ 9 -> liftM3 ListCompr get get get+ 10 -> liftM2 EnumFrom get get+ 11 -> liftM3 EnumFromThen get get get+ 12 -> liftM3 EnumFromTo get get get+ 13 -> EnumFromThenTo <$> get <*> get <*> get <*> get+ 14 -> liftM2 UnaryMinus get get+ 15 -> liftM3 Apply get get get+ 16 -> InfixApply <$> get <*> get <*> get <*> get+ 17 -> liftM3 LeftSection get get get+ 18 -> liftM3 RightSection get get get+ 19 -> liftM3 Lambda get get get+ 20 -> Let <$> get <*> get <*> get <*> get+ 21 -> Do <$> get <*> get <*> get <*> get+ 22 -> IfThenElse <$> get <*> get <*> get <*> get+ 23 -> Case <$> get <*> get <*> get <*> get <*> get+ _ -> fail "Invalid encoding for Expression"++instance Binary a => Binary (InfixOp a) where+ put (InfixOp a qid) = putWord8 0 >> put a >> put qid+ put (InfixConstr a qid) = putWord8 1 >> put a >> put qid++ get = do+ x <- getWord8+ case x of+ 0 -> liftM2 InfixOp get get+ 1 -> liftM2 InfixConstr get get+ _ -> fail "Invalid encoding for InfixOp"++instance Binary a => Binary (Statement a) where+ put (StmtExpr spi e) = putWord8 0 >> put spi >> put e+ put (StmtDecl spi li ds) = putWord8 1 >> put spi >> put li >> put ds+ put (StmtBind spi p e) = putWord8 2 >> put spi >> put p >> put e++ get = do+ x <- getWord8+ case x of+ 0 -> liftM2 StmtExpr get get+ 1 -> liftM3 StmtDecl get get get+ 2 -> liftM3 StmtBind get get get+ _ -> fail "Invalid encoding for Statement"++instance Binary CaseType where+ put Rigid = putWord8 0+ put Flex = putWord8 1++ get = do+ x <- getWord8+ case x of+ 0 -> return Rigid+ 1 -> return Flex+ _ -> fail "Invalid encoding for CaseType"++instance Binary a => Binary (Alt a) where+ put (Alt spi p rhs) = put spi >> put p >> put rhs+ get = liftM3 Alt get get get++instance Binary a => Binary (Field a) where+ put (Field spi qid a) = put spi >> put qid >> put a+ get = liftM3 Field get get get++instance Binary a => Binary (Var a) where+ put (Var a idt) = put a >> put idt+ get = liftM2 Var get get++{- HLINT ignore "Use record patterns"-}
+ src/Curry/Syntax/Utils.hs view
@@ -0,0 +1,325 @@+{- |+ Module : $Header$+ Description : Utility functions for Curry's abstract syntax+ Copyright : (c) 1999 - 2004 Wolfgang Lux+ 2005 Martin Engelke+ 2011 - 2014 Björn Peemöller+ 2015 Jan Tikovsky+ 2016 Finn Teegen+ License : BSD-3-clause++ Maintainer : bjp@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This module provides some utility functions for working with the+ abstract syntax tree of Curry.+-}++module Curry.Syntax.Utils+ ( hasLanguageExtension, knownExtensions+ , isTopDecl, isBlockDecl+ , isTypeSig, infixOp, isTypeDecl, isValueDecl, isInfixDecl+ , isDefaultDecl, isClassDecl, isTypeOrClassDecl, isInstanceDecl+ , isFunctionDecl, isExternalDecl, patchModuleId+ , isVariablePattern+ , isVariableType, isSimpleType+ , typeConstr, typeVariables, varIdent+ , flatLhs, eqnArity, fieldLabel, fieldTerm, field2Tuple, opName+ , funDecl, mkEquation, simpleRhs, patDecl, varDecl, constrPattern, caseAlt+ , mkLet, mkVar, mkCase, mkLambda+ , apply, unapply+ , constrId, nconstrId+ , nconstrType+ , recordLabels, nrecordLabels+ , methods, impls, imethod, imethodArity+ , shortenModuleAST+ ) where++import Control.Monad.State++import Curry.Base.Ident+import Curry.Base.SpanInfo+import Curry.Files.Filenames (takeBaseName)+import Curry.Syntax.Extension+import Curry.Syntax.Type++-- |Check whether a 'Module' has a specific 'KnownExtension' enabled by a pragma+hasLanguageExtension :: Module a -> KnownExtension -> Bool+hasLanguageExtension mdl ext = ext `elem` knownExtensions mdl++-- |Extract all known extensions from a 'Module'+knownExtensions :: Module a -> [KnownExtension]+knownExtensions (Module _ _ ps _ _ _ _) =+ [ e | LanguagePragma _ exts <- ps, KnownExtension _ e <- exts]++-- |Replace the generic module name @main@ with the module name derived+-- from the 'FilePath' of the module.+patchModuleId :: FilePath -> Module a -> Module a+patchModuleId fn m@(Module spi li ps mid es is ds)+ | mid == mainMIdent = Module spi li ps (mkMIdent [takeBaseName fn]) es is ds+ | otherwise = m++-- |Is the declaration a top declaration?+isTopDecl :: Decl a -> Bool+isTopDecl = not . isBlockDecl++-- |Is the declaration a block declaration?+isBlockDecl :: Decl a -> Bool+isBlockDecl = liftM3 ((.) (||) . (||)) isInfixDecl isTypeSig isValueDecl++-- |Is the declaration an infix declaration?+isInfixDecl :: Decl a -> Bool+isInfixDecl (InfixDecl _ _ _ _) = True+isInfixDecl _ = False++-- |Is the declaration a type declaration?+isTypeDecl :: Decl a -> Bool+isTypeDecl (DataDecl _ _ _ _ _) = True+isTypeDecl (ExternalDataDecl _ _ _) = True+isTypeDecl (NewtypeDecl _ _ _ _ _) = True+isTypeDecl (TypeDecl _ _ _ _) = True+isTypeDecl _ = False++-- |Is the declaration a default declaration?+isDefaultDecl :: Decl a -> Bool+isDefaultDecl (DefaultDecl _ _) = True+isDefaultDecl _ = False++-- |Is the declaration a class declaration?+isClassDecl :: Decl a -> Bool+isClassDecl (ClassDecl _ _ _ _ _ _) = True+isClassDecl _ = False++-- |Is the declaration a type or a class declaration?+isTypeOrClassDecl :: Decl a -> Bool+isTypeOrClassDecl = liftM2 (||) isTypeDecl isClassDecl++-- |Is the declaration an instance declaration?+isInstanceDecl :: Decl a -> Bool+isInstanceDecl (InstanceDecl _ _ _ _ _ _) = True+isInstanceDecl _ = False++-- |Is the declaration a type signature?+isTypeSig :: Decl a -> Bool+isTypeSig (TypeSig _ _ _) = True+isTypeSig _ = False++-- |Is the declaration a value declaration?+isValueDecl :: Decl a -> Bool+isValueDecl (FunctionDecl _ _ _ _) = True+isValueDecl (ExternalDecl _ _) = True+isValueDecl (PatternDecl _ _ _) = True+isValueDecl (FreeDecl _ _) = True+isValueDecl _ = False++-- |Is the declaration a function declaration?+isFunctionDecl :: Decl a -> Bool+isFunctionDecl (FunctionDecl _ _ _ _) = True+isFunctionDecl _ = False++-- |Is the declaration an external declaration?+isExternalDecl :: Decl a -> Bool+isExternalDecl (ExternalDecl _ _) = True+isExternalDecl _ = False++-- |Is the pattern semantically equivalent to a variable pattern?+isVariablePattern :: Pattern a -> Bool+isVariablePattern (VariablePattern _ _ _) = True+isVariablePattern (ParenPattern _ t) = isVariablePattern t+isVariablePattern (AsPattern _ _ t) = isVariablePattern t+isVariablePattern (LazyPattern _ _) = True+isVariablePattern _ = False++-- |Is a type expression a type variable?+isVariableType :: TypeExpr -> Bool+isVariableType (VariableType _ _) = True+isVariableType _ = False++-- |Is a type expression simple, i.e., is it of the form T u_1 ... u_n,+-- where T is a type constructor and u_1 ... u_n are type variables?+isSimpleType :: TypeExpr -> Bool+isSimpleType (ConstructorType _ _) = True+isSimpleType (ApplyType _ ty1 ty2) = isSimpleType ty1 && isVariableType ty2+isSimpleType (VariableType _ _) = False+isSimpleType (TupleType _ tys) = all isVariableType tys+isSimpleType (ListType _ ty) = isVariableType ty+isSimpleType (ArrowType _ ty1 ty2) = isVariableType ty1 && isVariableType ty2+isSimpleType (ParenType _ ty) = isSimpleType ty+isSimpleType (ForallType _ _ _) = False++-- |Return the qualified type constructor of a type expression.+typeConstr :: TypeExpr -> QualIdent+typeConstr (ConstructorType _ tc) = tc+typeConstr (ApplyType _ ty _) = typeConstr ty+typeConstr (TupleType _ tys) = qTupleId (length tys)+typeConstr (ListType _ _) = qListId+typeConstr (ArrowType _ _ _) = qArrowId+typeConstr (ParenType _ ty) = typeConstr ty+typeConstr (VariableType _ _) =+ error "Curry.Syntax.Utils.typeConstr: variable type"+typeConstr (ForallType _ _ _) =+ error "Curry.Syntax.Utils.typeConstr: forall type"++-- |Return the list of variables occuring in a type expression.+typeVariables :: TypeExpr -> [Ident]+typeVariables (ConstructorType _ _) = []+typeVariables (ApplyType _ ty1 ty2) = typeVariables ty1 ++ typeVariables ty2+typeVariables (VariableType _ tv) = [tv]+typeVariables (TupleType _ tys) = concatMap typeVariables tys+typeVariables (ListType _ ty) = typeVariables ty+typeVariables (ArrowType _ ty1 ty2) = typeVariables ty1 ++ typeVariables ty2+typeVariables (ParenType _ ty) = typeVariables ty+typeVariables (ForallType _ vs ty) = vs ++ typeVariables ty++-- |Return the identifier of a variable.+varIdent :: Var a -> Ident+varIdent (Var _ v) = v++-- |Convert an infix operator into an expression+infixOp :: InfixOp a -> Expression a+infixOp (InfixOp a op) = Variable NoSpanInfo a op+infixOp (InfixConstr a op) = Constructor NoSpanInfo a op++-- |flatten the left-hand-side to the identifier and all constructor terms+flatLhs :: Lhs a -> (Ident, [Pattern a])+flatLhs lhs = flat lhs []+ where flat (FunLhs _ f ts) ts' = (f, ts ++ ts')+ flat (OpLhs _ t1 op t2) ts' = (op, t1 : t2 : ts')+ flat (ApLhs _ lhs' ts) ts' = flat lhs' (ts ++ ts')++-- |Return the arity of an equation.+eqnArity :: Equation a -> Int+eqnArity (Equation _ lhs _) = length $ snd $ flatLhs lhs++-- |Select the label of a field+fieldLabel :: Field a -> QualIdent+fieldLabel (Field _ l _) = l++-- |Select the term of a field+fieldTerm :: Field a -> a+fieldTerm (Field _ _ t) = t++-- |Select the label and term of a field+field2Tuple :: Field a -> (QualIdent, a)+field2Tuple (Field _ l t) = (l, t)++-- |Get the operator name of an infix operator+opName :: InfixOp a -> QualIdent+opName (InfixOp _ op) = op+opName (InfixConstr _ c ) = c++-- | Get the identifier of a constructor declaration+constrId :: ConstrDecl -> Ident+constrId (ConstrDecl _ c _) = c+constrId (ConOpDecl _ _ op _) = op+constrId (RecordDecl _ c _) = c++-- | Get the identifier of a newtype constructor declaration+nconstrId :: NewConstrDecl -> Ident+nconstrId (NewConstrDecl _ c _) = c+nconstrId (NewRecordDecl _ c _) = c++-- | Get the type of a newtype constructor declaration+nconstrType :: NewConstrDecl -> TypeExpr+nconstrType (NewConstrDecl _ _ ty) = ty+nconstrType (NewRecordDecl _ _ (_, ty)) = ty++-- | Get record label identifiers of a constructor declaration+recordLabels :: ConstrDecl -> [Ident]+recordLabels (ConstrDecl _ _ _) = []+recordLabels (ConOpDecl _ _ _ _) = []+recordLabels (RecordDecl _ _ fs) = [l | FieldDecl _ ls _ <- fs, l <- ls]++-- | Get record label identifier of a newtype constructor declaration+nrecordLabels :: NewConstrDecl -> [Ident]+nrecordLabels (NewConstrDecl _ _ _ ) = []+nrecordLabels (NewRecordDecl _ _ (l, _)) = [l]++-- | Get the declared method identifiers of a type class method declaration+methods :: Decl a -> [Ident]+methods (TypeSig _ fs _) = fs+methods _ = []++-- | Get the method identifiers of a type class method implementations+impls :: Decl a -> [Ident]+impls (FunctionDecl _ _ f _) = [f]+impls _ = []++-- | Get the declared method identifier of an interface method declaration+imethod :: IMethodDecl -> Ident+imethod (IMethodDecl _ f _ _) = f++-- | Get the arity of an interface method declaration+imethodArity :: IMethodDecl -> Maybe Int+imethodArity (IMethodDecl _ _ a _) = a++--------------------------------------------------------+-- constructing elements of the abstract syntax tree+--------------------------------------------------------++funDecl :: SpanInfo -> a -> Ident -> [Pattern a] -> Expression a -> Decl a+funDecl spi a f ts e = FunctionDecl spi a f [mkEquation spi f ts e]++mkEquation :: SpanInfo -> Ident -> [Pattern a] -> Expression a -> Equation a+mkEquation spi f ts e = Equation spi (FunLhs NoSpanInfo f ts) (simpleRhs NoSpanInfo e)++simpleRhs :: SpanInfo -> Expression a -> Rhs a+simpleRhs spi e = SimpleRhs spi WhitespaceLayout e []++patDecl :: SpanInfo -> Pattern a -> Expression a -> Decl a+patDecl spi t e = PatternDecl spi t (SimpleRhs spi WhitespaceLayout e [])++varDecl :: SpanInfo -> a -> Ident -> Expression a -> Decl a+varDecl p ty = patDecl p . VariablePattern NoSpanInfo ty++constrPattern :: a -> QualIdent -> [(a, Ident)] -> Pattern a+constrPattern ty c = ConstructorPattern NoSpanInfo ty c+ . map (uncurry (VariablePattern NoSpanInfo))++caseAlt :: SpanInfo -> Pattern a -> Expression a -> Alt a+caseAlt spi t e = Alt spi t (SimpleRhs spi WhitespaceLayout e [])++mkLet :: [Decl a] -> Expression a -> Expression a+mkLet ds e = if null ds then e else Let NoSpanInfo WhitespaceLayout ds e++mkVar :: a -> Ident -> Expression a+mkVar ty = Variable NoSpanInfo ty . qualify++mkCase :: CaseType -> Expression a -> [Alt a] -> Expression a+mkCase = Case NoSpanInfo WhitespaceLayout++mkLambda :: [Pattern a] -> Expression a -> Expression a+mkLambda = Lambda NoSpanInfo++apply :: Expression a -> [Expression a] -> Expression a+apply = foldl (Apply NoSpanInfo)++unapply :: Expression a -> [Expression a] -> (Expression a, [Expression a])+unapply (Apply _ e1 e2) es = unapply e1 (e2 : es)+unapply e es = (e, es)+++--------------------------------------------------------+-- Shorten Module+-- Module Pragmas and Equations will be removed+--------------------------------------------------------++shortenModuleAST :: Module () -> Module ()+shortenModuleAST = shortenAST++class ShortenAST a where+ shortenAST :: a -> a++instance ShortenAST (Module a) where+ shortenAST (Module spi li _ mid ex im ds) =+ Module spi li [] mid ex im (map shortenAST ds)++instance ShortenAST (Decl a) where+ shortenAST (FunctionDecl spi a idt _) =+ FunctionDecl spi a idt []+ shortenAST (ClassDecl spi li cx cls tyv ds) =+ ClassDecl spi li cx cls tyv (map shortenAST ds)+ shortenAST (InstanceDecl spi li cx cls tyv ds) =+ InstanceDecl spi li cx cls tyv (map shortenAST ds)+ shortenAST d = d
src/CurryBuilder.hs view
@@ -23,8 +23,7 @@ import Curry.Base.Ident import Curry.Base.Monad-import Curry.Base.Position (Position)-import Curry.Base.SpanInfo (spanInfo2Pos)+import Curry.Base.SpanInfo (SpanInfo) import Curry.Base.Pretty import Curry.Files.Filenames import Curry.Files.PathUtils@@ -83,7 +82,7 @@ makeCurry opts srcs = mapM_ process' (zip [1 ..] srcs) where total = length srcs- tgtDir m = addCurrySubdirModule (optUseSubdir opts) m+ tgtDir m = addOutDirModule (optUseOutDir opts) (optOutDir opts) m process' :: (Int, (ModuleIdent, Source)) -> CYIO () process' (n, (m, Source fn ps is)) = do@@ -101,9 +100,9 @@ adjustOptions :: Bool -> Options -> Options adjustOptions final opts- | final = opts { optForce = optForce opts || isDump }- | otherwise = opts { optForce = False- , optDebugOpts = defaultDebugOpts+ | final = opts { optForce = optForce opts || isDump }+ | otherwise = opts { optForce = False+ , optDebugOpts = defaultDebugOpts } where isDump = not $ null $ dbDumpLevels $ optDebugOpts opts@@ -114,8 +113,8 @@ let opts1 = foldl processLanguagePragma opts0 [ e | LanguagePragma _ es <- ps, KnownExtension _ e <- es ] foldM processOptionPragma opts1 $- [ (spanInfo2Pos p, s) | OptionsPragma p (Just FRONTEND) s <- ps ] ++- [ (spanInfo2Pos p, s) | OptionsPragma p (Just CYMAKE) s <- ps ]+ [ (p, s) | OptionsPragma p (Just FRONTEND) s <- ps ] +++ [ (p, s) | OptionsPragma p (Just CYMAKE) s <- ps ] where processLanguagePragma opts CPP = opts { optCppOpts = (optCppOpts opts) { cppRun = True } }@@ -163,7 +162,7 @@ status opts $ compMessage idx "Compiling" m (fn, head destFiles) compileModule opts m fn - tgtDir = addCurrySubdirModule (optUseSubdir opts) m+ tgtDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) m destFiles = [ gen fn | (t, gen) <- nameGens, t `elem` optTargetTypes opts] nameGens =@@ -172,7 +171,7 @@ , (Parsed , tgtDir . sourceRepName ) , (FlatCurry , tgtDir . flatName ) , (TypedFlatCurry , tgtDir . typedFlatName )- , (TypeAnnotatedFlatCurry, tgtDir . typeAnnFlatName)+ , (AnnotatedFlatCurry , tgtDir . annotatedFlatName) , (AbstractCurry , tgtDir . acyName ) , (UntypedAbstractCurry, tgtDir . uacyName ) , (AST , tgtDir . astName )@@ -216,13 +215,13 @@ Nothing -> failMessages [errModificationTime f] Just val -> ok val -errUnknownOptions :: Position -> [String] -> Message-errUnknownOptions p errs = posMessage p $+errUnknownOptions :: SpanInfo -> [String] -> Message+errUnknownOptions spi errs = spanInfoMessage spi $ text "Unknown flag(s) in {-# OPTIONS_FRONTEND #-} pragma:" <+> sep (punctuate comma $ map text errs) -errIllegalOption :: Position -> String -> Message-errIllegalOption p err = posMessage p $+errIllegalOption :: SpanInfo -> String -> Message+errIllegalOption spi err = spanInfoMessage spi $ text "Illegal option in {-# OPTIONS_FRONTEND #-} pragma:" <+> text err errMissing :: String -> String -> Message
src/CurryDeps.hs view
@@ -100,7 +100,7 @@ -- |Retrieve the dependencies of a given module moduleDeps :: Options -> SourceEnv -> FilePath -> Module a -> CYIO SourceEnv-moduleDeps opts sEnv fn mdl@(Module _ ps m _ _ _) = case Map.lookup m sEnv of+moduleDeps opts sEnv fn mdl@(Module _ _ ps m _ _ _) = case Map.lookup m sEnv of Just _ -> return sEnv Nothing -> do let imps = imports opts mdl@@ -110,7 +110,7 @@ -- |Retrieve the imported modules and add the import of the Prelude -- according to the compiler options. imports :: Options -> Module a -> [ModuleIdent]-imports opts mdl@(Module _ _ m _ is _) = nub $+imports opts mdl@(Module _ _ _ m _ is _) = nub $ [preludeMIdent | m /= preludeMIdent && not noImplicitPrelude] ++ [m' | ImportDecl _ m' _ _ _ <- is] where noImplicitPrelude = NoImplicitPrelude `elem` optExtensions opts@@ -129,7 +129,7 @@ | icurryExt `isSuffixOf` fn -> return $ Map.insert m (Interface fn) sEnv | otherwise -> do- hdr@(Module _ _ m' _ _ _) <- readHeader opts fn+ hdr@(Module _ _ _ m' _ _ _) <- readHeader opts fn if m == m' then moduleDeps opts sEnv fn hdr else failMessages [errWrongModule m m']
src/Env/Class.hs view
@@ -1,20 +1,19 @@ {- | Module : $Header$ Description : Environment of classes- Copyright : (c) 2016 Finn Teegen+ Copyright : (c) 2016 - 2020 Finn Teegen License : BSD-3-clause - Maintainer : bjp@informatik.uni-kiel.de+ Maintainer : fte@informatik.uni-kiel.de Stability : experimental Portability : portable The compiler maintains information about all type classes in an- environment that maps type classes to a list of their direct- superclasses and all their associated class methods with an- additional boolean flag stating whether an default implementation- has been provided or not. For both the type class identifier and- the list of super classes original names are used. Thus, the use- of a flat environment is sufficient.+ environment that maps type classes to a sorted list of their direct+ superclasses and all their associated class methods with an additional+ flag stating whether an default implementation has been provided or not.+ For both the type class identifier and the list of super classes original+ names are used. Thus, the use of a flat environment is sufficient. -} module Env.Class
src/Env/Instance.hs view
@@ -1,10 +1,10 @@ {- | Module : $Header$ Description : Environment of instances- Copyright : (c) 2016 Finn Teegen+ Copyright : (c) 2016 - 2020 Finn Teegen License : BSD-3-clause - Maintainer : bjp@informatik.uni-kiel.de+ Maintainer : fte@informatik.uni-kiel.de Stability : experimental Portability : portable @@ -15,15 +15,16 @@ implemented in the specific instance along with their arity. A flat environment is sufficient because instances are visible globally and cannot be hidden. Instances are recorded only with the original names- of the type class and type constructor involved.+ of the type class and type constructor involved. The context also uses+ original names and is already minimized. -} module Env.Instance ( InstIdent, ppInstIdent, InstInfo- , InstEnv, initInstEnv, bindInstInfo, lookupInstInfo+ , InstEnv, initInstEnv, bindInstInfo, removeInstInfo, lookupInstInfo ) where -import qualified Data.Map as Map (Map, empty, insert, lookup)+import qualified Data.Map as Map (Map, empty, insert, delete, lookup) import Curry.Base.Ident import Curry.Base.Pretty@@ -45,6 +46,9 @@ bindInstInfo :: InstIdent -> InstInfo -> InstEnv -> InstEnv bindInstInfo = Map.insert++removeInstInfo :: InstIdent -> InstEnv -> InstEnv+removeInstInfo = Map.delete lookupInstInfo :: InstIdent -> InstEnv -> Maybe InstInfo lookupInstInfo = Map.lookup
src/Env/Value.hs view
@@ -48,15 +48,15 @@ data ValueInfo -- |Data constructor with original name, arity, list of record labels and type- = DataConstructor QualIdent Int [Ident] TypeScheme+ = DataConstructor QualIdent Int [Ident] TypeScheme -- |Newtype constructor with original name, record label and type -- (arity is always 1)- | NewtypeConstructor QualIdent Ident TypeScheme- -- |Value with original name, class method flag, arity and type- | Value QualIdent Bool Int TypeScheme+ | NewtypeConstructor QualIdent Ident TypeScheme+ -- |Value with original name, class method name, arity and type+ | Value QualIdent (Maybe QualIdent) Int TypeScheme -- |Record label with original name, list of constructors for which label- -- is valid field and type (arity is always 1)- | Label QualIdent [QualIdent] TypeScheme+ -- is a valid field and type (arity is always 1)+ | Label QualIdent [QualIdent] TypeScheme deriving Show instance Entity ValueInfo where@@ -115,21 +115,21 @@ where qc = qualifyWith m c v = f qc ty -bindFun :: ModuleIdent -> Ident -> Bool -> Int -> TypeScheme -> ValueEnv- -> ValueEnv+bindFun :: ModuleIdent -> Ident -> Maybe QualIdent -> Int -> TypeScheme+ -> ValueEnv -> ValueEnv bindFun m f cm a ty | hasGlobalScope f = bindTopEnv f v . qualBindTopEnv qf v | otherwise = bindTopEnv f v where qf = qualifyWith m f v = Value qf cm a ty -qualBindFun :: ModuleIdent -> Ident -> Bool -> Int -> TypeScheme -> ValueEnv- -> ValueEnv+qualBindFun :: ModuleIdent -> Ident -> Maybe QualIdent -> Int -> TypeScheme+ -> ValueEnv -> ValueEnv qualBindFun m f cm a ty = qualBindTopEnv qf $ Value qf cm a ty where qf = qualifyWith m f -rebindFun :: ModuleIdent -> Ident -> Bool -> Int -> TypeScheme -> ValueEnv- -> ValueEnv+rebindFun :: ModuleIdent -> Ident -> Maybe QualIdent -> Int -> TypeScheme+ -> ValueEnv -> ValueEnv rebindFun m f cm a ty | hasGlobalScope f = rebindTopEnv f v . qualRebindTopEnv qf v | otherwise = rebindTopEnv f v@@ -204,4 +204,4 @@ bindLocalVar :: ValueType t => (Ident, Int, t) -> ValueEnv -> ValueEnv bindLocalVar (v, a, ty) =- bindTopEnv v $ Value (qualify v) False a $ typeScheme $ fromValueType ty+ bindTopEnv v $ Value (qualify v) Nothing a $ typeScheme $ fromValueType ty
src/Exports.hs view
@@ -63,10 +63,10 @@ -- exported function. exportInterface :: CompilerEnv -> Module a -> Interface-exportInterface env (Module _ _ m (Just (Exporting _ es)) _ _) =+exportInterface env (Module _ _ _ m (Just (Exporting _ es)) _ _) = exportInterface' m es (opPrecEnv env) (tyConsEnv env) (valueEnv env) (classEnv env) (instEnv env)-exportInterface _ (Module _ _ _ Nothing _ _) =+exportInterface _ (Module _ _ _ _ Nothing _ _) = internalError "Exports.exportInterface: no export specification" exportInterface' :: ModuleIdent -> [Export] -> OpPrecEnv -> TCEnv -> ValueEnv@@ -178,7 +178,8 @@ valueDecl m vEnv tvs (Export _ f) ds = case qualLookupValue f vEnv of [Value _ cm a (ForAll _ pty)] -> IFunctionDecl NoPos (qualUnqualify m f)- (if cm then Just (head tvs) else Nothing) a (fromQualPredType m tvs pty) : ds+ (fmap (const (head tvs)) cm) a (fromQualPredType m tvs pty) : ds+ [Label _ _ _ ] -> ds -- Record labels are collected somewhere else. _ -> internalError $ "Exports.valueDecl: " ++ show f valueDecl _ _ _ (ExportTypeWith _ _ _) ds = ds valueDecl _ _ _ _ _ = internalError "Exports.valueDecl: no pattern match"
src/Generators.hs view
@@ -20,18 +20,18 @@ import qualified Curry.FlatCurry.Typed.Type as TFC (TProg) import qualified Curry.Syntax as CS (Module) -import qualified Generators.GenAbstractCurry as GAC (genAbstractCurry)-import qualified Generators.GenFlatCurry as GFC ( genFlatCurry- , genFlatInterface- )-import qualified Generators.GenTypeAnnotatedFlatCurry- as GTAFC (genTypeAnnotatedFlatCurry)-import qualified Generators.GenTypedFlatCurry as GTFC (genTypedFlatCurry)+import qualified Generators.GenAbstractCurry as GAC (genAbstractCurry)+import qualified Generators.GenFlatCurry as GFC ( genFlatCurry+ , genFlatInterface+ )+import qualified Generators.GenAnnotatedFlatCurry+ as GAFC (genAnnotatedFlatCurry)+import qualified Generators.GenTypedFlatCurry as GTFC (genTypedFlatCurry) -import Base.Types (Type, PredType)+import Base.Types (Type, PredType) -import CompilerEnv (CompilerEnv (..))-import qualified IL (Module)+import CompilerEnv (CompilerEnv (..))+import qualified IL (Module) -- |Generate typed AbstractCurry genTypedAbstractCurry :: CompilerEnv -> CS.Module PredType -> AC.CurryProg@@ -42,17 +42,16 @@ genUntypedAbstractCurry = GAC.genAbstractCurry True -- |Generate typed FlatCurry-genTypedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module- -> TFC.TProg+genTypedFlatCurry :: AFC.AProg FC.TypeExpr -> TFC.TProg genTypedFlatCurry = GTFC.genTypedFlatCurry -- |Generate type-annotated FlatCurry-genTypeAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module- -> AFC.AProg FC.TypeExpr-genTypeAnnotatedFlatCurry = GTAFC.genTypeAnnotatedFlatCurry+genAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module+ -> AFC.AProg FC.TypeExpr+genAnnotatedFlatCurry = GAFC.genAnnotatedFlatCurry -- |Generate FlatCurry-genFlatCurry :: TFC.TProg -> FC.Prog+genFlatCurry :: AFC.AProg FC.TypeExpr -> FC.Prog genFlatCurry = GFC.genFlatCurry -- |Generate a FlatCurry interface
src/Generators/GenAbstractCurry.hs view
@@ -63,7 +63,7 @@ -- --------------------------------------------------------------------------- trModule :: Module PredType -> GAC CurryProg-trModule (Module _ _ mid _ is ds) =+trModule (Module _ _ _ mid _ is ds) = CurryProg mid' is' <$> dflt' <*> cds' <*> ids' <*> ts' <*> fs' <*> os' where mid' = moduleName mid@@ -84,7 +84,7 @@ trDefaultDecl _ = return [] trClassDecl :: Decl PredType -> GAC [CClassDecl]-trClassDecl (ClassDecl _ cx cls tv ds) =+trClassDecl (ClassDecl _ _ cx cls tv ds) = (\cls' v' cx' tv' ds' -> [CClass cls' v' cx' tv' ds']) <$> trGlobalIdent cls <*> getTypeVisibility cls <*> trContext cx <*> getTVarIndex tv <*> concatMapM (trClassMethodDecl sigs fs) ds@@ -111,7 +111,7 @@ trClassMethodDecl _ _ _ = return [] trInstanceDecl :: Decl PredType -> GAC [CInstanceDecl]-trInstanceDecl (InstanceDecl _ cx qcls ty ds) =+trInstanceDecl (InstanceDecl _ _ cx qcls ty ds) = (\qcls' cx' ty' ds' -> [CInstance qcls' cx' ty' ds']) <$> trQual qcls <*> trContext cx <*> trTypeExpr ty <*> mapM (trInstanceMethodDecl qcls ty) ds trInstanceDecl _ = return []@@ -157,25 +157,22 @@ <$> trGlobalIdent t <*> getTypeVisibility t <*> mapM genTVarIndex vs trTypeDecl _ = return [] ---- TODO: Remove context and existential quantified type variables. trConsDecl :: ConstrDecl -> GAC CConsDecl-trConsDecl (ConstrDecl _ c tys) = inNestedTScope $ CCons [] (CContext [])+trConsDecl (ConstrDecl _ c tys) = inNestedTScope $ CCons <$> trGlobalIdent c <*> getVisibility c <*> mapM trTypeExpr tys trConsDecl (ConOpDecl p ty1 op ty2) = inNestedTScope $ trConsDecl $ ConstrDecl p op [ty1, ty2]-trConsDecl (RecordDecl _ c fs) = inNestedTScope $ CRecord [] (CContext [])+trConsDecl (RecordDecl _ c fs) = inNestedTScope $ CRecord <$> trGlobalIdent c <*> getVisibility c <*> concatMapM trFieldDecl fs trFieldDecl :: FieldDecl -> GAC [CFieldDecl] trFieldDecl (FieldDecl _ ls ty) = T.forM ls $ \l -> CField <$> trGlobalIdent l <*> getVisibility l <*> trTypeExpr ty --- TODO: Remove context and existential quantified type variables. trNewConsDecl :: NewConstrDecl -> GAC CConsDecl-trNewConsDecl (NewConstrDecl _ nc ty) = CCons [] (CContext [])+trNewConsDecl (NewConstrDecl _ nc ty) = CCons <$> trGlobalIdent nc <*> getVisibility nc <*> ((:[]) <$> trTypeExpr ty)-trNewConsDecl (NewRecordDecl p nc (l, ty)) = CRecord [] (CContext [])+trNewConsDecl (NewRecordDecl p nc (l, ty)) = CRecord <$> trGlobalIdent nc <*> getVisibility nc <*> trFieldDecl (FieldDecl p [l] ty) trTypeExpr :: TypeExpr -> GAC CTypeExpr@@ -233,10 +230,10 @@ trLhs = mapM trPat . snd . flatLhs trRhs :: Rhs PredType -> GAC CRhs-trRhs (SimpleRhs _ e ds) = inNestedScope $ do+trRhs (SimpleRhs _ _ e ds) = inNestedScope $ do mapM_ insertDeclLhs ds CSimpleRhs <$> trExpr e <*> concatMapM trLocalDecl ds-trRhs (GuardedRhs _ gs ds) = inNestedScope $ do+trRhs (GuardedRhs _ _ gs ds) = inNestedScope $ do mapM_ insertDeclLhs ds CGuardedRhs <$> mapM trCondExpr gs <*> concatMapM trLocalDecl ds @@ -313,14 +310,14 @@ trExpr $ apply (Variable NoSpanInfo undefined qFlip) [infixOp op, e] trExpr (Lambda _ ps e) = inNestedScope $ CLambda <$> mapM trPat ps <*> trExpr e-trExpr (Let _ ds e) = inNestedScope $+trExpr (Let _ _ ds e) = inNestedScope $ CLetDecl <$> trLocalDecls ds <*> trExpr e-trExpr (Do _ ss e) = inNestedScope $+trExpr (Do _ _ ss e) = inNestedScope $ (\ss' e' -> CDoExpr (ss' ++ [CSExpr e'])) <$> mapM trStatement ss <*> trExpr e trExpr (IfThenElse _ e1 e2 e3) = trExpr $ apply (Variable NoSpanInfo undefined qIfThenElseId) [e1, e2, e3]-trExpr (Case _ ct e bs) = CCase (cvCaseType ct)+trExpr (Case _ _ ct e bs) = CCase (cvCaseType ct) <$> trExpr e <*> mapM trAlt bs cvCaseType :: CaseType -> CCaseType@@ -328,9 +325,9 @@ cvCaseType Rigid = CRigid trStatement :: Statement PredType -> GAC CStatement-trStatement (StmtExpr _ e) = CSExpr <$> trExpr e-trStatement (StmtDecl _ ds) = CSLet <$> trLocalDecls ds-trStatement (StmtBind _ p e) = flip CSPat <$> trExpr e <*> trPat p+trStatement (StmtExpr _ e) = CSExpr <$> trExpr e+trStatement (StmtDecl _ _ ds) = CSLet <$> trLocalDecls ds+trStatement (StmtBind _ p e) = flip CSPat <$> trExpr e <*> trPat p trAlt :: Alt PredType -> GAC (CPattern, CRhs) trAlt (Alt _ p rhs) = inNestedScope $ (,) <$> trPat p <*> trRhs rhs@@ -393,7 +390,7 @@ qNegateId = qualifyWith preludeMIdent (mkIdent "negate") qIfThenElseId :: QualIdent-qIfThenElseId = qualifyWith preludeMIdent (mkIdent "if_then_else")+qIfThenElseId = qualifyWith preludeMIdent (mkIdent "ifThenElse") prelUntyped :: QualIdent prelUntyped = qualifyWith preludeMIdent $ mkIdent "untyped"@@ -419,7 +416,7 @@ -- |Initialize the AbstractCurry generator environment abstractEnv :: Bool -> CompilerEnv -> Module a -> AbstractEnv-abstractEnv uacy env (Module _ _ mid es _ ds) = AbstractEnv+abstractEnv uacy env (Module _ _ _ mid es _ ds) = AbstractEnv { moduleId = mid , typeEnv = valueEnv env , tyExports = foldr (buildTypeExports mid) Set.empty es'
+ src/Generators/GenAnnotatedFlatCurry.hs view
@@ -0,0 +1,488 @@+{- |+ Module : $Header$+ Description : Generation of typed FlatCurry program terms+ Copyright : (c) 2017 Finn Teegen+ 2018 Kai-Oliver Prott+ License : BSD-3-clause++ Maintainer : fte@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This module contains the generation of a type-annotated 'FlatCurry'+ program term for a given module in the intermediate language.+-}+{-# LANGUAGE CPP #-}+module Generators.GenAnnotatedFlatCurry (genAnnotatedFlatCurry) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>), (<*>))+#endif+import Control.Monad ((<=<))+import Control.Monad.Extra (concatMapM)+import qualified Control.Monad.State as S ( State, evalState, get, gets+ , modify, put )+import Data.Function (on)+import Data.List (nub, sortBy)+import Data.Maybe (fromMaybe)+import qualified Data.Map as Map (Map, empty, insert, lookup)+import qualified Data.Set as Set (Set, empty, insert, member)++import Curry.Base.Ident+import Curry.FlatCurry.Annotated.Goodies (typeName)+import Curry.FlatCurry.Annotated.Type+import qualified Curry.Syntax as CS++import Base.Messages (internalError)+import Base.NestEnv ( NestEnv, emptyEnv, bindNestEnv, lookupNestEnv+ , nestEnv, unnestEnv )+import Base.Types++import CompilerEnv+import Env.TypeConstructor (TCEnv)++import qualified IL++-- transforms intermediate language code (IL) to type-annotated FlatCurry code+genAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module+ -> AProg TypeExpr+genAnnotatedFlatCurry env mdl il = patchPrelude $ run env mdl (trModule il)++-- -----------------------------------------------------------------------------+-- Addition of primitive types for lists and tuples to the Prelude+-- -----------------------------------------------------------------------------++patchPrelude :: AProg a -> AProg a+patchPrelude p@(AProg n _ ts fs os)+ | n == prelude = AProg n [] ts' fs os+ | otherwise = p+ where ts' = sortBy (compare `on` typeName) pts+ pts = primTypes ++ ts++primTypes :: [TypeDecl]+primTypes =+ [ Type arrow Public [(0, KStar), (1, KStar)] []+ , Type unit Public [] [(Cons unit 0 Public [])]+ , Type nil Public [(0, KStar)] [ Cons nil 0 Public []+ , Cons cons 2 Public [TVar 0, TCons nil [TVar 0]]+ ]+ ] ++ map mkTupleType [2 .. maxTupleArity]+ where arrow = mkPreludeQName "(->)"+ unit = mkPreludeQName "()"+ nil = mkPreludeQName "[]"+ cons = mkPreludeQName ":"++mkTupleType :: Int -> TypeDecl+mkTupleType arity = Type tuple Public [(i, KStar) | i <- [0 .. arity - 1]]+ [Cons tuple arity Public $ map TVar [0 .. arity - 1]]+ where tuple = mkPreludeQName $ '(' : replicate (arity - 1) ',' ++ ")"++mkPreludeQName :: String -> QName+mkPreludeQName n = (prelude, n)++prelude :: String+prelude = "Prelude"++-- |Maximal arity of tuples+maxTupleArity :: Int+maxTupleArity = 15++-- -----------------------------------------------------------------------------++-- The environment 'FlatEnv' is embedded in the monadic representation+-- 'FlatState' which allows the usage of 'do' expressions.+type FlatState a = S.State FlatEnv a++-- Data type for representing an environment which contains information needed+-- for generating FlatCurry code.+data FlatEnv = FlatEnv+ { modIdent :: ModuleIdent -- current module+ -- for visibility calculation+ , tyExports :: Set.Set Ident -- exported types+ , valExports :: Set.Set Ident -- exported values (functions + constructors)+ , tcEnv :: TCEnv -- type constructor environment+ , typeSynonyms :: [CS.Decl Type] -- type synonyms+ , imports :: [ModuleIdent] -- module imports+ -- state for mapping identifiers to indexes+ , nextVar :: Int -- fresh variable index counter+ , varMap :: NestEnv VarIndex -- map of identifier to variable index+ }++-- Runs a 'FlatState' action and returns the result+run :: CompilerEnv -> CS.Module Type -> FlatState a -> a+run env (CS.Module _ _ _ mid es is ds) act = S.evalState act env0+ where+ es' = case es of Just (CS.Exporting _ e) -> e+ _ -> []+ env0 = FlatEnv+ { modIdent = mid+ -- for visibility calculation+ , tyExports = foldr (buildTypeExports mid) Set.empty es'+ , valExports = foldr (buildValueExports mid) Set.empty es'+ -- This includes *all* imports, even unused ones+ , imports = nub [ m | CS.ImportDecl _ m _ _ _ <- is ]+ -- Environment to retrieve the type of identifiers+ , tcEnv = tyConsEnv env+ -- Type synonyms in the module+ , typeSynonyms = [ d | d@CS.TypeDecl{} <- ds ]+ , nextVar = 0+ , varMap = emptyEnv+ }++-- Builds a table containing all exported identifiers from a module.+buildTypeExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident+buildTypeExports mid (CS.ExportTypeWith _ tc _)+ | isLocalIdent mid tc = Set.insert (unqualify tc)+buildTypeExports _ _ = id++-- Builds a table containing all exported identifiers from a module.+buildValueExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident+buildValueExports mid (CS.Export _ q)+ | isLocalIdent mid q = Set.insert (unqualify q)+buildValueExports mid (CS.ExportTypeWith _ tc cs)+ | isLocalIdent mid tc = flip (foldr Set.insert) cs+buildValueExports _ _ = id++getModuleIdent :: FlatState ModuleIdent+getModuleIdent = S.gets modIdent++-- Retrieve imports+getImports :: [ModuleIdent] -> FlatState [String]+getImports imps = (nub . map moduleName . (imps ++)) <$> S.gets imports++-- -----------------------------------------------------------------------------+-- Stateful part, used for translation of rules and expressions+-- -----------------------------------------------------------------------------++-- resets var index and environment+withFreshEnv :: FlatState a -> FlatState a+withFreshEnv act = S.modify (\ s -> s { nextVar = 0, varMap = emptyEnv }) >> act++-- Execute an action in a nested variable mapping+inNestedEnv :: FlatState a -> FlatState a+inNestedEnv act = do+ S.modify $ \ s -> s { varMap = nestEnv $ varMap s }+ res <- act+ S.modify $ \ s -> s { varMap = unnestEnv $ varMap s }+ return res++-- Generates a new variable index for an identifier+newVar :: IL.Type -> Ident -> FlatState (VarIndex, TypeExpr)+newVar ty i = do+ idx <- (+1) <$> S.gets nextVar+ S.modify $ \ s -> s { nextVar = idx, varMap = bindNestEnv i idx (varMap s) }+ ty' <- trType ty+ return (idx, ty')++-- Retrieve the variable index assigned to an identifier+getVarIndex :: Ident -> FlatState VarIndex+getVarIndex i = S.gets varMap >>= \ varEnv -> case lookupNestEnv i varEnv of+ [v] -> return v+ _ -> internalError $ "GenTypeAnnotatedFlatCurry.getVarIndex: " ++ escName i++-- -----------------------------------------------------------------------------+-- Translation of a module+-- -----------------------------------------------------------------------------++trModule :: IL.Module -> FlatState (AProg TypeExpr)+trModule (IL.Module mid is ds) = do+ is' <- getImports is+ tds <- concatMapM trTypeDecl ds+ fds <- concatMapM (return . map runNormalization <=< trAFuncDecl) ds+ return $ AProg (moduleName mid) is' tds fds []++-- Translate a data declaration+-- For empty data declarations, an additional constructor is generated. This+-- is due to the fact that external data declarations are translated into data+-- declarations with zero constructors and without the additional constructor+-- empty data declarations could not be distinguished from external ones.+trTypeDecl :: IL.Decl -> FlatState [TypeDecl]+trTypeDecl (IL.DataDecl qid ks []) = do+ q' <- trQualIdent qid+ vis <- getTypeVisibility qid+ c <- trQualIdent $ qualify (mkIdent $ "_Constr#" ++ idName (unqualify qid))+ let ks' = trKind <$> ks+ tvs = zip [0..] ks'+ return [Type q' vis tvs [Cons c 1 Private [TCons q' $ TVar <$> fst <$> tvs]]]+trTypeDecl (IL.DataDecl qid ks cs) = do+ q' <- trQualIdent qid+ vis <- getTypeVisibility qid+ cs' <- mapM trConstrDecl cs+ let ks' = trKind <$> ks+ tvs = zip [0..] ks'+ return [Type q' vis tvs cs']+trTypeDecl (IL.NewtypeDecl qid ks nc) = do+ q' <- trQualIdent qid+ vis <- getTypeVisibility qid+ nc' <- trNewConstrDecl nc+ let ks' = trKind <$> ks+ tvs = zip [0..] ks'+ return [TypeNew q' vis tvs nc']+trTypeDecl (IL.ExternalDataDecl qid ks) = do+ q' <- trQualIdent qid+ vis <- getTypeVisibility qid+ let ks' = trKind <$> ks+ tvs = zip [0..] ks'+ return [Type q' vis tvs []]+trTypeDecl _ = return []++-- Translate a constructor declaration+trConstrDecl :: IL.ConstrDecl -> FlatState ConsDecl+trConstrDecl (IL.ConstrDecl qid tys) = flip Cons (length tys)+ <$> trQualIdent qid+ <*> getVisibility qid+ <*> mapM trType tys++-- Translate a constructor declaration for newtypes+trNewConstrDecl :: IL.NewConstrDecl -> FlatState NewConsDecl+trNewConstrDecl (IL.NewConstrDecl qid ty) = NewCons+ <$> trQualIdent qid+ <*> getVisibility qid+ <*> trType ty++-- Translate a type expression+trType :: IL.Type -> FlatState TypeExpr+trType (IL.TypeConstructor t tys) = TCons <$> trQualIdent t <*> mapM trType tys+trType (IL.TypeVariable idx) = return $ TVar $ abs idx+trType (IL.TypeArrow ty1 ty2) = FuncType <$> trType ty1 <*> trType ty2+trType (IL.TypeForall idxs ty) = ForallType (map trTVarWithKind idxs) <$> trType ty++-- Translates a type variable with kind.+trTVarWithKind :: (Int, IL.Kind) -> (Int, Kind)+trTVarWithKind (i, k) = (abs i, trKind k)++-- Translate a kind+trKind :: IL.Kind -> Kind+trKind IL.KindStar = KStar+trKind (IL.KindVariable _) = KStar+trKind (IL.KindArrow k1 k2) = KArrow (trKind k1) (trKind k2)++-- -----------------------------------------------------------------------------+-- Function declarations+-- -----------------------------------------------------------------------------++-- Translate a function declaration+trAFuncDecl :: IL.Decl -> FlatState [AFuncDecl TypeExpr]+trAFuncDecl (IL.FunctionDecl f vs ty e) = do+ f' <- trQualIdent f+ vis <- getVisibility f+ ty' <- trType ty+ r' <- trARule ty vs e+ return [AFunc f' (length vs) vis ty' r']+trAFuncDecl (IL.ExternalDecl f a ty) = do+ f' <- trQualIdent f+ vis <- getVisibility f+ ty' <- trType ty+ r' <- trAExternal ty f --TODO: get arity from type?+ return [AFunc f' a vis ty' r']+trAFuncDecl _ = return []++-- Translate a function rule.+-- Resets variable index so that for every rule variables start with index 1+trARule :: IL.Type -> [(IL.Type, Ident)] -> IL.Expression+ -> FlatState (ARule TypeExpr)+trARule ty vs e = withFreshEnv $ ARule <$> trType ty+ <*> mapM (uncurry newVar) vs+ <*> trAExpr e++trAExternal :: IL.Type -> QualIdent -> FlatState (ARule TypeExpr)+trAExternal ty f = flip AExternal (qualName f) <$> trType ty++-- Translate an expression+trAExpr :: IL.Expression -> FlatState (AExpr TypeExpr)+trAExpr (IL.Literal ty l) = ALit <$> trType ty <*> trLiteral l+trAExpr (IL.Variable ty v) = AVar <$> trType ty <*> getVarIndex v+trAExpr (IL.Function ty f a) = genCall Fun ty f a []+trAExpr (IL.Constructor ty c a) = genCall Con ty c a []+trAExpr (IL.Apply e1 e2) = trApply e1 e2+trAExpr c@(IL.Case t e bs) = flip ACase (cvEval t) <$> trType (IL.typeOf c) <*> trAExpr e+ <*> mapM (inNestedEnv . trAlt) bs+trAExpr (IL.Or e1 e2) = AOr <$> trType (IL.typeOf e1) <*> trAExpr e1 <*> trAExpr e2+trAExpr (IL.Exist v ty e) = inNestedEnv $ do+ v' <- newVar ty v+ e' <- trAExpr e+ ty' <- trType (IL.typeOf e)+ return $ case e' of AFree ty'' vs e'' -> AFree ty'' (v' : vs) e''+ _ -> AFree ty' (v' : []) e'+trAExpr (IL.Let (IL.Binding v b) e) = inNestedEnv $ do+ v' <- newVar (IL.typeOf b) v+ b' <- trAExpr b+ e' <- trAExpr e+ ty' <- trType $ IL.typeOf e+ return $ case e' of ALet ty'' bs e'' -> ALet ty'' ((v', b'):bs) e''+ _ -> ALet ty' ((v', b'):[]) e'+trAExpr (IL.Letrec bs e) = inNestedEnv $ do+ let (vs, es) = unzip [ ((IL.typeOf b, v), b) | IL.Binding v b <- bs]+ ALet <$> trType (IL.typeOf e)+ <*> (zip <$> mapM (uncurry newVar) vs <*> mapM trAExpr es)+ <*> trAExpr e+trAExpr (IL.Typed e ty) = ATyped <$> ty' <*> trAExpr e <*> ty'+ where ty' = trType $ ty++-- Translate a literal+trLiteral :: IL.Literal -> FlatState Literal+trLiteral (IL.Char c) = return $ Charc c+trLiteral (IL.Int i) = return $ Intc i+trLiteral (IL.Float f) = return $ Floatc f++-- Translate a higher-order application+trApply :: IL.Expression -> IL.Expression -> FlatState (AExpr TypeExpr)+trApply e1 e2 = genFlatApplic e1 [e2]+ where+ genFlatApplic e es = case e of+ IL.Apply ea eb -> genFlatApplic ea (eb:es)+ IL.Function ty f a -> genCall Fun ty f a es+ IL.Constructor ty c a -> genCall Con ty c a es+ _ -> do+ expr <- trAExpr e+ genApply expr es++-- Translate an alternative+trAlt :: IL.Alt -> FlatState (ABranchExpr TypeExpr)+trAlt (IL.Alt p e) = ABranch <$> trPat p <*> trAExpr e++-- Translate a pattern+trPat :: IL.ConstrTerm -> FlatState (APattern TypeExpr)+trPat (IL.LiteralPattern ty l) = ALPattern <$> trType ty <*> trLiteral l+trPat (IL.ConstructorPattern ty c vs) = do+ qty <- trType $ foldr IL.TypeArrow ty $ map fst vs+ APattern <$> trType ty <*> ((\q -> (q, qty)) <$> trQualIdent c) <*> mapM (uncurry newVar) vs+trPat (IL.VariablePattern _ _) = internalError "GenTypeAnnotatedFlatCurry.trPat"++-- Convert a case type+cvEval :: IL.Eval -> CaseType+cvEval IL.Rigid = Rigid+cvEval IL.Flex = Flex++data Call = Fun | Con++-- Generate a function or constructor call+genCall :: Call -> IL.Type -> QualIdent -> Int -> [IL.Expression]+ -> FlatState (AExpr TypeExpr)+genCall call ty f arity es = do+ f' <- trQualIdent f+ case compare supplied arity of+ LT -> genAComb ty f' es (part call (arity - supplied))+ EQ -> genAComb ty f' es (full call)+ GT -> do+ let (es1, es2) = splitAt arity es+ funccall <- genAComb ty f' es1 (full call)+ genApply funccall es2+ where+ supplied = length es+ full Fun = FuncCall+ full Con = ConsCall+ part Fun = FuncPartCall+ part Con = ConsPartCall++genAComb :: IL.Type -> QName -> [IL.Expression] -> CombType -> FlatState (AExpr TypeExpr)+genAComb ty qid es ct = do+ ty' <- trType ty+ let ty'' = defunc ty' (length es)+ AComb ty'' ct (qid, ty') <$> mapM trAExpr es+ where+ defunc t 0 = t+ defunc (FuncType _ t2) n = defunc t2 (n - 1)+ defunc _ _ = internalError "GenTypeAnnotatedFlatCurry.genAComb.defunc"++genApply :: AExpr TypeExpr -> [IL.Expression] -> FlatState (AExpr TypeExpr)+genApply e es = do+ ap <- trQualIdent $ qApplyId+ es' <- mapM trAExpr es+ return $ foldl (\e1 e2 -> let FuncType ty1 ty2 = typeOf e1 in AComb ty2 FuncCall (ap, FuncType (FuncType ty1 ty2) (FuncType ty1 ty2)) [e1, e2]) e es'++-- -----------------------------------------------------------------------------+-- Normalization+-- -----------------------------------------------------------------------------++runNormalization :: Normalize a => a -> a+runNormalization x = S.evalState (normalize x) (0, Map.empty)++type NormState a = S.State (Int, Map.Map Int Int) a++class Normalize a where+ normalize :: a -> NormState a++instance Normalize a => Normalize [a] where+ normalize = mapM normalize++instance Normalize Int where+ normalize i = do+ (n, m) <- S.get+ case Map.lookup i m of+ Nothing -> do+ S.put (n + 1, Map.insert i n m)+ return n+ Just n' -> return n'++instance Normalize TypeExpr where+ normalize (TVar i) = TVar <$> normalize i+ normalize (TCons q tys) = TCons q <$> normalize tys+ normalize (FuncType ty1 ty2) = FuncType <$> normalize ty1 <*> normalize ty2+ normalize (ForallType is ty) = ForallType <$> mapM normalizeTypeVar is+ <*> normalize ty+ where normalizeTypeVar (tv, k) = (,) <$> normalize tv <*> pure k++instance Normalize a => Normalize (AFuncDecl a) where+ normalize (AFunc f a v ty r) = AFunc f a v <$> normalize ty <*> normalize r++instance Normalize a => Normalize (ARule a) where+ normalize (ARule ty vs e) = ARule <$> normalize ty+ <*> mapM normalizeTuple vs+ <*> normalize e+ normalize (AExternal ty s) = flip AExternal s <$> normalize ty++normalizeTuple :: Normalize b => (a, b) -> NormState (a, b)+normalizeTuple (a, b) = (,) <$> pure a <*> normalize b ++instance Normalize a => Normalize (AExpr a) where+ normalize (AVar ty v) = flip AVar v <$> normalize ty+ normalize (ALit ty l) = flip ALit l <$> normalize ty+ normalize (AComb ty ct f es) = flip AComb ct <$> normalize ty+ <*> normalizeTuple f+ <*> normalize es+ normalize (ALet ty ds e) = ALet <$> normalize ty+ <*> mapM normalizeBinding ds+ <*> normalize e+ where normalizeBinding (v, b) = (,) <$> normalizeTuple v <*> normalize b+ normalize (AOr ty a b) = AOr <$> normalize ty <*> normalize a+ <*> normalize b+ normalize (ACase ty ct e bs) = flip ACase ct <$> normalize ty <*> normalize e+ <*> normalize bs+ normalize (AFree ty vs e) = AFree <$> normalize ty+ <*> mapM normalizeTuple vs+ <*> normalize e+ normalize (ATyped ty e ty') = ATyped <$> normalize ty <*> normalize e+ <*> normalize ty'++instance Normalize a => Normalize (ABranchExpr a) where+ normalize (ABranch p e) = ABranch <$> normalize p <*> normalize e++instance Normalize a => Normalize (APattern a) where+ normalize (APattern ty c vs) = APattern <$> normalize ty+ <*> normalizeTuple c+ <*> mapM normalizeTuple vs+ normalize (ALPattern ty l) = flip ALPattern l <$> normalize ty++-- -----------------------------------------------------------------------------+-- Helper functions+-- -----------------------------------------------------------------------------++trQualIdent :: QualIdent -> FlatState QName+trQualIdent qid = do+ mid <- getModuleIdent+ return $ (moduleName $ fromMaybe mid mid', idName i)+ where+ mid' | i `elem` [listId, consId, nilId, unitId] || isTupleId i+ = Just preludeMIdent+ | otherwise+ = qidModule qid+ i = qidIdent qid++getTypeVisibility :: QualIdent -> FlatState Visibility+getTypeVisibility i = S.gets $ \s ->+ if Set.member (unqualify i) (tyExports s) then Public else Private++getVisibility :: QualIdent -> FlatState Visibility+getVisibility i = S.gets $ \s ->+ if Set.member (unqualify i) (valExports s) then Public else Private
src/Generators/GenFlatCurry.hs view
@@ -15,39 +15,39 @@ import Curry.FlatCurry.Goodies import Curry.FlatCurry.Type-import Curry.FlatCurry.Typed.Goodies-import Curry.FlatCurry.Typed.Type+import Curry.FlatCurry.Annotated.Goodies+import Curry.FlatCurry.Annotated.Type -- transforms annotated FlatCurry code to FlatCurry code-genFlatCurry :: TProg -> Prog-genFlatCurry = trTProg+genFlatCurry :: AProg TypeExpr -> Prog+genFlatCurry = trAProg (\name imps types funcs ops -> Prog name imps types (map genFlatFuncDecl funcs) ops) -genFlatFuncDecl :: TFuncDecl -> FuncDecl-genFlatFuncDecl = trTFunc+genFlatFuncDecl :: AFuncDecl TypeExpr -> FuncDecl+genFlatFuncDecl = trAFunc (\name arity vis ty rule -> Func name arity vis ty $ genFlatRule rule) -genFlatRule :: TRule -> Rule-genFlatRule = trTRule- (\args e -> Rule (map fst args) $ genFlatExpr e)+genFlatRule :: ARule TypeExpr -> Rule+genFlatRule = trARule+ (\_ args e -> Rule (map fst args) $ genFlatExpr e) (const External) -genFlatExpr :: TExpr -> Expr-genFlatExpr = trTExpr+genFlatExpr :: AExpr TypeExpr -> Expr+genFlatExpr = trAExpr (const Var) (const Lit)- (\_ ct name args -> Comb ct name args)- (\bs e -> Let (map (\(v, e') -> (fst v, e')) bs) e)- (\vs e -> Free (map fst vs) e)- Or- Case- (\pat e -> Branch (genFlatPattern pat) e)- Typed+ (\_ ct (name, _) args -> Comb ct name args)+ (const $ Let . map (\(v, e') -> (fst v, e')))+ (const $ Free . map fst)+ (const Or)+ (const Case)+ (Branch . genFlatPattern)+ (const Typed) -genFlatPattern :: TPattern -> Pattern-genFlatPattern = trTPattern- (\_ name args -> Pattern name $ map fst args)+genFlatPattern :: APattern TypeExpr -> Pattern+genFlatPattern = trAPattern+ (\_ (name, _) args -> Pattern name $ map fst args) (const LPattern) -- transforms a FlatCurry module to a FlatCurry interface
− src/Generators/GenTypeAnnotatedFlatCurry.hs
@@ -1,517 +0,0 @@-{- |- Module : $Header$- Description : Generation of typed FlatCurry program terms- Copyright : (c) 2017 Finn Teegen- 2018 Kai-Oliver Prott- License : BSD-3-clause-- Maintainer : fte@informatik.uni-kiel.de- Stability : experimental- Portability : portable-- This module contains the generation of a type-annotated 'FlatCurry'- program term for a given module in the intermediate language.--}-{-# LANGUAGE CPP #-}-module Generators.GenTypeAnnotatedFlatCurry (genTypeAnnotatedFlatCurry) where--#if __GLASGOW_HASKELL__ < 710-import Control.Applicative ((<$>), (<*>))-#endif-import Control.Monad ((<=<))-import Control.Monad.Extra (concatMapM)-import qualified Control.Monad.State as S ( State, evalState, get, gets- , modify, put )-import Data.Function (on)-import Data.List (nub, sortBy)-import Data.Maybe (fromMaybe)-import qualified Data.Map as Map (Map, empty, insert, lookup)-import qualified Data.Set as Set (Set, empty, insert, member)--import Curry.Base.Ident-import Curry.Base.SpanInfo-import Curry.FlatCurry.Annotated.Goodies (typeName)-import Curry.FlatCurry.Annotated.Type-import qualified Curry.Syntax as CS--import Base.CurryTypes (toType)-import Base.Messages (internalError)-import Base.NestEnv ( NestEnv, emptyEnv, bindNestEnv, lookupNestEnv- , nestEnv, unnestEnv )-import Base.TypeExpansion-import Base.Types--import CompilerEnv-import Env.OpPrec (mkPrec)-import Env.TypeConstructor (TCEnv)-import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)--import qualified IL-import Transformations (transType)---- TODO: Translate from TypedFlatCurry--- transforms intermediate language code (IL) to type-annotated FlatCurry code-genTypeAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module- -> AProg TypeExpr-genTypeAnnotatedFlatCurry env mdl il = patchPrelude $ run env mdl (trModule il)---- -------------------------------------------------------------------------------- Addition of primitive types for lists and tuples to the Prelude--- -------------------------------------------------------------------------------patchPrelude :: AProg a -> AProg a-patchPrelude p@(AProg n _ ts fs os)- | n == prelude = AProg n [] ts' fs os- | otherwise = p- where ts' = sortBy (compare `on` typeName) pts- pts = primTypes ++ ts--primTypes :: [TypeDecl]-primTypes =- [ Type arrow Public [0, 1] []- , Type unit Public [] [(Cons unit 0 Public [])]- , Type nil Public [0] [ Cons nil 0 Public []- , Cons cons 2 Public [TVar 0, TCons nil [TVar 0]]- ]- ] ++ map mkTupleType [2 .. maxTupleArity]- where arrow = mkPreludeQName "(->)"- unit = mkPreludeQName "()"- nil = mkPreludeQName "[]"- cons = mkPreludeQName ":"--mkTupleType :: Int -> TypeDecl-mkTupleType arity = Type tuple Public [0 .. arity - 1]- [Cons tuple arity Public (map TVar [0 .. arity - 1])]- where tuple = mkPreludeQName $ '(' : replicate (arity - 1) ',' ++ ")"--mkPreludeQName :: String -> QName-mkPreludeQName n = (prelude, n)--prelude :: String-prelude = "Prelude"---- |Maximal arity of tuples-maxTupleArity :: Int-maxTupleArity = 15---- --------------------------------------------------------------------------------- The environment 'FlatEnv' is embedded in the monadic representation--- 'FlatState' which allows the usage of 'do' expressions.-type FlatState a = S.State FlatEnv a---- Data type for representing an environment which contains information needed--- for generating FlatCurry code.-data FlatEnv = FlatEnv- { modIdent :: ModuleIdent -- current module- -- for visibility calculation- , tyExports :: Set.Set Ident -- exported types- , valExports :: Set.Set Ident -- exported values (functions + constructors)- , tcEnv :: TCEnv -- type constructor environment- , tyEnv :: ValueEnv -- type environment- , fixities :: [CS.IDecl] -- fixity declarations- , typeSynonyms :: [CS.Decl Type] -- type synonyms- , imports :: [ModuleIdent] -- module imports- -- state for mapping identifiers to indexes- , nextVar :: Int -- fresh variable index counter- , varMap :: NestEnv VarIndex -- map of identifier to variable index- }---- Runs a 'FlatState' action and returns the result-run :: CompilerEnv -> CS.Module Type -> FlatState a -> a-run env (CS.Module _ _ mid es is ds) act = S.evalState act env0- where- es' = case es of Just (CS.Exporting _ e) -> e- _ -> []- env0 = FlatEnv- { modIdent = mid- -- for visibility calculation- , tyExports = foldr (buildTypeExports mid) Set.empty es'- , valExports = foldr (buildValueExports mid) Set.empty es'- -- This includes *all* imports, even unused ones- , imports = nub [ m | CS.ImportDecl _ m _ _ _ <- is ]- -- Environment to retrieve the type of identifiers- , tyEnv = valueEnv env- , tcEnv = tyConsEnv env- -- Fixity declarations- , fixities = [ CS.IInfixDecl (spanInfo2Pos p) fix (mkPrec mPrec) (qualifyWith mid o)- | CS.InfixDecl p fix mPrec os <- ds, o <- os- ]- -- Type synonyms in the module- , typeSynonyms = [ d | d@CS.TypeDecl{} <- ds ]- , nextVar = 0- , varMap = emptyEnv- }---- Builds a table containing all exported identifiers from a module.-buildTypeExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident-buildTypeExports mid (CS.ExportTypeWith _ tc _)- | isLocalIdent mid tc = Set.insert (unqualify tc)-buildTypeExports _ _ = id---- Builds a table containing all exported identifiers from a module.-buildValueExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident-buildValueExports mid (CS.Export _ q)- | isLocalIdent mid q = Set.insert (unqualify q)-buildValueExports mid (CS.ExportTypeWith _ tc cs)- | isLocalIdent mid tc = flip (foldr Set.insert) cs-buildValueExports _ _ = id--getModuleIdent :: FlatState ModuleIdent-getModuleIdent = S.gets modIdent--getArity :: QualIdent -> FlatState Int-getArity qid = S.gets tyEnv >>= \ env -> return $ case qualLookupValue qid env of- [DataConstructor _ a _ _] -> a- [NewtypeConstructor _ _ _] -> 1- [Value _ _ a _] -> a- [Label _ _ _] -> 1- _ ->- internalError ("GenTypeAnnotatedFlatCurry.getArity: " ++ qualName qid)--getFixities :: FlatState [CS.IDecl]-getFixities = S.gets fixities---- The function 'typeSynonyms' returns the list of type synonyms.-getTypeSynonyms :: FlatState [CS.Decl Type]-getTypeSynonyms = S.gets typeSynonyms---- Retrieve imports-getImports :: [ModuleIdent] -> FlatState [String]-getImports imps = (nub . map moduleName . (imps ++)) <$> S.gets imports---- -------------------------------------------------------------------------------- Stateful part, used for translation of rules and expressions--- --------------------------------------------------------------------------------- resets var index and environment-withFreshEnv :: FlatState a -> FlatState a-withFreshEnv act = S.modify (\ s -> s { nextVar = 0, varMap = emptyEnv }) >> act---- Execute an action in a nested variable mapping-inNestedEnv :: FlatState a -> FlatState a-inNestedEnv act = do- S.modify $ \ s -> s { varMap = nestEnv $ varMap s }- res <- act- S.modify $ \ s -> s { varMap = unnestEnv $ varMap s }- return res---- Generates a new variable index for an identifier-newVar :: IL.Type -> Ident -> FlatState (VarIndex, TypeExpr)-newVar ty i = do- idx <- (+1) <$> S.gets nextVar- S.modify $ \ s -> s { nextVar = idx, varMap = bindNestEnv i idx (varMap s) }- ty' <- trType ty- return (idx, ty')---- Retrieve the variable index assigned to an identifier-getVarIndex :: Ident -> FlatState VarIndex-getVarIndex i = S.gets varMap >>= \ varEnv -> case lookupNestEnv i varEnv of- [v] -> return v- _ -> internalError $ "GenTypeAnnotatedFlatCurry.getVarIndex: " ++ escName i---- -------------------------------------------------------------------------------- Translation of an interface--- --------------------------------------------------------------------------------- Translate an operator declaration-trIOpDecl :: CS.IDecl -> FlatState [OpDecl]-trIOpDecl (CS.IInfixDecl _ fix prec op)- = (\op' -> [Op op' (cvFixity fix) prec]) <$> trQualIdent op-trIOpDecl _ = return []---- -------------------------------------------------------------------------------- Translation of a module--- -------------------------------------------------------------------------------trModule :: IL.Module -> FlatState (AProg TypeExpr)-trModule (IL.Module mid is ds) = do- is' <- getImports is- sns <- getTypeSynonyms >>= concatMapM trTypeSynonym- tds <- concatMapM trTypeDecl ds- fds <- concatMapM (return . map runNormalization <=< trAFuncDecl) ds- ops <- getFixities >>= concatMapM trIOpDecl- return $ AProg (moduleName mid) is' (sns ++ tds) fds ops---- Translate a type synonym-trTypeSynonym :: CS.Decl a -> FlatState [TypeDecl]-trTypeSynonym (CS.TypeDecl _ t tvs ty) = do- m <- getModuleIdent- qid <- flip qualifyWith t <$> getModuleIdent- t' <- trQualIdent qid- vis <- getTypeVisibility qid- tEnv <- S.gets tcEnv- ty' <- trType (transType $ expandType m tEnv $ toType tvs ty)- return [TypeSyn t' vis [0 .. length tvs - 1] ty']-trTypeSynonym _ = return []---- Translate a data declaration--- For empty data declarations, an additional constructor is generated. This--- is due to the fact that external data declarations are translated into data--- declarations with zero constructors and without the additional constructor--- empty data declarations could not be distinguished from external ones.-trTypeDecl :: IL.Decl -> FlatState [TypeDecl]-trTypeDecl (IL.DataDecl qid a []) = do- q' <- trQualIdent qid- vis <- getTypeVisibility qid- c <- trQualIdent $ qualify (mkIdent $ "_Constr#" ++ idName (unqualify qid))- let tvs = [0 .. a - 1]- return [Type q' vis tvs [Cons c 1 Private [TCons q' $ map TVar tvs]]]-trTypeDecl (IL.DataDecl qid a cs) = do- q' <- trQualIdent qid- vis <- getTypeVisibility qid- cs' <- mapM trConstrDecl cs- return [Type q' vis [0 .. a - 1] cs']-trTypeDecl (IL.ExternalDataDecl qid a) = do- q' <- trQualIdent qid- vis <- getTypeVisibility qid- return [Type q' vis [0 .. a - 1] []]-trTypeDecl _ = return []---- Translate a constructor declaration-trConstrDecl :: IL.ConstrDecl -> FlatState ConsDecl-trConstrDecl (IL.ConstrDecl qid tys) = flip Cons (length tys)- <$> trQualIdent qid- <*> getVisibility qid- <*> mapM trType tys---- Translate a type expression-trType :: IL.Type -> FlatState TypeExpr-trType (IL.TypeConstructor t tys) = TCons <$> trQualIdent t <*> mapM trType tys-trType (IL.TypeVariable idx) = return $ TVar $ abs idx-trType (IL.TypeArrow ty1 ty2) = FuncType <$> trType ty1 <*> trType ty2-trType (IL.TypeForall idxs ty) = ForallType (map abs idxs) <$> trType ty---- Convert a fixity-cvFixity :: CS.Infix -> Fixity-cvFixity CS.InfixL = InfixlOp-cvFixity CS.InfixR = InfixrOp-cvFixity CS.Infix = InfixOp---- -------------------------------------------------------------------------------- Function declarations--- --------------------------------------------------------------------------------- Translate a function declaration-trAFuncDecl :: IL.Decl -> FlatState [AFuncDecl TypeExpr]-trAFuncDecl (IL.FunctionDecl f vs _ e) = do- f' <- trQualIdent f- a <- getArity f- vis <- getVisibility f- ty' <- trType ty- r' <- trARule ty vs e- return [AFunc f' a vis ty' r']- where ty = foldr IL.TypeArrow (IL.typeOf e) $ map fst vs-trAFuncDecl (IL.ExternalDecl f ty) = do- f' <- trQualIdent f- a <- getArity f- vis <- getVisibility f- ty' <- trType ty- r' <- trAExternal ty f- return [AFunc f' a vis ty' r']-trAFuncDecl _ = return []---- Translate a function rule.--- Resets variable index so that for every rule variables start with index 1-trARule :: IL.Type -> [(IL.Type, Ident)] -> IL.Expression- -> FlatState (ARule TypeExpr)-trARule ty vs e = withFreshEnv $ ARule <$> trType ty- <*> mapM (uncurry newVar) vs- <*> trAExpr e--trAExternal :: IL.Type -> QualIdent -> FlatState (ARule TypeExpr)-trAExternal ty f = flip AExternal (qualName f) <$> trType ty---- Translate an expression-trAExpr :: IL.Expression -> FlatState (AExpr TypeExpr)-trAExpr (IL.Literal ty l) = ALit <$> trType ty <*> trLiteral l-trAExpr (IL.Variable ty v) = AVar <$> trType ty <*> getVarIndex v-trAExpr (IL.Function ty f _) = genCall Fun ty f []-trAExpr (IL.Constructor ty c _) = genCall Con ty c []-trAExpr (IL.Apply e1 e2) = trApply e1 e2-trAExpr c@(IL.Case t e bs) = flip ACase (cvEval t) <$> trType (IL.typeOf c) <*> trAExpr e- <*> mapM (inNestedEnv . trAlt) bs-trAExpr (IL.Or e1 e2) = AOr <$> trType (IL.typeOf e1) <*> trAExpr e1 <*> trAExpr e2-trAExpr (IL.Exist v ty e) = inNestedEnv $ do- v' <- newVar ty v- e' <- trAExpr e- ty' <- trType (IL.typeOf e)- return $ case e' of AFree ty'' vs e'' -> AFree ty'' (v' : vs) e''- _ -> AFree ty' (v' : []) e'-trAExpr (IL.Let (IL.Binding v b) e) = inNestedEnv $ do- v' <- newVar (IL.typeOf b) v- b' <- trAExpr b- e' <- trAExpr e- ty' <- trType $ IL.typeOf e- return $ case e' of ALet ty'' bs e'' -> ALet ty'' ((v', b'):bs) e''- _ -> ALet ty' ((v', b'):[]) e'-trAExpr (IL.Letrec bs e) = inNestedEnv $ do- let (vs, es) = unzip [ ((IL.typeOf b, v), b) | IL.Binding v b <- bs]- ALet <$> trType (IL.typeOf e)- <*> (zip <$> mapM (uncurry newVar) vs <*> mapM trAExpr es)- <*> trAExpr e-trAExpr (IL.Typed e _) = ATyped <$> ty' <*> trAExpr e <*> ty'- where ty' = trType $ IL.typeOf e---- Translate a literal-trLiteral :: IL.Literal -> FlatState Literal-trLiteral (IL.Char c) = return $ Charc c-trLiteral (IL.Int i) = return $ Intc i-trLiteral (IL.Float f) = return $ Floatc f---- Translate a higher-order application-trApply :: IL.Expression -> IL.Expression -> FlatState (AExpr TypeExpr)-trApply e1 e2 = genFlatApplic e1 [e2]- where- genFlatApplic e es = case e of- IL.Apply ea eb -> genFlatApplic ea (eb:es)- IL.Function ty f _ -> genCall Fun ty f es- IL.Constructor ty c _ -> genCall Con ty c es- _ -> do- expr <- trAExpr e- genApply expr es---- Translate an alternative-trAlt :: IL.Alt -> FlatState (ABranchExpr TypeExpr)-trAlt (IL.Alt p e) = ABranch <$> trPat p <*> trAExpr e---- Translate a pattern-trPat :: IL.ConstrTerm -> FlatState (APattern TypeExpr)-trPat (IL.LiteralPattern ty l) = ALPattern <$> trType ty <*> trLiteral l-trPat (IL.ConstructorPattern ty c vs) = do- qty <- trType $ foldr IL.TypeArrow ty $ map fst vs- APattern <$> trType ty <*> ((\q -> (q, qty)) <$> trQualIdent c) <*> mapM (uncurry newVar) vs-trPat (IL.VariablePattern _ _) = internalError "GenTypeAnnotatedFlatCurry.trPat"---- Convert a case type-cvEval :: IL.Eval -> CaseType-cvEval IL.Rigid = Rigid-cvEval IL.Flex = Flex--data Call = Fun | Con---- Generate a function or constructor call-genCall :: Call -> IL.Type -> QualIdent -> [IL.Expression]- -> FlatState (AExpr TypeExpr)-genCall call ty f es = do- f' <- trQualIdent f- arity <- getArity f- case compare supplied arity of- LT -> genAComb ty f' es (part call (arity - supplied))- EQ -> genAComb ty f' es (full call)- GT -> do- let (es1, es2) = splitAt arity es- funccall <- genAComb ty f' es1 (full call)- genApply funccall es2- where- supplied = length es- full Fun = FuncCall- full Con = ConsCall- part Fun = FuncPartCall- part Con = ConsPartCall--genAComb :: IL.Type -> QName -> [IL.Expression] -> CombType -> FlatState (AExpr TypeExpr)-genAComb ty qid es ct = do- ty' <- trType ty- let ty'' = defunc ty' (length es)- AComb ty'' ct (qid, ty') <$> mapM trAExpr es- where- defunc t 0 = t- defunc (FuncType _ t2) n = defunc t2 (n - 1)- defunc _ _ = internalError "GenTypeAnnotatedFlatCurry.genAComb.defunc"--genApply :: AExpr TypeExpr -> [IL.Expression] -> FlatState (AExpr TypeExpr)-genApply e es = do- ap <- trQualIdent $ qApplyId- es' <- mapM trAExpr es- return $ foldl (\e1 e2 -> let FuncType ty1 ty2 = typeOf e1 in AComb ty2 FuncCall (ap, FuncType (FuncType ty1 ty2) (FuncType ty1 ty2)) [e1, e2]) e es'---- -------------------------------------------------------------------------------- Normalization--- -------------------------------------------------------------------------------runNormalization :: Normalize a => a -> a-runNormalization x = S.evalState (normalize x) (0, Map.empty)--type NormState a = S.State (Int, Map.Map Int Int) a--class Normalize a where- normalize :: a -> NormState a--instance Normalize Int where- normalize i = do- (n, m) <- S.get- case Map.lookup i m of- Nothing -> do- S.put (n + 1, Map.insert i n m)- return n- Just n' -> return n'--instance Normalize TypeExpr where- normalize (TVar i) = TVar <$> normalize i- normalize (TCons q tys) = TCons q <$> mapM normalize tys- normalize (FuncType ty1 ty2) = FuncType <$> normalize ty1 <*> normalize ty2- normalize (ForallType is ty) =- ForallType <$> mapM normalize is <*> normalize ty--instance Normalize b => Normalize (a, b) where- normalize (x, y) = ((,) x) <$> normalize y--instance Normalize a => Normalize (AFuncDecl a) where- normalize (AFunc f a v ty r) = AFunc f a v <$> normalize ty <*> normalize r--instance Normalize a => Normalize (ARule a) where- normalize (ARule ty vs e) = ARule <$> normalize ty- <*> mapM normalize vs- <*> normalize e- normalize (AExternal ty s) = flip AExternal s <$> normalize ty--instance Normalize a => Normalize (AExpr a) where- normalize (AVar ty v) = flip AVar v <$> normalize ty- normalize (ALit ty l) = flip ALit l <$> normalize ty- normalize (AComb ty ct f es) = flip AComb ct <$> normalize ty- <*> normalize f- <*> mapM normalize es- normalize (ALet ty ds e) = ALet <$> normalize ty- <*> mapM normalizeBinding ds- <*> normalize e- where normalizeBinding (v, b) = (,) <$> normalize v <*> normalize b- normalize (AOr ty a b) = AOr <$> normalize ty <*> normalize a- <*> normalize b- normalize (ACase ty ct e bs) = flip ACase ct <$> normalize ty <*> normalize e- <*> mapM normalize bs- normalize (AFree ty vs e) = AFree <$> normalize ty <*> mapM normalize vs- <*> normalize e- normalize (ATyped ty e ty') = ATyped <$> normalize ty <*> normalize e- <*> normalize ty'--instance Normalize a => Normalize (ABranchExpr a) where- normalize (ABranch p e) = ABranch <$> normalize p <*> normalize e--instance Normalize a => Normalize (APattern a) where- normalize (APattern ty c vs) = APattern <$> normalize ty <*> normalize c- <*> mapM normalize vs- normalize (ALPattern ty l) = flip ALPattern l <$> normalize ty---- -------------------------------------------------------------------------------- Helper functions--- -------------------------------------------------------------------------------trQualIdent :: QualIdent -> FlatState QName-trQualIdent qid = do- mid <- getModuleIdent- return $ (moduleName $ fromMaybe mid mid', idName i)- where- mid' | i `elem` [listId, consId, nilId, unitId] || isTupleId i- = Just preludeMIdent- | otherwise- = qidModule qid- i = qidIdent qid--getTypeVisibility :: QualIdent -> FlatState Visibility-getTypeVisibility i = S.gets $ \s ->- if Set.member (unqualify i) (tyExports s) then Public else Private--getVisibility :: QualIdent -> FlatState Visibility-getVisibility i = S.gets $ \s ->- if Set.member (unqualify i) (valExports s) then Public else Private
src/Generators/GenTypedFlatCurry.hs view
@@ -15,498 +15,39 @@ {-# LANGUAGE CPP #-} module Generators.GenTypedFlatCurry (genTypedFlatCurry) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative ((<$>), (<*>))-#endif-import Control.Monad ((<=<))-import Control.Monad.Extra (concatMapM)-import qualified Control.Monad.State as S ( State, evalState, get, gets- , modify, put )-import Data.Function (on)-import Data.List (nub, sortBy)-import Data.Maybe (fromMaybe)-import qualified Data.Map as Map (Map, empty, insert, lookup)-import qualified Data.Set as Set (Set, empty, insert, member)--import Curry.Base.Ident-import Curry.Base.SpanInfo-import Curry.FlatCurry.Typed.Goodies (typeName)-import Curry.FlatCurry.Typed.Type-import qualified Curry.Syntax as CS--import Base.CurryTypes (toType)-import Base.Messages (internalError)-import Base.NestEnv ( NestEnv, emptyEnv, bindNestEnv, lookupNestEnv- , nestEnv, unnestEnv )-import Base.TypeExpansion-import Base.Types--import CompilerEnv-import Env.OpPrec (mkPrec)-import Env.TypeConstructor (TCEnv)-import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)--import qualified IL-import Transformations (transType)---- transforms intermediate language code (IL) to typed FlatCurry code-genTypedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module- -> TProg-genTypedFlatCurry env mdl il = patchPrelude $ run env mdl (trModule il)---- -------------------------------------------------------------------------------- Addition of primitive types for lists and tuples to the Prelude--- -------------------------------------------------------------------------------patchPrelude :: TProg -> TProg-patchPrelude p@(TProg n _ ts fs os)- | n == prelude = TProg n [] ts' fs os- | otherwise = p- where ts' = sortBy (compare `on` typeName) pts- pts = primTypes ++ ts--primTypes :: [TypeDecl]-primTypes =- [ Type arrow Public [0, 1] []- , Type unit Public [] [(Cons unit 0 Public [])]- , Type nil Public [0] [ Cons nil 0 Public []- , Cons cons 2 Public [TVar 0, TCons nil [TVar 0]]- ]- ] ++ map mkTupleType [2 .. maxTupleArity]- where arrow = mkPreludeQName "(->)"- unit = mkPreludeQName "()"- nil = mkPreludeQName "[]"- cons = mkPreludeQName ":"--mkTupleType :: Int -> TypeDecl-mkTupleType arity = Type tuple Public [0 .. arity - 1]- [Cons tuple arity Public (map TVar [0 .. arity - 1])]- where tuple = mkPreludeQName $ '(' : replicate (arity - 1) ',' ++ ")"--mkPreludeQName :: String -> QName-mkPreludeQName n = (prelude, n)--prelude :: String-prelude = "Prelude"---- |Maximal arity of tuples-maxTupleArity :: Int-maxTupleArity = 15---- --------------------------------------------------------------------------------- The environment 'FlatEnv' is embedded in the monadic representation--- 'FlatState' which allows the usage of 'do' expressions.-type FlatState a = S.State FlatEnv a---- Data type for representing an environment which contains information needed--- for generating FlatCurry code.-data FlatEnv = FlatEnv- { modIdent :: ModuleIdent -- current module- -- for visibility calculation- , tyExports :: Set.Set Ident -- exported types- , valExports :: Set.Set Ident -- exported values (functions + constructors)- , tcEnv :: TCEnv -- type constructor environment- , tyEnv :: ValueEnv -- type environment- , fixities :: [CS.IDecl] -- fixity declarations- , typeSynonyms :: [CS.Decl Type] -- type synonyms- , imports :: [ModuleIdent] -- module imports- -- state for mapping identifiers to indexes- , nextVar :: Int -- fresh variable index counter- , varMap :: NestEnv VarIndex -- map of identifier to variable index- }---- Runs a 'FlatState' action and returns the result-run :: CompilerEnv -> CS.Module Type -> FlatState a -> a-run env (CS.Module _ _ mid es is ds) act = S.evalState act env0- where- es' = case es of Just (CS.Exporting _ e) -> e- _ -> []- env0 = FlatEnv- { modIdent = mid- -- for visibility calculation- , tyExports = foldr (buildTypeExports mid) Set.empty es'- , valExports = foldr (buildValueExports mid) Set.empty es'- -- This includes *all* imports, even unused ones- , imports = nub [ m | CS.ImportDecl _ m _ _ _ <- is ]- -- Environment to retrieve the type of identifiers- , tyEnv = valueEnv env- , tcEnv = tyConsEnv env- -- Fixity declarations- , fixities = [ CS.IInfixDecl (spanInfo2Pos p) fix (mkPrec mPrec) (qualifyWith mid o)- | CS.InfixDecl p fix mPrec os <- ds, o <- os- ]- -- Type synonyms in the module- , typeSynonyms = [ d | d@CS.TypeDecl{} <- ds ]- , nextVar = 0- , varMap = emptyEnv- }---- Builds a table containing all exported identifiers from a module.-buildTypeExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident-buildTypeExports mid (CS.ExportTypeWith _ tc _)- | isLocalIdent mid tc = Set.insert (unqualify tc)-buildTypeExports _ _ = id---- Builds a table containing all exported identifiers from a module.-buildValueExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident-buildValueExports mid (CS.Export _ q)- | isLocalIdent mid q = Set.insert (unqualify q)-buildValueExports mid (CS.ExportTypeWith _ tc cs)- | isLocalIdent mid tc = flip (foldr Set.insert) cs-buildValueExports _ _ = id--getModuleIdent :: FlatState ModuleIdent-getModuleIdent = S.gets modIdent--getArity :: QualIdent -> FlatState Int-getArity qid = S.gets tyEnv >>= \ env -> return $ case qualLookupValue qid env of- [DataConstructor _ a _ _] -> a- [NewtypeConstructor _ _ _] -> 1- [Value _ _ a _] -> a- [Label _ _ _] -> 1- _ -> internalError- ("GenTypedFlatCurry.getArity: " ++ qualName qid)--getFixities :: FlatState [CS.IDecl]-getFixities = S.gets fixities---- The function 'typeSynonyms' returns the list of type synonyms.-getTypeSynonyms :: FlatState [CS.Decl Type]-getTypeSynonyms = S.gets typeSynonyms---- Retrieve imports-getImports :: [ModuleIdent] -> FlatState [String]-getImports imps = (nub . map moduleName . (imps ++)) <$> S.gets imports---- -------------------------------------------------------------------------------- Stateful part, used for translation of rules and expressions--- --------------------------------------------------------------------------------- resets var index and environment-withFreshEnv :: FlatState a -> FlatState a-withFreshEnv act = S.modify (\ s -> s { nextVar = 0, varMap = emptyEnv }) >> act---- Execute an action in a nested variable mapping-inNestedEnv :: FlatState a -> FlatState a-inNestedEnv act = do- S.modify $ \ s -> s { varMap = nestEnv $ varMap s }- res <- act- S.modify $ \ s -> s { varMap = unnestEnv $ varMap s }- return res---- Generates a new variable index for an identifier-newVar :: IL.Type -> Ident -> FlatState (VarIndex, TypeExpr)-newVar ty i = do- idx <- (+1) <$> S.gets nextVar- S.modify $ \ s -> s { nextVar = idx, varMap = bindNestEnv i idx (varMap s) }- ty' <- trType ty- return (idx, ty')---- Retrieve the variable index assigned to an identifier-getVarIndex :: Ident -> FlatState VarIndex-getVarIndex i = S.gets varMap >>= \ varEnv -> case lookupNestEnv i varEnv of- [v] -> return v- _ -> internalError $ "GenFlatCurry.getVarIndex: " ++ escName i---- -------------------------------------------------------------------------------- Translation of an interface--- --------------------------------------------------------------------------------- Translate an operator declaration-trIOpDecl :: CS.IDecl -> FlatState [OpDecl]-trIOpDecl (CS.IInfixDecl _ fix prec op)- = (\op' -> [Op op' (cvFixity fix) prec]) <$> trQualIdent op-trIOpDecl _ = return []---- -------------------------------------------------------------------------------- Translation of a module--- -------------------------------------------------------------------------------trModule :: IL.Module -> FlatState TProg-trModule (IL.Module mid is ds) = do- is' <- getImports is- sns <- getTypeSynonyms >>= concatMapM trTypeSynonym- tds <- concatMapM trTypeDecl ds- fds <- concatMapM (return . map runNormalization <=< trTFuncDecl) ds- ops <- getFixities >>= concatMapM trIOpDecl- return $ TProg (moduleName mid) is' (sns ++ tds) fds ops---- Translate a type synonym-trTypeSynonym :: CS.Decl a -> FlatState [TypeDecl]-trTypeSynonym (CS.TypeDecl _ t tvs ty) = do- m <- getModuleIdent- qid <- flip qualifyWith t <$> getModuleIdent- t' <- trQualIdent qid- vis <- getTypeVisibility qid- tEnv <- S.gets tcEnv- ty' <- trType (transType $ expandType m tEnv $ toType tvs ty)- return [TypeSyn t' vis [0 .. length tvs - 1] ty']-trTypeSynonym _ = return []---- Translate a data declaration--- For empty data declarations, an additional constructor is generated. This--- is due to the fact that external data declarations are translated into data--- declarations with zero constructors and without the additional constructor--- empty data declarations could not be distinguished from external ones.-trTypeDecl :: IL.Decl -> FlatState [TypeDecl]-trTypeDecl (IL.DataDecl qid a []) = do- q' <- trQualIdent qid- vis <- getTypeVisibility qid- c <- trQualIdent $ qualify (mkIdent $ "_Constr#" ++ idName (unqualify qid))- let tvs = [0 .. a - 1]- return [Type q' vis tvs [Cons c 1 Private [TCons q' $ map TVar tvs]]]-trTypeDecl (IL.DataDecl qid a cs) = do- q' <- trQualIdent qid- vis <- getTypeVisibility qid- cs' <- mapM trConstrDecl cs- return [Type q' vis [0 .. a - 1] cs']-trTypeDecl (IL.ExternalDataDecl qid a) = do- q' <- trQualIdent qid- vis <- getTypeVisibility qid- return [Type q' vis [0 .. a - 1] []]-trTypeDecl _ = return []---- Translate a constructor declaration-trConstrDecl :: IL.ConstrDecl -> FlatState ConsDecl-trConstrDecl (IL.ConstrDecl qid tys) = flip Cons (length tys)- <$> trQualIdent qid- <*> getVisibility qid- <*> mapM trType tys---- Translate a type expression-trType :: IL.Type -> FlatState TypeExpr-trType (IL.TypeConstructor t tys) = TCons <$> trQualIdent t <*> mapM trType tys-trType (IL.TypeVariable idx) = return $ TVar $ abs idx-trType (IL.TypeArrow ty1 ty2) = FuncType <$> trType ty1 <*> trType ty2-trType (IL.TypeForall idxs ty) = ForallType (map abs idxs) <$> trType ty---- Convert a fixity-cvFixity :: CS.Infix -> Fixity-cvFixity CS.InfixL = InfixlOp-cvFixity CS.InfixR = InfixrOp-cvFixity CS.Infix = InfixOp---- -------------------------------------------------------------------------------- Function declarations--- --------------------------------------------------------------------------------- Translate a function declaration-trTFuncDecl :: IL.Decl -> FlatState [TFuncDecl]-trTFuncDecl (IL.FunctionDecl f vs _ e) = do- f' <- trQualIdent f- a <- getArity f- vis <- getVisibility f- ty' <- trType ty- r' <- trTRule vs e- return [TFunc f' a vis ty' r']- where ty = foldr IL.TypeArrow (IL.typeOf e) $ map fst vs-trTFuncDecl (IL.ExternalDecl f ty) = do- f' <- trQualIdent f- a <- getArity f- vis <- getVisibility f- ty' <- trType ty- r' <- trTExternal ty f- return [TFunc f' a vis ty' r']-trTFuncDecl _ = return []---- Translate a function rule.--- Resets variable index so that for every rule variables start with index 1-trTRule :: [(IL.Type, Ident)] -> IL.Expression- -> FlatState TRule-trTRule vs e = withFreshEnv $ TRule <$> mapM (uncurry newVar) vs- <*> trTExpr e--trTExternal :: IL.Type -> QualIdent -> FlatState TRule-trTExternal ty f = flip TExternal (qualName f) <$> trType ty---- Translate an expression-trTExpr :: IL.Expression -> FlatState TExpr-trTExpr (IL.Literal ty l) = TLit <$> trType ty <*> trLiteral l-trTExpr (IL.Variable ty v) = TVarE <$> trType ty <*> getVarIndex v-trTExpr (IL.Function ty f _) = genCall Fun ty f []-trTExpr (IL.Constructor ty c _) = genCall Con ty c []-trTExpr (IL.Apply e1 e2) = trApply e1 e2-trTExpr (IL.Case t e bs) = TCase (cvEval t) <$> trTExpr e- <*> mapM (inNestedEnv . trAlt) bs-trTExpr (IL.Or e1 e2) = TOr <$> trTExpr e1 <*> trTExpr e2-trTExpr (IL.Exist v ty e) = inNestedEnv $ do- v' <- newVar ty v- e' <- trTExpr e- return $ case e' of TFree vs e'' -> TFree (v' : vs) e''- _ -> TFree (v' : []) e'-trTExpr (IL.Let (IL.Binding v b) e) = inNestedEnv $ do- v' <- newVar (IL.typeOf b) v- b' <- trTExpr b- e' <- trTExpr e- return $ case e' of TLet bs e'' -> TLet ((v', b'):bs) e''- _ -> TLet ((v', b'):[]) e'-trTExpr (IL.Letrec bs e) = inNestedEnv $ do- let (vs, es) = unzip [ ((IL.typeOf b, v), b) | IL.Binding v b <- bs]- TLet <$> (zip <$> mapM (uncurry newVar) vs <*> mapM trTExpr es)- <*> trTExpr e-trTExpr (IL.Typed e _) = TTyped <$> trTExpr e <*> ty'- where ty' = trType $ IL.typeOf e---- Translate a literal-trLiteral :: IL.Literal -> FlatState Literal-trLiteral (IL.Char c) = return $ Charc c-trLiteral (IL.Int i) = return $ Intc i-trLiteral (IL.Float f) = return $ Floatc f---- Translate a higher-order application-trApply :: IL.Expression -> IL.Expression -> FlatState TExpr-trApply e1 e2 = genFlatApplic e1 [e2]- where- genFlatApplic e es = case e of- IL.Apply ea eb -> genFlatApplic ea (eb:es)- IL.Function ty f _ -> genCall Fun ty f es- IL.Constructor ty c _ -> genCall Con ty c es- _ -> do- expr <- trTExpr e- genApply expr es---- Translate an alternative-trAlt :: IL.Alt -> FlatState TBranchExpr-trAlt (IL.Alt p e) = TBranch <$> trPat p <*> trTExpr e---- Translate a pattern-trPat :: IL.ConstrTerm -> FlatState TPattern-trPat (IL.LiteralPattern ty l) = TLPattern <$> trType ty <*> trLiteral l-trPat (IL.ConstructorPattern ty c vs) =- TPattern <$> trType ty <*> trQualIdent c <*> mapM (uncurry newVar) vs-trPat (IL.VariablePattern _ _) = internalError "GenTypedFlatCurry.trPat"---- Convert a case type-cvEval :: IL.Eval -> CaseType-cvEval IL.Rigid = Rigid-cvEval IL.Flex = Flex--data Call = Fun | Con---- Generate a function or constructor call-genCall :: Call -> IL.Type -> QualIdent -> [IL.Expression]- -> FlatState TExpr-genCall call ty f es = do- f' <- trQualIdent f- arity <- getArity f- case compare supplied arity of- LT -> genTComb ty f' es (part call (arity - supplied))- EQ -> genTComb ty f' es (full call)- GT -> do- let (es1, es2) = splitAt arity es- funccall <- genTComb ty f' es1 (full call)- genApply funccall es2- where- supplied = length es- full Fun = FuncCall- full Con = ConsCall- part Fun = FuncPartCall- part Con = ConsPartCall--genTComb :: IL.Type -> QName -> [IL.Expression] -> CombType -> FlatState TExpr-genTComb ty qid es ct = do- ty' <- trType ty- let ty'' = defunc ty' (length es)- TComb ty'' ct qid <$> mapM trTExpr es- where- defunc t 0 = t- defunc (FuncType _ t2) n = defunc t2 (n - 1)- defunc _ _ = internalError "GenTypedFlatCurry.genTComb.defunc"--genApply :: TExpr -> [IL.Expression] -> FlatState TExpr-genApply e es = do- ap <- trQualIdent qApplyId- es' <- mapM trTExpr es- return $ foldl (\e1 e2 -> let FuncType _ ty2 = typeOf e1- in TComb ty2 FuncCall ap [e1, e2])- e es'---- -------------------------------------------------------------------------------- Normalization--- -------------------------------------------------------------------------------runNormalization :: Normalize a => a -> a-runNormalization x = S.evalState (normalize x) (0, Map.empty)--type NormState a = S.State (Int, Map.Map Int Int) a--class Normalize a where- normalize :: a -> NormState a--instance Normalize Int where- normalize i = do- (n, m) <- S.get- case Map.lookup i m of- Nothing -> do- S.put (n + 1, Map.insert i n m)- return n- Just n' -> return n'--instance Normalize TypeExpr where- normalize (TVar i) = TVar <$> normalize i- normalize (TCons q tys) = TCons q <$> mapM normalize tys- normalize (FuncType ty1 ty2) = FuncType <$> normalize ty1 <*> normalize ty2- normalize (ForallType is ty) =- ForallType <$> mapM normalize is <*> normalize ty--instance Normalize b => Normalize (a, b) where- normalize (x, y) = (,) x <$> normalize y--instance Normalize TFuncDecl where- normalize (TFunc f a v ty r) = TFunc f a v <$> normalize ty <*> normalize r--instance Normalize TRule where- normalize (TRule vs e) = TRule <$> mapM normalize vs- <*> normalize e- normalize (TExternal ty s) = flip TExternal s <$> normalize ty--instance Normalize TExpr where- normalize (TVarE ty v) = flip TVarE v <$> normalize ty- normalize (TLit ty l) = flip TLit l <$> normalize ty- normalize (TComb ty ct f es) = flip TComb ct <$> normalize ty- <*> pure f- <*> mapM normalize es- normalize (TLet ds e) = TLet <$> mapM normalizeBinding ds- <*> normalize e- where normalizeBinding (v, b) = (,) <$> normalize v <*> normalize b- normalize (TOr a b) = TOr <$> normalize a- <*> normalize b- normalize (TCase ct e bs) = TCase ct <$> normalize e- <*> mapM normalize bs- normalize (TFree vs e) = TFree <$> mapM normalize vs- <*> normalize e- normalize (TTyped e ty') = TTyped <$> normalize e- <*> normalize ty'+import Curry.FlatCurry.Annotated.Type+import Curry.FlatCurry.Annotated.Goodies+import Curry.FlatCurry.Typed.Type -instance Normalize TBranchExpr where- normalize (TBranch p e) = TBranch <$> normalize p <*> normalize e+-- transforms annotated FlatCurry code to typed FlatCurry code+genTypedFlatCurry :: AProg TypeExpr -> TProg+genTypedFlatCurry = trAProg+ (\name imps types funcs ops ->+ TProg name imps types (map genTypedFuncDecl funcs) ops) -instance Normalize TPattern where- normalize (TPattern ty c vs) = TPattern <$> normalize ty- <*> pure c- <*> mapM normalize vs- normalize (TLPattern ty l) = flip TLPattern l <$> normalize ty+genTypedFuncDecl :: AFuncDecl TypeExpr -> TFuncDecl+genTypedFuncDecl = trAFunc+ (\name arity vis ty rule -> TFunc name arity vis ty $ genTypedRule rule) --- -------------------------------------------------------------------------------- Helper functions--- -----------------------------------------------------------------------------+genTypedRule :: ARule TypeExpr -> TRule+genTypedRule = trARule+ (\_ args e -> TRule args $ genTypedExpr e)+ TExternal -trQualIdent :: QualIdent -> FlatState QName-trQualIdent qid = do- mid <- getModuleIdent- return $ (moduleName $ fromMaybe mid mid', idName i)- where- mid' | i `elem` [listId, consId, nilId, unitId] || isTupleId i- = Just preludeMIdent- | otherwise- = qidModule qid- i = qidIdent qid+genTypedExpr :: AExpr TypeExpr -> TExpr+genTypedExpr = trAExpr+ TVarE+ TLit+ (\ty ct (name, _) args -> TComb ty ct name args)+ (const TLet)+ (const TFree)+ (const TOr)+ (const TCase)+ (TBranch . genTypedPattern)+ (const TTyped) -getTypeVisibility :: QualIdent -> FlatState Visibility-getTypeVisibility i = S.gets $ \s ->- if Set.member (unqualify i) (tyExports s) then Public else Private+genTypedPattern :: APattern TypeExpr -> TPattern+genTypedPattern = trAPattern+ (\ty (name, _) args -> TPattern ty name args)+ TLPattern -getVisibility :: QualIdent -> FlatState Visibility-getVisibility i = S.gets $ \s ->- if Set.member (unqualify i) (valExports s) then Public else Private
src/Html/CurryHtml.hs view
@@ -70,10 +70,10 @@ [ "<!DOCTYPE html>" , "<html lang=\"en\">" , "<head>"- , "<meta charset=\"utf-8\" />"- , "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\" />"+ , "<meta charset=\"utf-8\">"+ , "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1.0\">" , "<title>" ++ titleHtml ++ "</title>"- , "<link rel=\"stylesheet\" href=\"" ++ cssFileName ++ "\" />"+ , "<link rel=\"stylesheet\" href=\"" ++ cssFileName ++ "\">" , "</head>" , "<body>" , "<table><tbody><tr>"
src/Html/SyntaxColoring.hs view
@@ -257,7 +257,7 @@ -- ----------------------------------------------------------------------------- idsModule :: Module a -> [Code]-idsModule (Module _ _ mid es is ds) =+idsModule (Module _ _ _ mid es is ds) = let hdrCodes = ModuleName mid : idsExportSpec es impCodes = concatMap idsImportDecl (sortBy cmpImportDecl is) dclCodes = concatMap idsDecl (sortBy cmpDecl ds)@@ -299,35 +299,35 @@ -- Declarations idsDecl :: Decl a -> [Code]-idsDecl (InfixDecl _ _ _ ops) =+idsDecl (InfixDecl _ _ _ ops) = map (Function FuncInfix False . qualify) ops-idsDecl (DataDecl _ d vs cds clss) =+idsDecl (DataDecl _ d vs cds clss) = TypeCons TypeDeclare False (qualify d) : map (Identifier IdDeclare False . qualify) vs ++ concatMap idsConstrDecl cds ++ map (TypeCons TypeRefer False) clss-idsDecl (ExternalDataDecl _ d vs) =+idsDecl (ExternalDataDecl _ d vs) = TypeCons TypeDeclare False (qualify d) : map (Identifier IdDeclare False . qualify) vs-idsDecl (NewtypeDecl _ t vs nc clss) =+idsDecl (NewtypeDecl _ t vs nc clss) = TypeCons TypeDeclare False (qualify t) : map (Identifier IdDeclare False . qualify) vs ++ idsNewConstrDecl nc ++ map (TypeCons TypeRefer False) clss-idsDecl (TypeDecl _ t vs ty) =+idsDecl (TypeDecl _ t vs ty) = TypeCons TypeDeclare False (qualify t) : map (Identifier IdDeclare False . qualify) vs ++ idsTypeExpr ty-idsDecl (TypeSig _ fs qty) =+idsDecl (TypeSig _ fs qty) = map (Function FuncTypeSig False . qualify) fs ++ idsQualTypeExpr qty-idsDecl (FunctionDecl _ _ _ eqs) = concatMap idsEquation eqs-idsDecl (ExternalDecl _ fs) =+idsDecl (FunctionDecl _ _ _ eqs) = concatMap idsEquation eqs+idsDecl (ExternalDecl _ fs) = map (Function FuncDeclare False . qualify . varIdent) fs-idsDecl (PatternDecl _ p rhs) = idsPat p ++ idsRhs rhs-idsDecl (FreeDecl _ vs) =+idsDecl (PatternDecl _ p rhs) = idsPat p ++ idsRhs rhs+idsDecl (FreeDecl _ vs) = map (Identifier IdDeclare False . qualify . varIdent) vs-idsDecl (DefaultDecl _ tys) = concatMap idsTypeExpr tys-idsDecl (ClassDecl _ cx c v ds) =+idsDecl (DefaultDecl _ tys) = concatMap idsTypeExpr tys+idsDecl (ClassDecl _ _ cx c v ds) = idsContext cx ++ TypeCons TypeDeclare False (qualify c) : Identifier IdDeclare False (qualify v) : concatMap idsClassDecl ds-idsDecl (InstanceDecl _ cx c ty ds) = idsContext cx +++idsDecl (InstanceDecl _ _ cx c ty ds) = idsContext cx ++ TypeCons TypeRefer False c : idsTypeExpr ty ++ concatMap idsInstanceDecl ds idsConstrDecl :: ConstrDecl -> [Code]@@ -376,7 +376,7 @@ idsTypeExpr (ArrowType _ ty1 ty2) = concatMap idsTypeExpr [ty1, ty2] idsTypeExpr (ParenType _ ty) = idsTypeExpr ty idsTypeExpr (ForallType _ vs ty) =- map (Identifier IdDeclare False . qualify) vs ++ idsTypeExpr ty+ map (Identifier IdDeclare False . qualify) vs ++ Symbol "." : idsTypeExpr ty idsFieldDecl :: FieldDecl -> [Code] idsFieldDecl (FieldDecl _ ls ty) =@@ -393,8 +393,8 @@ idsLhs (ApLhs _ lhs ps) = idsLhs lhs ++ concatMap idsPat ps idsRhs :: Rhs a -> [Code]-idsRhs (SimpleRhs _ e ds) = idsExpr e ++ concatMap idsDecl ds-idsRhs (GuardedRhs _ ce ds) = concatMap idsCondExpr ce ++ concatMap idsDecl ds+idsRhs (SimpleRhs _ _ e ds) = idsExpr e ++ concatMap idsDecl ds+idsRhs (GuardedRhs _ _ ce ds) = concatMap idsCondExpr ce ++ concatMap idsDecl ds idsCondExpr :: CondExpr a -> [Code] idsCondExpr (CondExpr _ e1 e2) = idsExpr e1 ++ idsExpr e2@@ -446,10 +446,10 @@ idsExpr (LeftSection _ e op) = idsExpr e ++ idsInfix op idsExpr (RightSection _ op e) = idsInfix op ++ idsExpr e idsExpr (Lambda _ ps e) = concatMap idsPat ps ++ idsExpr e-idsExpr (Let _ ds e) = concatMap idsDecl ds ++ idsExpr e-idsExpr (Do _ stmts e) = concatMap idsStmt stmts ++ idsExpr e+idsExpr (Let _ _ ds e) = concatMap idsDecl ds ++ idsExpr e+idsExpr (Do _ _ stmts e) = concatMap idsStmt stmts ++ idsExpr e idsExpr (IfThenElse _ e1 e2 e3) = concatMap idsExpr [e1, e2, e3]-idsExpr (Case _ _ e alts) = idsExpr e ++ concatMap idsAlt alts+idsExpr (Case _ _ _ e alts) = idsExpr e ++ concatMap idsAlt alts idsField :: (a -> [Code]) -> Field a -> [Code] idsField f (Field _ l x) = Function FuncCall False l : f x@@ -459,9 +459,9 @@ idsInfix (InfixConstr _ qid) = [DataCons ConsInfix False qid] idsStmt :: Statement a -> [Code]-idsStmt (StmtExpr _ e) = idsExpr e-idsStmt (StmtDecl _ ds) = concatMap idsDecl ds-idsStmt (StmtBind _ p e) = idsPat p ++ idsExpr e+idsStmt (StmtExpr _ e) = idsExpr e+idsStmt (StmtDecl _ _ ds) = concatMap idsDecl ds+idsStmt (StmtBind _ p e) = idsPat p ++ idsExpr e idsAlt :: Alt a -> [Code] idsAlt (Alt _ p rhs) = idsPat p ++ idsRhs rhs
src/IL/Pretty.hs view
@@ -56,16 +56,19 @@ ppImport m = text "import" <+> text (moduleName m) ppDecl :: Decl -> Doc-ppDecl (DataDecl tc n cs) = sep $- text "data" <+> ppTypeLhs tc n :+ppDecl (DataDecl tc ks cs) = sep $+ text "data" <+> ppTypeLhs tc (length ks) : map (nest dataIndent) (zipWith (<+>) (equals : repeat (char '|')) (map ppConstr cs))-ppDecl (ExternalDataDecl tc n) =- text "external data" <+> ppTypeLhs tc n+ppDecl (NewtypeDecl tc ks nc) = sep $+ text "newtype" <+> ppTypeLhs tc (length ks) :+ [nest dataIndent (equals <+> ppNewConstr nc)]+ppDecl (ExternalDataDecl tc ks) =+ text "external data" <+> ppTypeLhs tc (length ks) ppDecl (FunctionDecl f vs ty e) = ppTypeSig f ty $$ sep [ ppQIdent f <+> hsep (map (ppIdent . snd) vs) <+> equals , nest bodyIndent (ppExpr 0 e)]-ppDecl (ExternalDecl f ty) = text "external" <+> ppTypeSig f ty+ppDecl (ExternalDecl f _ ty) = text "external" <+> ppTypeSig f ty ppTypeLhs :: QualIdent -> Int -> Doc ppTypeLhs tc n = ppQIdent tc <+> hsep (map text (take n typeVars))@@ -73,6 +76,9 @@ ppConstr :: ConstrDecl -> Doc ppConstr (ConstrDecl c tys) = ppQIdent c <+> fsep (map (ppType 2) tys) +ppNewConstr :: NewConstrDecl -> Doc+ppNewConstr (NewConstrDecl c ty) = ppQIdent c <+> fsep [ppType 2 ty]+ ppTypeSig :: QualIdent -> Type -> Doc ppTypeSig f ty = ppQIdent f <+> text "::" <+> ppType 0 ty @@ -83,9 +89,9 @@ | tc == qListId && length tys == 1 = brackets (ppType 0 (head tys)) | otherwise = parenIf (p > 1 && not (null tys)) (ppQIdent tc <+> fsep (map (ppType 2) tys))-ppType _ (TypeVariable n) = ppTypeVar n-ppType p (TypeArrow ty1 ty2) = parenIf (p > 0)- (fsep (ppArrow (TypeArrow ty1 ty2)))+ppType _ (TypeVariable n) = ppTypeVar n+ppType p (TypeArrow ty1 ty2) = parenIf (p > 0)+ (fsep (ppArrow (TypeArrow ty1 ty2))) where ppArrow (TypeArrow ty1' ty2') = ppType 1 ty1' <+> text "->" : ppArrow ty2' ppArrow ty = [ppType 0 ty]@@ -98,10 +104,10 @@ | n >= 0 = text (typeVars !! n) | otherwise = text ('_':show (-n)) -ppQuantifiedTypeVars :: [Int] -> Doc+ppQuantifiedTypeVars :: [(Int, Kind)] -> Doc ppQuantifiedTypeVars ns | null ns = empty- | otherwise = text "forall" <+> hsep (map ppTypeVar ns) <+> char '.'+ | otherwise = text "forall" <+> hsep (map (ppTypeVar . fst) ns) <> char '.' ppBinding :: Binding -> Doc ppBinding (Binding v expr) = sep
src/IL/ShowModule.hs view
@@ -39,6 +39,12 @@ . shows arity . space . showsList showsConstrDecl constrdecls . showsString ")"+showsDecl (NewtypeDecl qident arity newconstrdecl)+ = showsString "(NewtypeDecl "+ . showsQualIdent qident . space+ . shows arity . space+ . showsNewConstrDecl newconstrdecl+ . showsString ")" showsDecl (ExternalDataDecl qident arity) = showsString "(ExternalDataDecl " . showsQualIdent qident . space@@ -51,9 +57,10 @@ . showsType typ . space . showsExpression expr . showsString ")"-showsDecl (ExternalDecl qident typ)+showsDecl (ExternalDecl qident arity typ) = showsString "(ExternalDecl " . showsQualIdent qident . space+ . shows arity . showsType typ . showsString ")" @@ -62,6 +69,13 @@ = showsString "(ConstrDecl " . showsQualIdent qident . space . showsList showsType tys+ . showsString ")"++showsNewConstrDecl :: NewConstrDecl -> ShowS+showsNewConstrDecl (NewConstrDecl qident ty)+ = showsString "(NewConstrDecl "+ . showsQualIdent qident . space+ . showsType ty . showsString ")" showsType :: Type -> ShowS
src/IL/Type.hs view
@@ -42,9 +42,12 @@ -} module IL.Type- ( -- * Data types- Module (..), Decl (..), ConstrDecl (..), Type (..), Literal (..)- , ConstrTerm (..), Expression (..), Eval (..), Alt (..), Binding (..)+ ( -- * Representation of (type) variables+ TypeVariableWithKind+ -- * Data types+ , Module (..), Decl (..), ConstrDecl (..), NewConstrDecl (..), Type (..)+ , Kind (..), Literal (..), ConstrTerm (..), Expression (..), Eval (..)+ , Alt (..), Binding (..) ) where import Curry.Base.Ident@@ -55,21 +58,33 @@ deriving (Eq, Show) data Decl- = DataDecl QualIdent Int [ConstrDecl]- | ExternalDataDecl QualIdent Int+ = DataDecl QualIdent [Kind] [ConstrDecl]+ | NewtypeDecl QualIdent [Kind] NewConstrDecl+ | ExternalDataDecl QualIdent [Kind] | FunctionDecl QualIdent [(Type, Ident)] Type Expression- | ExternalDecl QualIdent Type+ | ExternalDecl QualIdent Int Type deriving (Eq, Show) +data NewConstrDecl = NewConstrDecl QualIdent Type+ deriving (Eq, Show)+ data ConstrDecl = ConstrDecl QualIdent [Type] deriving (Eq, Show) +type TypeVariableWithKind = (Int, Kind)+ data Type = TypeConstructor QualIdent [Type] | TypeVariable Int | TypeArrow Type Type- | TypeForall [Int] Type+ | TypeForall [TypeVariableWithKind] Type deriving (Eq, Show)++data Kind+ = KindStar+ | KindVariable Int+ | KindArrow Kind Kind+ deriving (Eq, Ord, Show) data Literal = Char Char
src/Imports.hs view
@@ -17,7 +17,7 @@ -} module Imports (importInterfaces, importModules, qualifyEnv) where -import Data.List (nubBy)+import Data.List (nubBy, find) import qualified Data.Map as Map import Data.Maybe (catMaybes, fromMaybe, isJust) import qualified Data.Set as Set@@ -49,7 +49,7 @@ importModules :: Monad m => Module a -> InterfaceEnv -> [ImportDecl] -> CYT m CompilerEnv-importModules mdl@(Module _ _ mid _ _ _) iEnv expImps+importModules mdl@(Module _ _ _ mid _ _ _) iEnv expImps = ok $ foldl importModule initEnv expImps where initEnv = (initCompilerEnv mid)@@ -265,11 +265,17 @@ where tc' = qualQualify m tc ty' = constrType tc' tvs values m (IFunctionDecl _ f Nothing a qty) =- [Value (qualQualify m f) False a (typeScheme (toQualPredType m [] qty))]+ [Value (qualQualify m f) Nothing a (typeScheme (toQualPredType m [] qty))] values m (IFunctionDecl _ f (Just tv) _ qty) =- [Value (qualQualify m f) True 0 (typeScheme (toQualPredType m [tv] qty))]+ let mcls = case qty of+ QualTypeExpr _ ctx _ -> fmap (\(Constraint _ qcls _) -> qcls) $+ find (\(Constraint _ _ ty) -> isVar ty) ctx+ in [Value (qualQualify m f) mcls 0 (typeScheme (toQualPredType m [tv] qty))]+ where+ isVar (VariableType _ i) = i == tv+ isVar _ = False values m (IClassDecl _ _ qcls _ tv ds hs) =- map (classMethod m qcls' tv) (filter ((`notElem` hs) . imethod) ds)+ map (classMethod m qcls' tv hs) ds where qcls' = qualQualify m qcls values _ _ = [] @@ -315,10 +321,13 @@ -- We always enter class methods with an arity of 0 into the value environment -- because there may be different implementations with different arities. -classMethod :: ModuleIdent -> QualIdent -> Ident -> IMethodDecl -> ValueInfo-classMethod m qcls tv (IMethodDecl _ f _ qty) =- Value (qualifyLike qcls f) True 0 $+classMethod :: ModuleIdent -> QualIdent -> Ident -> [Ident] -> IMethodDecl+ -> ValueInfo+classMethod m qcls tv hs (IMethodDecl _ f _ qty) =+ Value (qualifyLike qcls f) mcls 0 $ typeScheme $ qualifyPredType m $ toMethodType qcls tv qty+ where+ mcls = if f `elem` hs then Nothing else Just qcls -- ---------------------------------------------------------------------------
src/Interfaces.hs view
@@ -77,7 +77,7 @@ loadInterfaces :: [FilePath] -- ^ 'FilePath's to search in for interfaces -> Module a -- ^ 'Module' header with import declarations -> CYIO InterfaceEnv-loadInterfaces paths (Module _ _ m _ is _) = do+loadInterfaces paths (Module _ _ _ m _ is _) = do res <- liftIO $ S.execStateT load (LoaderState initInterfaceEnv paths []) if null (errs res) then ok (iEnv res) else failMessages (reverse $ errs res) where load = mapM_ (loadInterface [m]) [(p, m') | ImportDecl p m' _ _ _ <- is]@@ -93,33 +93,32 @@ -- for in the import paths and compiled. loadInterface :: HasPosition a => [ModuleIdent] -> (a, ModuleIdent) -> IntfLoader ()-loadInterface ctxt imp@(pp, m)- | m `elem` ctxt = report [errCyclicImport p (m : takeWhile (/= m) ctxt)]+loadInterface ctxt (_, m)+ | m `elem` ctxt = report [errCyclicImport $ m : takeWhile (/= m) ctxt] | otherwise = do isLoaded <- loaded m unless isLoaded $ do paths <- searchPaths mbIntf <- liftIO $ lookupCurryInterface paths m case mbIntf of- Nothing -> report [errInterfaceNotFound p m]- Just fn -> compileInterface ctxt imp fn- where p = getPosition pp+ Nothing -> report [errInterfaceNotFound m]+ Just fn -> compileInterface ctxt m fn -- |Compile an interface by recursively loading its dependencies. -- -- After reading an interface, all imported interfaces are recursively -- loaded and inserted into the interface's environment.-compileInterface :: HasPosition p => [ModuleIdent] -> (p, ModuleIdent) -> FilePath+compileInterface :: [ModuleIdent] -> ModuleIdent -> FilePath -> IntfLoader ()-compileInterface ctxt (p, m) fn = do+compileInterface ctxt m fn = do mbSrc <- liftIO $ readModule fn case mbSrc of- Nothing -> report [errInterfaceNotFound p m]+ Nothing -> report [errInterfaceNotFound m] Just src -> case runCYMIgnWarn (parseInterface fn src) of Left err -> report err Right intf@(Interface n is _) -> if m /= n- then report [errWrongInterface (first fn) m n]+ then report [errWrongInterface m n] else do let (intf', intfErrs) = intfSyntaxCheck intf mapM_ report [intfErrs]@@ -127,22 +126,22 @@ addInterface m intf' -- Error message for required interface that could not be found.-errInterfaceNotFound :: HasPosition p => p -> ModuleIdent -> Message-errInterfaceNotFound p m = posMessage p $+errInterfaceNotFound :: ModuleIdent -> Message+errInterfaceNotFound m = spanInfoMessage m $ text "Interface for module" <+> text (moduleName m) <+> text "not found" -- Error message for an unexpected interface.-errWrongInterface :: HasPosition p => p -> ModuleIdent -> ModuleIdent -> Message-errWrongInterface p m n = posMessage p $+errWrongInterface :: ModuleIdent -> ModuleIdent -> Message+errWrongInterface m n = spanInfoMessage m $ text "Expected interface for" <+> text (moduleName m) <> comma <+> text "but found" <+> text (moduleName n) -- Error message for a cyclic import.-errCyclicImport :: HasPosition p => p -> [ModuleIdent] -> Message-errCyclicImport _ [] = internalError "Interfaces.errCyclicImport: empty list"-errCyclicImport p [m] = posMessage p $+errCyclicImport :: [ModuleIdent] -> Message+errCyclicImport [] = internalError "Interfaces.errCyclicImport: empty list"+errCyclicImport [m] = spanInfoMessage m $ text "Recursive import for module" <+> text (moduleName m)-errCyclicImport p ms = posMessage p $+errCyclicImport ms = spanInfoMessage (head ms) $ text "Cyclic import dependency between modules" <+> hsep (punctuate comma (map text inits)) <+> text "and" <+> text lastm where
src/Modules.hs view
@@ -55,7 +55,7 @@ import qualified Curry.AbstractCurry as AC import qualified Curry.FlatCurry as FC import qualified Curry.Syntax as CS-import qualified IL as IL+import qualified IL import Checks import CompilerEnv@@ -93,11 +93,10 @@ writeParsed opts mdl let qmdl = qual mdl writeHtml opts qmdl- let umdl = (fst qmdl, fmap (const ()) (snd qmdl))- writeAST opts umdl- writeShortAST opts umdl+ writeAST opts (fst mdl, fmap (const ()) (snd mdl))+ writeShortAST opts (fst qmdl, fmap (const ()) (snd qmdl)) mdl' <- expandExports opts mdl- qmdl' <- dumpWith opts CS.showModule CS.ppModule DumpQualified $ qual mdl'+ qmdl' <- dumpWith opts CS.showModule pPrint DumpQualified $ qual mdl' writeAbstractCurry opts qmdl' -- generate interface file let intf = uncurry exportInterface qmdl'@@ -106,7 +105,10 @@ ((env, il), mdl'') <- transModule opts qmdl' writeFlat opts env (snd mdl'') il where- withFlat = any (`elem` optTargetTypes opts) [TypedFlatCurry, FlatCurry]+ withFlat = any (`elem` optTargetTypes opts) [ AnnotatedFlatCurry+ , TypedFlatCurry+ , FlatCurry+ ] loadAndCheckModule :: Options -> ModuleIdent -> FilePath -> CYIO (CompEnv (CS.Module PredType))@@ -125,13 +127,14 @@ -- parse and check module header (toks, mdl) <- parseModule opts m fn -- load the imported interfaces into an InterfaceEnv- let paths = map (addCurrySubdir (optUseSubdir opts))+ let paths = map (addOutDir (optUseOutDir opts) (optOutDir opts)) ("." : optImportPaths opts)- iEnv <- loadInterfaces paths mdl+ let withPrel = importPrelude opts mdl+ iEnv <- loadInterfaces paths withPrel checkInterfaces opts iEnv- is <- importSyntaxCheck iEnv mdl+ is <- importSyntaxCheck iEnv withPrel -- add information of imported modules- cEnv <- importModules mdl iEnv is+ cEnv <- importModules withPrel iEnv is return (cEnv { filePath = fn, tokens = toks }, mdl) parseModule :: Options -> ModuleIdent -> FilePath@@ -150,7 +153,7 @@ -- they will be issued a second time during parsing. spanToks <- liftCYM $ silent $ CS.lexSource fn condC ast <- liftCYM $ CS.parseModule fn condC- checked <- checkModuleHeader opts m fn ast+ checked <- checkModuleHeader m fn ast return (spanToks, checked) preprocess :: PrepOpts -> FilePath -> String -> CYIO String@@ -179,33 +182,33 @@ removeFile fn return res -checkModuleHeader :: Monad m => Options -> ModuleIdent -> FilePath+checkModuleHeader :: Monad m => ModuleIdent -> FilePath -> CS.Module () -> CYT m (CS.Module ())-checkModuleHeader opts m fn = checkModuleId m- . importPrelude opts- . CS.patchModuleId fn+checkModuleHeader m fn = checkModuleId m+ . CS.patchModuleId fn -- |Check whether the 'ModuleIdent' and the 'FilePath' fit together checkModuleId :: Monad m => ModuleIdent -> CS.Module () -> CYT m (CS.Module ())-checkModuleId mid m@(CS.Module _ _ mid' _ _ _)+checkModuleId mid m@(CS.Module _ _ _ mid' _ _ _) | mid == mid' = ok m | otherwise = failMessages [errModuleFileMismatch mid'] --- An implicit import of the prelude is added to the declarations of--- every module, except for the prelude itself, or when the import is disabled--- by a compiler option. If no explicit import for the prelude is present,--- the prelude is imported unqualified, otherwise a qualified import is added.+-- An implicit import of the prelude is temporariliy added to the declarations+-- of every module, except for the prelude itself, or when the import is+-- disabled by a compiler option. If no explicit import for the prelude is+-- present, the prelude is imported unqualified,+-- otherwise a qualified import is added. importPrelude :: Options -> CS.Module () -> CS.Module ()-importPrelude opts m@(CS.Module spi ps mid es is ds)+importPrelude opts m@(CS.Module spi li ps mid es is ds) -- the Prelude itself- | mid == preludeMIdent = m+ | mid == preludeMIdent = m -- disabled by compiler option- | noImpPrelude = m+ | noImpPrelude = m -- already imported- | preludeMIdent `elem` imported = m+ | preludeMIdent `elem` imports = m -- let's add it!- | otherwise = CS.Module spi ps mid es (preludeImp : is) ds+ | otherwise = CS.Module spi li ps mid es (preludeImp:is) ds where noImpPrelude = NoImplicitPrelude `elem` optExtensions opts || m `CS.hasLanguageExtension` NoImplicitPrelude@@ -213,7 +216,7 @@ False -- qualified? Nothing -- no alias Nothing -- no selection of types, functions, etc.- imported = [imp | (CS.ImportDecl _ imp _ _ _) <- is]+ imports = [imp | (CS.ImportDecl _ imp _ _ _) <- is] checkInterfaces :: Monad m => Options -> InterfaceEnv -> CYT m () checkInterfaces opts iEnv = mapM_ checkInterface (Map.elems iEnv)@@ -223,7 +226,7 @@ interfaceCheck opts (env, intf) importSyntaxCheck :: Monad m => InterfaceEnv -> CS.Module a -> CYT m [CS.ImportDecl]-importSyntaxCheck iEnv (CS.Module _ _ _ _ imps _) = mapM checkImportDecl imps+importSyntaxCheck iEnv (CS.Module _ _ _ _ _ imps _) = mapM checkImportDecl imps where checkImportDecl (CS.ImportDecl p m q asM is) = case Map.lookup m iEnv of Just intf -> CS.ImportDecl p m q asM `liftM` importCheck intf is@@ -252,7 +255,7 @@ where dumpCS :: (MonadIO m, Show a) => DumpLevel -> CompEnv (CS.Module a) -> m (CompEnv (CS.Module a))- dumpCS = dumpWith opts CS.showModule CS.ppModule+ dumpCS = dumpWith opts CS.showModule pPrint -- --------------------------------------------------------------------------- -- Translating a module@@ -261,19 +264,23 @@ transModule :: Options -> CompEnv (CS.Module PredType) -> CYIO (CompEnv IL.Module, CompEnv (CS.Module Type)) transModule opts mdl = do- derived <- dumpCS DumpDerived $ derive mdl- desugared <- dumpCS DumpDesugared $ desugar derived- dicts <- dumpCS DumpDictionaries $ insertDicts desugared- newtypes <- dumpCS DumpNewtypes $ removeNewtypes dicts- simplified <- dumpCS DumpSimplified $ simplify newtypes- lifted <- dumpCS DumpLifted $ lift simplified- il <- dumpIL DumpTranslated $ ilTrans lifted- ilCaseComp <- dumpIL DumpCaseCompleted $ completeCase il+ derived <- dumpCS DumpDerived $ derive mdl+ desugared <- dumpCS DumpDesugared $ desugar derived+ dicts <- dumpCS DumpDictionaries $ insertDicts inlDi desugared+ newtypes <- dumpCS DumpNewtypes $ removeNewtypes remNT dicts+ simplified <- dumpCS DumpSimplified $ simplify newtypes+ lifted <- dumpCS DumpLifted $ lift simplified+ il <- dumpIL DumpTranslated $ ilTrans remIm lifted+ ilCaseComp <- dumpIL DumpCaseCompleted $ completeCase il return (ilCaseComp, newtypes) where+ optOpts = optOptimizations opts+ inlDi = optInlineDictionaries optOpts+ remIm = optRemoveUnusedImports optOpts+ remNT = optDesugarNewtypes optOpts dumpCS :: Show a => DumpLevel -> CompEnv (CS.Module a) -> CYIO (CompEnv (CS.Module a))- dumpCS = dumpWith opts CS.showModule CS.ppModule+ dumpCS = dumpWith opts CS.showModule pPrint dumpIL = dumpWith opts IL.showModule IL.ppModule -- ---------------------------------------------------------------------------@@ -293,7 +300,7 @@ (showTokenStream (tokens env)) where tokTarget = Tokens `elem` optTargetTypes opts- useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)+ useSubDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env) writeComments :: Options -> CompilerEnv -> CYIO () writeComments opts env = when tokTarget $ liftIO $@@ -301,7 +308,7 @@ (showCommentTokenStream $ tokens env) where tokTarget = Comments `elem` optTargetTypes opts- useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)+ useSubDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env) -- |Output the parsed 'Module' on request writeParsed :: Show a => Options -> CompEnv (CS.Module a) -> CYIO ()@@ -309,7 +316,7 @@ writeModule (useSubDir $ sourceRepName (filePath env)) (CS.showModule mdl) where srcTarget = Parsed `elem` optTargetTypes opts- useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)+ useSubDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env) writeHtml :: Options -> CompEnv (CS.Module a) -> CYIO () writeHtml opts (env, mdl) = when htmlTarget $@@ -329,8 +336,8 @@ interfaceFile = interfName (filePath env) outputInterface = liftIO $ writeModule- (addCurrySubdirModule (optUseSubdir opts) m interfaceFile)- (show $ CS.ppInterface intf)+ (addOutDirModule (optUseOutDir opts) (optOutDir opts) m interfaceFile)+ (show $ pPrint intf) matchInterface :: FilePath -> CS.Interface -> IO Bool matchInterface ifn i = do@@ -342,24 +349,24 @@ writeFlat :: Options -> CompilerEnv -> CS.Module Type -> IL.Module -> CYIO () writeFlat opts env mdl il = do- (_, tfc) <- dumpWith opts show (FC.ppProg . genFlatCurry) DumpTypedFlatCurry (env, tfcyProg)- when tfcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir tfcyName) tafcyProg- when tafcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir tafcyName) tfc+ _ <- dumpWith opts show (pPrint . genFlatCurry) DumpTypedFlatCurry (env, afcy)+ when afcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir afcyName) afcy+ when tfcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir tfcyName) tfcy when fcyTarget $ do- (_, fc) <- dumpWith opts show FC.ppProg DumpFlatCurry (env, fcyProg)- liftIO $ FC.writeFlatCurry (useSubDir fcyName) fc- writeFlatIntf opts env fcyProg+ _ <- dumpWith opts show pPrint DumpFlatCurry (env, fcy)+ liftIO $ FC.writeFlatCurry (useSubDir fcyName) fcy+ writeFlatIntf opts env fcy where- tfcyName = typedFlatName (filePath env)- tfcyProg = genTypedFlatCurry env mdl il- tfcyTarget = TypedFlatCurry `elem` optTargetTypes opts- tafcyName = typeAnnFlatName (filePath env)- tafcyProg = genTypeAnnotatedFlatCurry env mdl il- tafcyTarget = TypeAnnotatedFlatCurry `elem` optTargetTypes opts- fcyName = flatName (filePath env)- fcyProg = genFlatCurry tfcyProg- fcyTarget = FlatCurry `elem` optTargetTypes opts- useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)+ afcy = genAnnotatedFlatCurry env mdl il+ afcyName = annotatedFlatName (filePath env)+ afcyTarget = AnnotatedFlatCurry `elem` optTargetTypes opts+ tfcy = genTypedFlatCurry afcy+ tfcyName = typedFlatName (filePath env)+ tfcyTarget = TypedFlatCurry `elem` optTargetTypes opts+ fcy = genFlatCurry afcy+ fcyName = flatName (filePath env)+ fcyTarget = FlatCurry `elem` optTargetTypes opts+ useSubDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env) writeFlatIntf :: Options -> CompilerEnv -> FC.Prog -> CYIO () writeFlatIntf opts env prog@@ -369,12 +376,12 @@ mfint <- liftIO $ FC.readFlatInterface targetFile let oldInterface = fromMaybe emptyIntf mfint when (mfint == mfint) $ return () -- necessary to close file -- TODO- unless (oldInterface `eqInterface` fint) $ outputInterface+ unless (oldInterface `eqInterface` fint) outputInterface where targetFile = flatIntName (filePath env) emptyIntf = FC.Prog "" [] [] [] [] fint = genFlatInterface prog- useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)+ useSubDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env) outputInterface = liftIO $ FC.writeFlatCurry (useSubDir targetFile) fint writeAbstractCurry :: Options -> CompEnv (CS.Module PredType) -> CYIO ()@@ -388,7 +395,7 @@ where acyTarget = AbstractCurry `elem` optTargetTypes opts uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts- useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)+ useSubDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env) writeAST :: Options -> CompEnv (CS.Module ()) -> CYIO ()@@ -396,7 +403,7 @@ writeModule (useSubDir $ astName (filePath env)) (CS.showModule mdl) where astTarget = AST `elem` optTargetTypes opts- useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)+ useSubDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env) writeShortAST :: Options -> CompEnv (CS.Module ()) -> CYIO ()@@ -405,7 +412,7 @@ (CS.showModule $ shortenModuleAST mdl) where astTarget = ShortAST `elem` optTargetTypes opts- useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)+ useSubDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env) type Dump = (DumpLevel, CompilerEnv, String)
src/Transformations.hs view
@@ -26,6 +26,8 @@ import Transformations.Qual as Q (qual) import Transformations.Simplify as S (simplify) +import Env.TypeConstructor+ import CompilerEnv import Imports (qualifyEnv) import qualified IL@@ -48,19 +50,20 @@ (tyConsEnv env) mdl -- |Insert dictionaries, changes the type constructor and value environments.-insertDicts :: CompEnv (Module PredType) -> CompEnv (Module Type)-insertDicts (env, mdl) = (env { interfaceEnv = intfEnv'- , tyConsEnv = tcEnv'- , valueEnv = vEnv'- , opPrecEnv = pEnv' }, mdl')+insertDicts :: Bool -> CompEnv (Module PredType) -> CompEnv (Module Type)+insertDicts inlDi (env, mdl) = (env { interfaceEnv = intfEnv'+ , tyConsEnv = tcEnv'+ , valueEnv = vEnv'+ , opPrecEnv = pEnv' }, mdl') where (mdl', intfEnv', tcEnv', vEnv', pEnv') =- DI.insertDicts (interfaceEnv env) (tyConsEnv env) (valueEnv env)- (classEnv env) (instEnv env) (opPrecEnv env) mdl+ DI.insertDicts inlDi (interfaceEnv env) (tyConsEnv env)+ (valueEnv env) (classEnv env) (instEnv env)+ (opPrecEnv env) mdl -- |Remove newtype constructors.-removeNewtypes :: CompEnv (Module Type) -> CompEnv (Module Type)-removeNewtypes (env, mdl) = (env, mdl')- where mdl' = NT.removeNewtypes (valueEnv env) mdl+removeNewtypes :: Bool -> CompEnv (Module Type) -> CompEnv (Module Type)+removeNewtypes remNT (env, mdl) = (env, mdl')+ where mdl' = NT.removeNewtypes remNT (valueEnv env) mdl -- |Simplify the source code, changes the value environment. simplify :: CompEnv (Module Type) -> CompEnv (Module Type)@@ -73,14 +76,14 @@ where (mdl', tyEnv') = L.lift (valueEnv env) mdl -- |Translate into the intermediate language-ilTrans :: CompEnv (Module Type) -> CompEnv IL.Module-ilTrans (env, mdl) = (env, il)- where il = IL.ilTrans (valueEnv env) mdl+ilTrans :: Bool -> CompEnv (Module Type) -> CompEnv IL.Module+ilTrans remIm (env, mdl) = (env, il)+ where il = IL.ilTrans remIm (valueEnv env) (tyConsEnv env) mdl --- |Translate a type into its representation in the intermediate language-transType :: Type -> IL.Type+transType :: TCEnv -> Type -> IL.Type transType = IL.transType -- |Add missing case branches completeCase :: CompEnv IL.Module -> CompEnv IL.Module-completeCase (env, mdl) = (env, CC.completeCase (interfaceEnv env) mdl)+completeCase (env, mdl) =+ (env, CC.completeCase (interfaceEnv env) (tyConsEnv env) mdl)
src/Transformations/CaseCompletion.hs view
@@ -50,6 +50,7 @@ ) import Base.Subst +import Env.TypeConstructor import Env.Interface (InterfaceEnv, lookupInterface) import Transformations.CurryToIL (transType)@@ -59,9 +60,9 @@ -- Completes case expressions by adding branches for missing constructors. -- The interface environment 'iEnv' is needed to compute these constructors.-completeCase :: InterfaceEnv -> Module -> Module-completeCase iEnv mdl@(Module mid is ds) = Module mid is ds'- where ds'= S.evalState (mapM ccDecl ds) (CCState mdl iEnv 0)+completeCase :: InterfaceEnv -> TCEnv -> Module -> Module+completeCase iEnv tcEnv mdl@(Module mid is ds) = Module mid is ds'+ where ds'= S.evalState (mapM ccDecl ds) (CCState mdl iEnv 0 tcEnv ) -- ----------------------------------------------------------------------------- -- Internally used state monad@@ -71,6 +72,7 @@ { modul :: Module , interfaceEnv :: InterfaceEnv , nextId :: Int+ , tyconEnv :: TCEnv } type CCM a = S.State CCState a@@ -78,6 +80,9 @@ getModule :: CCM Module getModule = S.gets modul +getTCEnv :: CCM TCEnv+getTCEnv = S.gets tyconEnv+ getInterfaceEnv :: CCM InterfaceEnv getInterfaceEnv = S.gets interfaceEnv @@ -96,7 +101,8 @@ ccDecl dd@(DataDecl _ _ _) = return dd ccDecl edd@(ExternalDataDecl _ _) = return edd ccDecl (FunctionDecl qid vs ty e) = FunctionDecl qid vs ty <$> ccExpr e-ccDecl ed@(ExternalDecl _ _) = return ed+ccDecl ed@(ExternalDecl _ _ _) = return ed+ccDecl nd@(NewtypeDecl _ _ _) = return nd ccExpr :: Expression -> CCM Expression ccExpr l@(Literal _ _) = return l@@ -165,8 +171,9 @@ completeConsAlts ea ce alts = do mdl <- getModule menv <- getInterfaceEnv+ tcEnv <- getTCEnv -- complementary constructor patterns- complPats <- mapM genPat $ getComplConstrs mdl menv+ complPats <- mapM genPat $ getComplConstrs mdl menv tcEnv [ c | (Alt (ConstructorPattern _ c _) _) <- consAlts ] v <- freshIdent w <- freshIdent@@ -315,16 +322,22 @@ failedExpr :: Type -> Expression failedExpr ty = Function ty (qualifyWith preludeMIdent (mkIdent "failed")) 0 +--TODO: Add note about arity of 0 because of the predefined functions in the Prelude eqExpr :: Expression -> Expression -> Expression-eqExpr e1 e2 = Apply (Apply (Function eqTy eq 2) e1) e2- where eq = qImplMethodId preludeMIdent qEqId ty $ mkIdent "=="+eqExpr e1 e2 = Apply (Apply (Function eqTy eq 0) e1) e2+ where eq = qImplMethodId preludeMIdent qDataId ty $ mkIdent "===" ty = case e2 of Literal _ l -> case l of Char _ -> charType Int _ -> intType Float _ -> floatType _ -> internalError "CaseCompletion.eqExpr: no literal"- ty' = transType ty+ ty' = case e2 of+ Literal _ l -> case l of+ Char _ -> charType'+ Int _ -> intType'+ Float _ -> floatType'+ _ -> internalError "CaseCompletion.eqExpr: no literal" eqTy = TypeArrow ty' (TypeArrow ty' boolType') truePatt :: ConstrTerm@@ -334,8 +347,17 @@ falsePatt = ConstructorPattern boolType' qFalseId [] boolType' :: Type-boolType' = transType boolType+boolType' = IL.TypeConstructor qBoolId [] +charType' :: Type+charType' = IL.TypeConstructor qCharId []++intType' :: Type+intType' = IL.TypeConstructor qIntId []++floatType' :: Type+floatType' = IL.TypeConstructor qFloatId []+ -- --------------------------------------------------------------------------- -- The following functions compute the missing constructors for generating -- missing case alternatives@@ -345,17 +367,20 @@ -- This functions uses the module environment 'menv', which contains all -- imported constructors, except for the built-in list constructors. -- TODO: Check if the list constructors are in the menv.-getComplConstrs :: Module -> InterfaceEnv -> [QualIdent] -> [(QualIdent, [Type])]-getComplConstrs _ _ []+getComplConstrs :: Module -> InterfaceEnv -> TCEnv+ -> [QualIdent] -> [(QualIdent, [Type])]+getComplConstrs _ _ _ [] = internalError "CaseCompletion.getComplConstrs: empty constructor list"-getComplConstrs (Module mid _ ds) menv cs@(c:_)+getComplConstrs (Module mid _ ds) menv tcEnv cs@(c:_) -- built-in lists | c `elem` [qNilId, qConsId] = complementary cs- [(qNilId, []), (qConsId, [TypeVariable 0, transType (listType boolType)])]+ [ (qNilId, [])+ , (qConsId, [TypeVariable 0, transType tcEnv (listType boolType)])+ ] -- current module | mid' == mid = getCCFromDecls cs ds -- imported module- | otherwise = maybe [] (getCCFromIDecls mid' cs)+ | otherwise = maybe [] (getCCFromIDecls mid' cs tcEnv) (lookupInterface mid' menv) where mid' = fromMaybe mid (qidModule c) @@ -379,9 +404,9 @@ constrInfo (ConstrDecl cid tys) = (cid, tys) -- Find complementary constructors within the module environment-getCCFromIDecls :: ModuleIdent -> [QualIdent] -> CS.Interface+getCCFromIDecls :: ModuleIdent -> [QualIdent] -> TCEnv-> CS.Interface -> [(QualIdent, [Type])]-getCCFromIDecls mid cs (CS.Interface _ _ ds) = complementary cs cinfos+getCCFromIDecls mid cs tcEnv (CS.Interface _ _ ds) = complementary cs cinfos where cinfos = map (uncurry constrInfo) $ maybe [] extractConstrDecls (find (`declares` head cs) ds)@@ -410,7 +435,7 @@ , [transType' vs ty | CS.FieldDecl _ ls ty <- fs, _ <- ls] ) - transType' vs = transType . toType vs+ transType' vs = transType tcEnv . toType vs -- Compute complementary constructors complementary :: [QualIdent] -> [(QualIdent, [Type])] -> [(QualIdent, [Type])]@@ -430,10 +455,11 @@ instance SubstType Type where subst sigma (TypeConstructor q tys) = TypeConstructor q $ subst sigma tys- subst sigma (TypeVariable tv) = substVar' TypeVariable subst sigma tv- subst sigma (TypeArrow ty1 ty2) = TypeArrow (subst sigma ty1) (subst sigma ty2)- subst _ (TypeForall _ _) =- internalError "Transformations.CaseCompletion.SubstType.Type.subst"+ subst sigma (TypeVariable tv) = substVar' TypeVariable subst sigma tv+ subst sigma (TypeArrow ty1 ty2)+ = TypeArrow (subst sigma ty1) (subst sigma ty2)+ subst sigma (TypeForall tvs ty)+ = TypeForall tvs (subst (foldr (unbindSubst . fst) sigma tvs) ty) matchType :: Type -> Type -> TypeSubst -> TypeSubst matchType ty1 ty2 = fromMaybe noMatch (matchType' ty1 ty2)
src/Transformations/CurryToIL.hs view
@@ -30,28 +30,34 @@ import Control.Monad.Extra (concatMapM) import qualified Control.Monad.Reader as R+import qualified Control.Monad.State as S import Data.List (nub, partition)-import qualified Data.Map as Map (Map, empty, insert, lookup)+import Data.Maybe (fromJust)+import qualified Data.Map as Map import qualified Data.Set as Set (Set, empty, insert, delete, toList) import Curry.Base.Ident import Curry.Syntax hiding (caseAlt) -import Base.CurryTypes (toType) import Base.Expr import Base.Messages (internalError)-import Base.Types+import Base.Types hiding (polyType)+import Base.Kinds import Base.Typing import Base.Utils (foldr2) +import Env.TypeConstructor import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue) import qualified IL as IL -ilTrans :: ValueEnv -> Module Type -> IL.Module-ilTrans vEnv (Module _ _ m _ _ ds) = IL.Module m (imports m ds') ds'- where ds' = R.runReader (concatMapM trDecl ds) (TransEnv m vEnv)+ilTrans :: Bool -> ValueEnv -> TCEnv -> Module Type -> IL.Module+ilTrans remIm vEnv tcEnv (Module _ _ _ m _ im ds) = IL.Module m im' ds'+ where ds' = R.runReader (concatMapM trDecl ds) (TransEnv m vEnv tcEnv)+ im' = preludeMIdent : if remIm then imports m ds' else map moduleImport im+ moduleImport (ImportDecl _ mdl _ _ _) = mdl + -- ----------------------------------------------------------------------------- -- Computation of necessary imports -- -----------------------------------------------------------------------------@@ -65,9 +71,11 @@ mdlsDecl :: IL.Decl -> Set.Set ModuleIdent -> Set.Set ModuleIdent mdlsDecl (IL.DataDecl _ _ cs) ms = foldr mdlsConstrsDecl ms cs where mdlsConstrsDecl (IL.ConstrDecl _ tys) ms' = foldr mdlsType ms' tys+mdlsDecl (IL.NewtypeDecl _ _ nc) ms = mdlsNewConstrDecl nc+ where mdlsNewConstrDecl (IL.NewConstrDecl _ ty) = mdlsType ty ms mdlsDecl (IL.ExternalDataDecl _ _) ms = ms mdlsDecl (IL.FunctionDecl _ _ ty e) ms = mdlsType ty (mdlsExpr e ms)-mdlsDecl (IL.ExternalDecl _ ty) ms = mdlsType ty ms+mdlsDecl (IL.ExternalDecl _ _ ty) ms = mdlsType ty ms mdlsType :: IL.Type -> Set.Set ModuleIdent -> Set.Set ModuleIdent mdlsType (IL.TypeConstructor tc tys) ms = modules tc (foldr mdlsType ms tys)@@ -103,6 +111,7 @@ data TransEnv = TransEnv { moduleIdent :: ModuleIdent , valueEnv :: ValueEnv+ , tyconEnv :: TCEnv } type TransM a = R.Reader TransEnv a@@ -110,17 +119,22 @@ getValueEnv :: TransM ValueEnv getValueEnv = R.asks valueEnv +getTCEnv :: TransM TCEnv+getTCEnv = R.asks tyconEnv+ trQualify :: Ident -> TransM QualIdent trQualify i = flip qualifyWith i <$> R.asks moduleIdent --- Return the type of a variable-varType :: QualIdent -> TransM Type-varType f = do- tyEnv <- getValueEnv- case qualLookupValue f tyEnv of- [Value _ _ _ (ForAll _ (PredType _ ty))] -> return ty- [Label _ _ (ForAll _ (PredType _ ty))] -> return ty- _ -> internalError $ "CurryToIL.varType: " ++ show f+getArity :: QualIdent -> TransM Int+getArity qid = do+ vEnv <- getValueEnv+ return $ case qualLookupValue qid vEnv of+ [DataConstructor _ a _ _] -> a+ [NewtypeConstructor _ _ _] -> 1+ [Value _ _ a _] -> a+ [Label _ _ _] -> 1+ _ ->+ internalError $ "CurryToIL.getArity: " ++ show qid -- Return the type of a constructor constrType :: QualIdent -> TransM Type@@ -131,6 +145,14 @@ [NewtypeConstructor _ _ (ForAll _ (PredType _ ty))] -> return ty _ -> internalError $ "CurryToIL.constrType: " ++ show c +-- Return the kinds of a type constructor's type variables+tcTVarKinds :: QualIdent -> TransM [Kind]+tcTVarKinds qid = do+ tcEnv <- getTCEnv+ let mid = fromJust $ qidModule qid+ kind = tcKind mid qid tcEnv+ return $ kindArgs kind+ -- ----------------------------------------------------------------------------- -- Translation -- -----------------------------------------------------------------------------@@ -144,57 +166,177 @@ trDecl :: Decl Type -> TransM [IL.Decl] trDecl (DataDecl _ tc tvs cs _) = (:[]) <$> trData tc tvs cs+trDecl (NewtypeDecl _ tc tvs nc _) = (:[]) <$> trNewtype tc tvs nc trDecl (ExternalDataDecl _ tc tvs) = (:[]) <$> trExternalData tc tvs-trDecl (FunctionDecl _ ty f eqs) = (:[]) <$> trFunction f ty eqs+trDecl (FunctionDecl _ _ f eqs) = (:[]) <$> trFunction f eqs trDecl (ExternalDecl _ vs) = mapM trExternal vs trDecl _ = return [] trData :: Ident -> [Ident] -> [ConstrDecl] -> TransM IL.Decl trData tc tvs cs = do tc' <- trQualify tc- IL.DataDecl tc' (length tvs) <$> mapM trConstrDecl cs+ ks <- tcTVarKinds tc'+ IL.DataDecl tc' (transKind <$> ks) <$> mapM trConstrDecl cs +trNewtype :: Ident -> [Ident] -> NewConstrDecl -> TransM IL.Decl+trNewtype tc tvs nc = do+ tc' <- trQualify tc+ ks <- tcTVarKinds tc'+ IL.NewtypeDecl tc' (transKind <$> ks) <$> trNewConstrDecl nc+ trConstrDecl :: ConstrDecl -> TransM IL.ConstrDecl trConstrDecl d = do c' <- trQualify (constr d) ty' <- arrowArgs <$> constrType c'- return $ IL.ConstrDecl c' (map transType ty')+ tcEnv <- getTCEnv+ return $ IL.ConstrDecl c' (map (transType tcEnv) ty') where constr (ConstrDecl _ c _) = c constr (ConOpDecl _ _ op _) = op constr (RecordDecl _ c _) = c +trNewConstrDecl :: NewConstrDecl -> TransM IL.NewConstrDecl+trNewConstrDecl d = do+ c' <- trQualify (constr d)+ ty' <- arrowArgs <$> constrType c'+ tcEnv <- getTCEnv+ case ty' of+ [ty] -> return $ IL.NewConstrDecl c' (transType tcEnv ty)+ _ -> internalError "CurryToIL.trNewConstrDecl: invalid constructor type"+ where+ constr (NewConstrDecl _ c _) = c+ constr (NewRecordDecl _ c _) = c+ trExternalData :: Ident -> [Ident] -> TransM IL.Decl-trExternalData tc tvs = flip IL.ExternalDataDecl (length tvs) <$> trQualify tc+trExternalData tc tvs = do+ tc' <- trQualify tc+ ks <- tcTVarKinds tc'+ return $ IL.ExternalDataDecl tc' (transKind <$> ks) trExternal :: Var Type -> TransM IL.Decl-trExternal (Var ty f) = flip IL.ExternalDecl (transType ty) <$> trQualify f+trExternal (Var ty f) = do+ tcEnv <- getTCEnv+ f' <- trQualify f+ a <- getArity f'+ return $ IL.ExternalDecl f' a (transType tcEnv $ polyType ty) -- The type representation in the intermediate language does not support -- types with higher order kinds. Therefore, the type transformations has -- to transform all types to first order terms. To that end, we assume the--- existence of a type synonym 'type @ f a = f a'. In addition, the type+-- existence of a type synonym 'type Apply f a = f a'. In addition, the type -- representation of the intermediate language does not support constrained -- type variables and skolem types. The former are fixed and the later are -- replaced by fresh type constructors. -transType :: Type -> IL.Type-transType ty = transType' ty []--transType' :: Type -> [IL.Type] -> IL.Type-transType' (TypeConstructor tc) = IL.TypeConstructor tc-transType' (TypeApply ty1 ty2) = transType' ty1 . (transType ty2 :)-transType' (TypeVariable tv) = foldl applyType' (IL.TypeVariable tv)-transType' (TypeConstrained tys _) = transType' (head tys)-transType' (TypeArrow ty1 ty2) =- foldl applyType' (IL.TypeArrow (transType ty1) (transType ty2))-transType' (TypeForall tvs ty) =- foldl applyType' (IL.TypeForall tvs (transType ty))+transType :: TCEnv -> Type -> IL.Type+transType tcEnv ty' = transType' ty' []+ where+ ks = transTVars tcEnv ty'+ transType' (TypeConstructor tc) = IL.TypeConstructor tc+ transType' (TypeApply ty1 ty2) = transType' ty1 . (transType' ty2 [] :)+ transType' (TypeVariable tv) = foldl applyType' (IL.TypeVariable tv)+ transType' (TypeConstrained tys _) = transType' (head tys)+ transType' (TypeArrow ty1 ty2) =+ foldl applyType' (IL.TypeArrow (transType' ty1 []) (transType' ty2 []))+ transType' (TypeForall tvs ty) =+ foldl applyType' (IL.TypeForall tvs' (transType' ty []))+ where tvs' = filter ((`elem` tvs) . fst) ks applyType' :: IL.Type -> IL.Type -> IL.Type applyType' ty1 ty2 = IL.TypeConstructor (qualifyWith preludeMIdent (mkIdent "Apply")) [ty1, ty2] +-- We need to existentially quantify all variables in some types+polyType :: Type -> Type+polyType (TypeForall _ ty) = polyType ty+polyType ty =+ let vs = nub $ typeVars ty+ in if null vs then ty else TypeForall vs ty++-- We need to infer kinds for the quantified variables.+-- We already checked the correctness of all Kinds earlier,+-- thus we know that we will be able to unify all the inferred equations.+-- We can also keep a flat environment,+-- as all variables have already been renamed.++data KIS = KIS+ { _nextId :: Int+ , kinds :: Map.Map Int IL.Kind+ }++freshId :: S.State KIS Int+freshId = do+ KIS i ks <- S.get+ S.put (KIS (i+1) ks)+ return i++transTVars :: TCEnv -> Type -> [(Int, IL.Kind)]+transTVars tcEnv ty' =+ Map.toList $ kinds $ S.execState (build ty' IL.KindStar) (KIS 0 Map.empty)+ where+ build :: Type -> IL.Kind -> S.State KIS ()+ build (TypeArrow ty1 ty2) _ =+ build ty1 IL.KindStar >> build ty2 IL.KindStar+ build (TypeConstrained tys _) k =+ build (head tys) k+ build (TypeForall _ ty) k =+ build ty k+ build (TypeVariable tv) k = do+ KIS i ks <- S.get+ -- get current kind+ let k' = Map.findWithDefault k tv ks+ -- unify it+ let s = unifyKind k k'+ -- apply substitution+ let ks' = fmap (applyKindSubst s) $ Map.insert tv k' ks+ S.put (KIS i ks')+ build (TypeConstructor _) _ = return ()+ build ta@(TypeApply _ _) k =+ let (ty, tys) = unapplyType True ta+ in case ty of+ TypeConstructor tc -> do+ let k' = tcKind (fromJust $ qidModule tc) tc tcEnv+ mapM_ (uncurry build) (zip tys $ unarrowKind $ transKind k')+ _ -> do -- var of forall+ -- construct new kind vars+ ks <- mapM (const (freshId >>= return . IL.KindVariable)) tys+ -- infer kind for v+ build ty (foldr IL.KindArrow k ks)+ -- infer kinds for args+ mapM_ (uncurry build) (zip tys ks)++type KindSubst = Map.Map Int IL.Kind++transKind :: Kind -> IL.Kind+transKind KindStar = IL.KindStar+transKind (KindVariable _) = IL.KindStar+transKind (KindArrow k1 k2) = IL.KindArrow (transKind k1) (transKind k2)++unarrowKind :: IL.Kind -> [IL.Kind]+unarrowKind (IL.KindArrow k1 k2) = k1 : unarrowKind k2+unarrowKind k = [k]++applyKindSubst :: KindSubst -> IL.Kind -> IL.Kind+applyKindSubst _ IL.KindStar =+ IL.KindStar+applyKindSubst s (IL.KindArrow k1 k2) =+ IL.KindArrow (applyKindSubst s k1) (applyKindSubst s k2)+applyKindSubst s v@(IL.KindVariable i) =+ Map.findWithDefault v i s++composeKindSubst :: KindSubst -> KindSubst -> KindSubst+composeKindSubst s1 s2 = Map.map (applyKindSubst s1) s2 `Map.union` s1++unifyKind :: IL.Kind -> IL.Kind -> KindSubst+unifyKind IL.KindStar IL.KindStar = Map.empty+unifyKind (IL.KindVariable i) k = Map.singleton i k+unifyKind k (IL.KindVariable i) = Map.singleton i k+unifyKind (IL.KindArrow k1 k2) (IL.KindArrow k1' k2') =+ let s1 = unifyKind k1 k1'+ s2 = unifyKind (applyKindSubst s1 k2) (applyKindSubst s1 k2')+ in s1 `composeKindSubst` s2+unifyKind k1 k2 = error $ "Transformation.CurryToIL.unifyKind: " ++ show k1 ++ ", " ++ show k2+ -- Each function in the program is translated into a function of the -- intermediate language. The arguments of the function are renamed such -- that all variables occurring in the same position (in different@@ -215,17 +357,19 @@ -- selector function have to be renamed according to the name mapping -- computed for its first argument. -trFunction :: Ident -> Type -> [Equation Type] -> TransM IL.Decl-trFunction f ty eqs = do+trFunction :: Ident -> [Equation Type] -> TransM IL.Decl+trFunction f eqs = do f' <- trQualify f- let ty' = transType ty- vs' = zip (map (transType . typeOf) ts) vs+ tcEnv <- getTCEnv+ let tys = map typeOf ts+ ty' = transType tcEnv $ polyType $ foldr TypeArrow (typeOf rhs) tys+ vs' = zip (map (transType tcEnv) tys) vs alts <- mapM (trEquation vs ws) eqs return $ IL.FunctionDecl f' vs' ty' (flexMatch vs' alts) where -- vs are the variables needed for the function: _1, _2, etc. -- ws is an infinite list for introducing additional variables later- Equation _ lhs _ = head eqs+ Equation _ lhs rhs = head eqs (_, ts) = flatLhs lhs (vs, ws) = splitAt (length ts) (argNames (mkIdent "")) @@ -239,7 +383,8 @@ -- translate right-hand-side rhs' <- trRhs vs' patternRenaming rhs -- convert patterns- return (zipWith trPattern vs ts, rhs')+ tcEnv <- getTCEnv+ return (zipWith (trPattern tcEnv) vs ts, rhs') trEquation _ _ _ = internalError "Translation of non-FunLhs euqation not defined" @@ -257,8 +402,8 @@ = internalError "CurryToIL.bindRenameEnv" trRhs :: [Ident] -> RenameEnv -> Rhs Type -> TransM IL.Expression-trRhs vs env (SimpleRhs _ e _) = trExpr vs env e-trRhs _ _ (GuardedRhs _ _ _) = internalError "CurryToIL.trRhs: GuardedRhs"+trRhs vs env (SimpleRhs _ _ e _) = trExpr vs env e+trRhs _ _ (GuardedRhs _ _ _ _) = internalError "CurryToIL.trRhs: GuardedRhs" -- Note that the case matching algorithm assumes that the matched -- expression is accessible through a variable. The translation of case@@ -269,22 +414,30 @@ -- instance, if one of the alternatives contains an as-pattern. trExpr :: [Ident] -> RenameEnv -> Expression Type -> TransM IL.Expression-trExpr _ _ (Literal _ ty l) = return $ IL.Literal (transType ty) (trLiteral l)+trExpr _ _ (Literal _ ty l) = do+ tcEnv <- getTCEnv+ return $ IL.Literal (transType tcEnv ty) (trLiteral l) trExpr _ env (Variable _ ty v)- | isQualified v = fun- | otherwise = case Map.lookup (unqualify v) env of- Nothing -> fun- Just v' -> return $ IL.Variable (transType ty) v' -- apply renaming- where fun = (IL.Function (transType ty) v . arrowArity) <$> varType v-trExpr _ _ (Constructor _ ty c)- = (IL.Constructor (transType ty) c . arrowArity) <$> constrType c+ | isQualified v = getTCEnv >>= fun+ | otherwise = do+ tcEnv <- getTCEnv+ case Map.lookup (unqualify v) env of+ Nothing -> error $ "unexpected variable" ++ show v --TODO: Replace case by fromJust?+ Just v' -> return $ IL.Variable (transType tcEnv ty) v' -- apply renaming+ where+ fun tcEnv = IL.Function (transType tcEnv ty) v <$> getArity v+trExpr _ _ (Constructor _ ty c) = do+ tcEnv <- getTCEnv+ IL.Constructor (transType tcEnv ty) c <$> getArity c trExpr vs env (Apply _ e1 e2) = IL.Apply <$> trExpr vs env e1 <*> trExpr vs env e2-trExpr vs env (Let _ ds e) = do+trExpr vs env (Let _ _ ds e) = do e' <- trExpr vs env' e case ds of [FreeDecl _ vs']- -> return $ foldr (\ (Var ty v) -> IL.Exist v (transType ty)) e' vs'+ -> do tcEnv <- getTCEnv+ return $+ foldr (\ (Var ty v) -> IL.Exist v (transType tcEnv ty)) e' vs' [d] | all (`notElem` bv d) (qfv emptyMIdent d) -> flip IL.Let e' <$> trBinding d _ -> flip IL.Letrec e' <$> mapM trBinding ds@@ -294,12 +447,13 @@ trBinding (PatternDecl _ (VariablePattern _ _ v) rhs) = IL.Binding v <$> trRhs vs env' rhs trBinding p = error $ "unexpected binding: " ++ show p-trExpr (v:vs) env (Case _ ct e alts) = do+trExpr (v:vs) env (Case _ _ ct e alts) = do -- the ident v is used for the case expression subject, as this could -- be referenced in the case alternatives by a variable pattern e' <- trExpr vs env e+ tcEnv <- getTCEnv let matcher = if ct == Flex then flexMatch else rigidMatch- ty' = transType $ typeOf e+ ty' = transType tcEnv $ typeOf e expr <- matcher [(ty', v)] <$> mapM (trAlt (v:vs) env) alts return $ case expr of IL.Case mode (IL.Variable _ v') alts'@@ -309,15 +463,17 @@ -- subject is referenced -> introduce binding for v as subject | v `elem` fv expr -> IL.Let (IL.Binding v e') expr | otherwise -> expr-trExpr vs env (Typed _ e (QualTypeExpr _ _ ty)) =- flip IL.Typed ty' <$> trExpr vs env e- where ty' = transType (toType [] ty)+trExpr vs env (Typed _ e _) = do+ tcEnv <- getTCEnv+ e' <- trExpr vs env e+ return $ IL.Typed e' (transType tcEnv $ typeOf e) trExpr _ _ _ = internalError "CurryToIL.trExpr" trAlt :: [Ident] -> RenameEnv -> Alt Type -> TransM Match trAlt ~(v:vs) env (Alt _ t rhs) = do+ tcEnv <- getTCEnv rhs' <- trRhs vs (bindRenameEnv v t env) rhs- return ([trPattern v t], rhs')+ return ([trPattern tcEnv v t], rhs') trLiteral :: Literal -> IL.Literal trLiteral (Char c) = IL.Char c@@ -337,18 +493,20 @@ arguments :: NestedTerm -> [NestedTerm] arguments (NestedTerm _ ts) = ts -trPattern :: Ident -> Pattern Type -> NestedTerm-trPattern _ (LiteralPattern _ ty l)- = NestedTerm (IL.LiteralPattern (transType ty) $ trLiteral l) []-trPattern v (VariablePattern _ ty _)- = NestedTerm (IL.VariablePattern (transType ty) v) []-trPattern v (ConstructorPattern _ ty c ts)- = NestedTerm (IL.ConstructorPattern (transType ty) c vs')- (zipWith trPattern vs ts)+trPattern :: TCEnv -> Ident -> Pattern Type -> NestedTerm+trPattern tcEnv _ (LiteralPattern _ ty l)+ = NestedTerm (IL.LiteralPattern (transType tcEnv ty) $ trLiteral l) []+trPattern tcEnv v (VariablePattern _ ty _)+ = NestedTerm (IL.VariablePattern (transType tcEnv ty) v) []+trPattern tcEnv v (ConstructorPattern _ ty c ts)+ = NestedTerm (IL.ConstructorPattern (transType tcEnv ty) c vs')+ (zipWith (trPattern tcEnv) vs ts) where vs = argNames v- vs' = zip (map (transType . typeOf) ts) vs-trPattern v (AsPattern _ _ t) = trPattern v t-trPattern _ _ = internalError "CurryToIL.trPattern"+ vs' = zip (map (transType tcEnv . typeOf) ts) vs+trPattern tcEnv v (AsPattern _ _ t)+ = trPattern tcEnv v t+trPattern _ _ _+ = internalError "CurryToIL.trPattern" argNames :: Ident -> [Ident] argNames v = [mkIdent (prefix ++ show i) | i <- [1 :: Integer ..] ]
src/Transformations/Derive.hs view
@@ -16,6 +16,7 @@ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif+import Control.Monad (replicateM) import qualified Control.Monad.State as S (State, evalState, gets, modify) import Data.List (intercalate, intersperse) import Data.Maybe (fromJust, isJust)@@ -50,8 +51,8 @@ derive :: TCEnv -> ValueEnv -> InstEnv -> OpPrecEnv -> Module PredType -> Module PredType-derive tcEnv vEnv inEnv pEnv (Module spi ps m es is ds) = Module spi ps m es is $- ds ++ concat (S.evalState (mapM deriveInstances tds) initState)+derive tcEnv vEnv inEnv pEnv (Module spi li ps m es is ds) = Module spi li ps m es is $+ ds ++ concat (S.evalState (deriveAllInstances tds) initState) where tds = filter isTypeDecl ds initState = DVState m tcEnv vEnv inEnv pEnv 1 @@ -80,6 +81,35 @@ type ConstrInfo = (Int, QualIdent, Maybe [Ident], [Type]) +deriveAllInstances :: [Decl PredType] -> DVM [[Decl PredType]]+deriveAllInstances ds = do+ derived <- mapM deriveInstances ds+ inst <- getInstEnv+ mid <- getModuleIdent+ let dds = filter (hasDataInstance inst mid) ds+ datains <- mapM deriveDataInstance dds+ return (datains:derived)++-- If we ever entered a data instance for this datatype into the instance+-- environment, we can safely derive a data instance+hasDataInstance :: InstEnv -> ModuleIdent -> Decl PredType -> Bool+hasDataInstance inst mid (DataDecl _ tc _ _ _) =+ maybe False (\(mid', _, _) -> mid == mid') $+ lookupInstInfo (qDataId, qualifyWith mid tc) inst+hasDataInstance inst mid (NewtypeDecl _ tc _ _ _) =+ maybe False (\(mid', _, _) -> mid == mid') $+ lookupInstInfo (qDataId, qualifyWith mid tc) inst+hasDataInstance _ _ _ =+ False++deriveDataInstance :: Decl PredType -> DVM (Decl PredType)+deriveDataInstance (DataDecl p tc tvs _ _) =+ head <$> deriveInstances (DataDecl p tc tvs [] [qDataId])+deriveDataInstance (NewtypeDecl p tc tvs _ _) =+ deriveDataInstance $ DataDecl p tc tvs [] []+deriveDataInstance _ =+ internalError "Derive.deriveDataInstance: No DataDel"+ -- An instance declaration is created for each type class of a deriving clause. -- Newtype declaration are simply treated as data declarations. @@ -103,7 +133,7 @@ take (length tvs) $ map TypeVariable [0 ..] QualTypeExpr _ cx inst = fromPredType tvs $ PredType ps ty ds <- deriveMethods cls ty cis ps- return $ InstanceDecl NoSpanInfo cx cls inst ds+ return $ InstanceDecl NoSpanInfo WhitespaceLayout cx cls inst ds -- Note: The methods and arities of the generated instance declarations have to -- correspond to the methods and arities entered previously into the instance@@ -118,6 +148,7 @@ | cls == qBoundedId = deriveBoundedMethods | cls == qReadId = deriveReadMethods | cls == qShowId = deriveShowMethods+ | cls == qDataId = deriveDataMethods | otherwise = internalError $ "Derive.deriveMethods: " ++ show cls -- Binary Operators:@@ -133,7 +164,11 @@ deriveBinOp cls op expr ty cis ps = do pty <- getInstMethodType ps cls ty op eqs <- mapM (deriveBinOpEquation op expr ty) $ sequence [cis, cis]- return $ FunctionDecl NoSpanInfo pty op eqs+ return $ FunctionDecl NoSpanInfo pty op $+ if null eqs+ then [mkEquation NoSpanInfo op [] $+ preludeFailed $ instType $ unpredType pty]+ else eqs deriveBinOpEquation :: Ident -> BinOpExpr -> Type -> [ConstrInfo] -> DVM (Equation PredType)@@ -160,6 +195,39 @@ else foldl1 prelAnd $ zipWith prelEq es1 es2 | otherwise = prelFalse +-- Data:++deriveDataMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType]+deriveDataMethods ty cis ps = sequence+ [ deriveBinOp qDataId dataEqId dataEqOpExpr ty cis ps+ , deriveAValue ty cis ps]++dataEqOpExpr :: BinOpExpr+dataEqOpExpr i1 es1 i2 es2+ | i1 == i2 = if null es1 then prelTrue+ else foldl1 prelAnd $ zipWith prelDataEq es1 es2+ | otherwise = prelFalse++deriveAValue :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType)+deriveAValue ty cis ps = do+ pty <- getInstMethodType ps qDataId ty aValueId+ return $ FunctionDecl NoSpanInfo pty aValueId $+ if null cis+ then [mkEquation NoSpanInfo aValueId [] $ preludeFailed $ instType ty]+ else map (aValueEquation ty) cis++aValueEquation :: Type -> ConstrInfo -> Equation PredType+aValueEquation ty (arity, cns, _, tys)+ | arity >= 0 = mkEquation NoSpanInfo aValueId [] $ predType <$>+ foldl (Apply NoSpanInfo)+ (Constructor NoSpanInfo constrType cns)+ (map mkAValue tys')+ | otherwise = internalError "Derive.aValueEquation: negative arity"+ where+ constrType = foldr TypeArrow (instType ty) tys'+ mkAValue argTy = Variable NoSpanInfo argTy qAValueId+ tys' = map instType tys+ -- Ordering: deriveOrdMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType]@@ -194,11 +262,13 @@ -> DVM (Decl PredType) deriveSuccOrPred f ty cis1 cis2 ps = do pty <- getInstMethodType ps qEnumId ty f- FunctionDecl NoSpanInfo pty f <$> if null eqs- then do- v <- freshArgument $ instType ty- return [failedEquation f ty v]- else return eqs+ FunctionDecl NoSpanInfo pty f <$>+ if null eqs+ then do+ v <- freshArgument $ instType ty+ return [mkEquation NoSpanInfo f [uncurry (VariablePattern NoSpanInfo) v] $+ preludeFailed $ instType ty]+ else return eqs where eqs = zipWith (succOrPredEquation f ty) cis1 cis2 succOrPredEquation :: Ident -> Type -> ConstrInfo -> ConstrInfo@@ -208,11 +278,6 @@ Constructor NoSpanInfo pty c2 where pty = predType $ instType ty -failedEquation :: Ident -> Type -> (PredType, Ident) -> Equation PredType-failedEquation f ty v =- mkEquation NoSpanInfo f [uncurry (VariablePattern NoSpanInfo) v] $- preludeFailed $ instType ty- deriveToEnum :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType) deriveToEnum ty cis ps = do pty <- getInstMethodType ps qEnumId ty toEnumId@@ -253,7 +318,7 @@ -> DVM (Decl PredType) deriveEnumFromThen ty (_, c1, _, _) (_, c2, _, _) ps = do pty <- getInstMethodType ps qEnumId ty enumFromId- vs <- mapM (freshArgument . instType) $ replicate 2 ty+ vs <- replicateM 2 ((freshArgument . instType) ty) let [v1, v2] = vs return $ funDecl NoSpanInfo pty enumFromThenId (map (uncurry (VariablePattern NoSpanInfo)) vs) $@@ -262,7 +327,7 @@ enumFromThenExpr :: (PredType, Ident) -> (PredType, Ident) -> QualIdent -> QualIdent -> Expression PredType enumFromThenExpr v1 v2 c1 c2 =- prelEnumFromThenTo (uncurry mkVar v1) (uncurry mkVar v2) $ boundedExpr+ prelEnumFromThenTo (uncurry mkVar v1) (uncurry mkVar v2) boundedExpr where boundedExpr = IfThenElse NoSpanInfo (prelLeq (prelFromEnum $ uncurry mkVar v1)@@ -299,7 +364,7 @@ deriveReadsPrec :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType) deriveReadsPrec ty cis ps = do- pty <- getInstMethodType ps qReadId ty $ readsPrecId+ pty <- getInstMethodType ps qReadId ty readsPrecId d <- freshArgument intType r <- freshArgument stringType let pats = map (uncurry (VariablePattern NoSpanInfo)) [d, r]@@ -310,7 +375,7 @@ -> Expression PredType -> DVM (Expression PredType) deriveReadsPrecExpr ty cis d r = do es <- mapM (deriveReadsPrecReadParenExpr ty d) cis- return $ foldr1 prelAppend $ map (flip (Apply NoSpanInfo) r) $ es+ return $ foldr1 prelAppend $ map (flip (Apply NoSpanInfo) r) es deriveReadsPrecReadParenExpr :: Type -> Expression PredType -> ConstrInfo -> DVM (Expression PredType)@@ -334,7 +399,7 @@ deriveReadsPrecLambdaExpr ty (_, c, ls, tys) p = do r <- freshArgument stringType (stmts, vs, s) <- deriveReadsPrecStmts (unqualify c) (p + 1) r ls tys- let pty = predType $ foldr TypeArrow (instType ty) $ map instType tys+ let pty = predType $ foldr (TypeArrow . instType) (instType ty) tys e = Tuple NoSpanInfo [ apply (Constructor NoSpanInfo pty c) $ map (uncurry mkVar) vs , uncurry mkVar s@@ -401,7 +466,7 @@ deriveReadsPrecLexStmt :: String -> (PredType, Ident) -> DVM ((PredType, Ident), Statement PredType) deriveReadsPrecLexStmt str r = do- s <- freshArgument $ stringType+ s <- freshArgument stringType let pat = TuplePattern NoSpanInfo [ LiteralPattern NoSpanInfo predStringType $ String str , uncurry (VariablePattern NoSpanInfo) s@@ -427,7 +492,7 @@ deriveShowsPrec :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType) deriveShowsPrec ty cis ps = do- pty <- getInstMethodType ps qShowId ty $ showsPrecId+ pty <- getInstMethodType ps qShowId ty showsPrecId eqs <- mapM (deriveShowsPrecEquation ty) cis return $ FunctionDecl NoSpanInfo pty showsPrecId eqs @@ -541,7 +606,7 @@ instMethodType vEnv ps cls ty f = PredType (ps `Set.union` ps'') ty'' where PredType ps' ty' = case qualLookupValue (qualifyLike cls f) vEnv of [Value _ _ _ (ForAll _ pty)] -> pty- _ -> internalError $ "Derive.instMethodType"+ _ -> internalError "Derive.instMethodType" PredType ps'' ty'' = instanceType ty $ PredType (Set.deleteMin ps') ty' -- -----------------------------------------------------------------------------@@ -577,6 +642,12 @@ where ty = typeOf e1 pty = predType $ foldr1 TypeArrow [ty, ty, boolType] +prelDataEq :: Expression PredType -> Expression PredType -> Expression PredType+prelDataEq e1 e2 = foldl1 (Apply NoSpanInfo)+ [Variable NoSpanInfo pty qDataEqId, e1, e2]+ where ty = typeOf e1+ pty = predType $ foldr1 TypeArrow [ty, ty, boolType]+ prelLeq :: Expression PredType -> Expression PredType -> Expression PredType prelLeq e1 e2 = foldl1 (Apply NoSpanInfo) [Variable NoSpanInfo pty qLeqOpId, e1, e2]@@ -626,7 +697,7 @@ ] preludeLex :: Expression PredType -> Expression PredType-preludeLex e = Apply NoSpanInfo (Variable NoSpanInfo pty qLexId) e+preludeLex = Apply NoSpanInfo (Variable NoSpanInfo pty qLexId) where pty = predType $ TypeArrow stringType $ listType $ tupleType [stringType, stringType]
src/Transformations/Desugar.hs view
@@ -96,8 +96,8 @@ desugar :: [KnownExtension] -> ValueEnv -> TCEnv -> Module PredType -> (Module PredType, ValueEnv)-desugar xs vEnv tcEnv (Module spi ps m es is ds)- = (Module spi ps m es is ds', valueEnv s')+desugar xs vEnv tcEnv (Module spi li ps m es is ds)+ = (Module spi li ps m es is ds', valueEnv s') where (ds', s') = S.runState (desugarModuleDecls ds) (DesugarState m xs tcEnv vEnv 1) @@ -156,23 +156,54 @@ desugarModuleDecls :: [Decl PredType] -> DsM [Decl PredType] desugarModuleDecls ds = do- ds' <- concatMapM dsRecordDecl ds- ds'' <- mapM dsClassAndInstanceDecl ds'- ds''' <- dsDeclGroup ds''- return $ filter (not . liftM2 (||) isValueDecl isTypeSig) ds'' ++ ds'''+ ds' <- concatMapM dsRecordDecl ds+ ds'' <- concatMapM dsTypeDecl ds'+ ds''' <- mapM dsClassAndInstanceDecl ds''+ ds'''' <- dsDeclGroup ds'''+ return $ filter (not . liftM2 (||) isValueDecl isTypeSig) ds''' ++ ds'''' -- -----------------------------------------------------------------------------+-- Desugaring of type declarations+-- -----------------------------------------------------------------------------++dsTypeDecl :: Decl PredType -> DsM [Decl PredType]+dsTypeDecl (DataDecl si tc tvs cs clss) = do+ cs' <- mapM dsConstrDecl cs+ return $ [DataDecl si tc tvs cs' clss]+dsTypeDecl (NewtypeDecl si tc tvs nc clss) = do+ nc' <- dsNewConstrDecl nc+ return $ [NewtypeDecl si tc tvs nc' clss]+dsTypeDecl (TypeDecl _ _ _ _) = return []+dsTypeDecl d = return [d]++dsConstrDecl :: ConstrDecl -> DsM ConstrDecl+dsConstrDecl (ConstrDecl si c tys) = ConstrDecl si c <$> mapM dsTypeExpr tys+dsConstrDecl (ConOpDecl si ty1 op ty2) =+ ConstrDecl si op <$> mapM dsTypeExpr [ty1, ty2]+dsConstrDecl cd = internalError $ "Desugar.dsConstrDecl: " ++ show cd++dsNewConstrDecl :: NewConstrDecl -> DsM NewConstrDecl+dsNewConstrDecl (NewConstrDecl si c ty) = NewConstrDecl si c <$> dsTypeExpr ty+dsNewConstrDecl nc = internalError $ "Desugar.dsNewConstrDecl: " ++ show nc++-- ----------------------------------------------------------------------------- -- Desugaring of class and instance declarations -- ----------------------------------------------------------------------------- dsClassAndInstanceDecl :: Decl PredType -> DsM (Decl PredType)-dsClassAndInstanceDecl (ClassDecl p cx cls tv ds) =- ClassDecl p cx cls tv . (tds ++) <$> dsDeclGroup vds+dsClassAndInstanceDecl (ClassDecl p li cx cls tv ds) = do+ tds' <- mapM dsTypeSig tds+ vds' <- dsDeclGroup vds+ return $ ClassDecl p li cx cls tv $ tds' ++ vds' where (tds, vds) = partition isTypeSig ds-dsClassAndInstanceDecl (InstanceDecl p cx cls ty ds) =- InstanceDecl p cx cls ty <$> dsDeclGroup ds+dsClassAndInstanceDecl (InstanceDecl p li cx cls ty ds) =+ InstanceDecl p li cx cls ty <$> dsDeclGroup ds dsClassAndInstanceDecl d = return d +dsTypeSig :: Decl PredType -> DsM (Decl PredType)+dsTypeSig (TypeSig s fs qty) = TypeSig s fs <$> dsQualTypeExpr qty+dsTypeSig d = internalError $ "Desugar.dsTypeSig: " ++ show d+ -- ----------------------------------------------------------------------------- -- Desugaring of type declarations: records -- -----------------------------------------------------------------------------@@ -306,9 +337,9 @@ expandRhs :: Expression PredType -> (Expression PredType -> Expression PredType) -> Rhs PredType -> DsM (Expression PredType)-expandRhs _ f (SimpleRhs _ e ds) = return $ Let NoSpanInfo ds (f e)-expandRhs e0 f (GuardedRhs _ es ds) = (Let NoSpanInfo ds . f)- <$> expandGuards e0 es+expandRhs _ f (SimpleRhs _ _ e ds) = return $ mkLet ds (f e)+expandRhs e0 f (GuardedRhs _ _ es ds) = mkLet ds . f+ <$> expandGuards e0 es expandGuards :: Expression PredType -> [CondExpr PredType] -> DsM (Expression PredType)@@ -325,8 +356,8 @@ -- Add additional declarations to a right-hand side addDecls :: [Decl PredType] -> Rhs PredType -> Rhs PredType-addDecls ds (SimpleRhs p e ds') = SimpleRhs p e (ds ++ ds')-addDecls ds (GuardedRhs spi es ds') = GuardedRhs spi es (ds ++ ds')+addDecls ds (SimpleRhs p li e ds') = SimpleRhs p li e (ds ++ ds')+addDecls ds (GuardedRhs spi li es ds') = GuardedRhs spi li es (ds ++ ds') -- ----------------------------------------------------------------------------- -- Desugaring of non-linear patterns@@ -673,7 +704,7 @@ dsExpr p (applyConstr pty c tys es) dsExpr p (RecordUpdate _ e fs) = do alts <- constructors tc >>= concatMapM updateAlt- dsExpr p $ Case NoSpanInfo Flex e (map (uncurry (caseAlt p)) alts)+ dsExpr p $ mkCase Flex e (map (uncurry (caseAlt p)) alts) where ty = typeOf e pty = predType ty tc = rootOfType (arrowBase ty)@@ -733,19 +764,19 @@ where TypeArrow ty1 (TypeArrow ty2 ty3) = typeOf (infixOp op) dsExpr p expr@(Lambda _ ts e) = do (pty, f) <- freshVar "_#lambda" expr- dsExpr p $ Let NoSpanInfo [funDecl p pty f ts e] $ mkVar pty f-dsExpr p (Let _ ds e) = do+ dsExpr p $ mkLet [funDecl p pty f ts e] $ mkVar pty f+dsExpr p (Let _ _ ds e) = do ds' <- dsDeclGroup ds e' <- dsExpr p e- return (if null ds' then e' else Let NoSpanInfo ds' e')-dsExpr p (Do _ sts e) = dsDo sts e >>= dsExpr p+ return $ mkLet ds' e'+dsExpr p (Do _ _ sts e) = dsDo sts e >>= dsExpr p dsExpr p (IfThenElse _ e1 e2 e3) = do e1' <- dsExpr p e1 e2' <- dsExpr p e2 e3' <- dsExpr p e3- return $ Case NoSpanInfo Rigid e1'+ return $ mkCase Rigid e1' [caseAlt p truePat e2', caseAlt p falsePat e3']-dsExpr p (Case _ ct e alts) = dsCase p ct e alts+dsExpr p (Case _ _ ct e alts) = dsCase p ct e alts -- We ignore the context in the type signature of a typed expression, since -- there should be no possibility to provide an non-empty context without@@ -760,7 +791,8 @@ dsTypeExpr ty = do m <- getModuleIdent tcEnv <- getTyConsEnv- return $ fromType (typeVariables ty) (expandType m tcEnv (toType [] ty))+ let tvs = typeVariables ty+ return $ fromType tvs $ expandType m tcEnv $ toType tvs ty -- ----------------------------------------------------------------------------- -- Desugaring of case expressions@@ -784,12 +816,12 @@ v <- freshVar "_#case" e alts' <- mapM dsAltLhs alts alts'' <- mapM (expandAlt v ct) (init (tails alts')) >>= mapM dsAltRhs- return (mkCase m v e' alts'')+ return (mkMyCase m v e' alts'') where- mkCase m (pty, v) e' bs- | v `elem` qfv m bs = Let NoSpanInfo [varDecl p pty v e']- (Case NoSpanInfo ct (mkVar pty v) bs)- | otherwise = Case NoSpanInfo ct e' bs+ mkMyCase m (pty, v) e' bs+ | v `elem` qfv m bs = mkLet [varDecl p pty v e']+ (mkCase ct (mkVar pty v) bs)+ | otherwise = mkCase ct e' bs dsAltLhs :: Alt PredType -> DsM (Alt PredType) dsAltLhs (Alt p t rhs) = do@@ -805,7 +837,7 @@ expandAlt v ct (Alt p t rhs : alts) = caseAlt p t <$> expandRhs e0 id rhs where e0 | ct == Flex || null compAlts = prelFailed (typeOf rhs)- | otherwise = Case NoSpanInfo ct (uncurry mkVar v) compAlts+ | otherwise = mkCase ct (uncurry mkVar v) compAlts compAlts = filter (isCompatible t . altPattern) alts altPattern (Alt _ t1 _) = t1 @@ -839,18 +871,56 @@ return $ apply (prelBind_ (typeOf e1) (typeOf e')) [e1, e'] dsStmt (StmtBind _ t e1) e' = do v <- freshVar "_#var" t- let func = Lambda NoSpanInfo [uncurry (VariablePattern NoSpanInfo) v] $- Case NoSpanInfo Rigid (uncurry mkVar v)- [ caseAlt NoSpanInfo t e'- , caseAlt NoSpanInfo (uncurry (VariablePattern NoSpanInfo) v)- (failedPatternMatch $ typeOf e')- ]+ failable <- checkFailableBind t+ let func = mkLambda [uncurry (VariablePattern NoSpanInfo) v] $+ mkCase Rigid (uncurry mkVar v) $+ caseAlt NoSpanInfo t e' :+ if failable+ then [caseAlt NoSpanInfo+ (uncurry (VariablePattern NoSpanInfo) v)+ (failedPatternMatch $ typeOf e')]+ else [] return $ apply (prelBind (typeOf e1) (typeOf t) (typeOf e')) [e1, func] where failedPatternMatch ty = apply (prelFail ty) [Literal NoSpanInfo predStringType $ String "Pattern match failed!"]-dsStmt (StmtDecl _ ds) e' = return $ Let NoSpanInfo ds e'+dsStmt (StmtDecl _ _ ds) e' = return $ mkLet ds e' +checkFailableBind :: Pattern a -> DsM Bool+checkFailableBind (ConstructorPattern _ _ idt ps ) = do+ tcEnv <- getTyConsEnv+ case qualLookupTypeInfo idt tcEnv of+ [RenamingType _ _ _ ] -> or <$> mapM checkFailableBind ps -- or [] == False+ [DataType _ _ cs]+ | length cs == 1 -> or <$> mapM checkFailableBind ps+ | otherwise -> return True+ _ -> return True+checkFailableBind (InfixPattern _ _ p1 idt p2) = do+ tcEnv <- getTyConsEnv+ case qualLookupTypeInfo idt tcEnv of+ [RenamingType _ _ _ ] -> (||) <$> checkFailableBind p1+ <*> checkFailableBind p2+ [DataType _ _ cs]+ | length cs == 1 -> (||) <$> checkFailableBind p1+ <*> checkFailableBind p2+ | otherwise -> return True+ _ -> return True+checkFailableBind (RecordPattern _ _ idt fs ) = do+ tcEnv <- getTyConsEnv+ case qualLookupTypeInfo idt tcEnv of+ [RenamingType _ _ _ ] -> or <$> mapM (checkFailableBind . fieldContent) fs+ [DataType _ _ cs]+ | length cs == 1 -> or <$> mapM (checkFailableBind . fieldContent) fs+ | otherwise -> return True+ _ -> return True+ where fieldContent (Field _ _ c) = c+checkFailableBind (TuplePattern _ ps ) =+ or <$> mapM checkFailableBind ps+checkFailableBind (AsPattern _ _ p ) = checkFailableBind p+checkFailableBind (ParenPattern _ p ) = checkFailableBind p+checkFailableBind (LazyPattern _ _ ) = return False+checkFailableBind (VariablePattern _ _ _ ) = return False+checkFailableBind _ = return True -- ----------------------------------------------------------------------------- -- Desugaring of List Comprehensions -- -----------------------------------------------------------------------------@@ -891,7 +961,7 @@ -> DsM (Expression PredType) dsQual p (StmtExpr _ b) e = dsExpr p (IfThenElse NoSpanInfo b e (List NoSpanInfo (predType $ typeOf e) []))-dsQual p (StmtDecl _ ds) e = dsExpr p (Let NoSpanInfo ds e)+dsQual p (StmtDecl _ _ ds) e = dsExpr p (mkLet ds e) dsQual p (StmtBind _ t l) e | isVariablePattern t = dsExpr p (qualExpr t e l) | otherwise = do@@ -901,13 +971,13 @@ [foldFunct v l' e, List NoSpanInfo (predType $ typeOf e) [], l]) where qualExpr v (ListCompr NoSpanInfo e1 []) l1- = apply (prelMap (typeOf v) (typeOf e1)) [Lambda NoSpanInfo [v] e1, l1]+ = apply (prelMap (typeOf v) (typeOf e1)) [mkLambda [v] e1, l1] qualExpr v e1 l1 = apply (prelConcatMap (typeOf v) (elemType $ typeOf e1))- [Lambda NoSpanInfo [v] e1, l1]+ [mkLambda [v] e1, l1] foldFunct v l1 e1- = Lambda NoSpanInfo (map (uncurry (VariablePattern NoSpanInfo)) [v, l1])- (Case NoSpanInfo Rigid (uncurry mkVar v)+ = mkLambda (map (uncurry (VariablePattern NoSpanInfo)) [v, l1])+ (mkCase Rigid (uncurry mkVar v) [ caseAlt p t (append e1 (uncurry mkVar l1)) , caseAlt p (uncurry (VariablePattern NoSpanInfo) v) (uncurry mkVar l1)])
src/Transformations/Dictionary.hs view
@@ -62,7 +62,6 @@ , classEnv :: ClassEnv , instEnv :: InstEnv , opPrecEnv :: OpPrecEnv- , augmentEnv :: AugmentEnv -- for augmenting nullary class methods , dictEnv :: DictEnv -- for dictionary insertion , specEnv :: SpecEnv -- for dictionary specialization , nextId :: Integer@@ -70,15 +69,15 @@ type DTM = S.State DTState -insertDicts :: InterfaceEnv -> TCEnv -> ValueEnv -> ClassEnv -> InstEnv- -> OpPrecEnv -> Module PredType+insertDicts :: Bool -> InterfaceEnv -> TCEnv -> ValueEnv -> ClassEnv+ -> InstEnv -> OpPrecEnv -> Module PredType -> (Module Type, InterfaceEnv, TCEnv, ValueEnv, OpPrecEnv)-insertDicts intfEnv tcEnv vEnv clsEnv inEnv pEnv mdl@(Module _ _ m _ _ _) =+insertDicts inlDi intfEnv tcEnv vEnv clsEnv inEnv pEnv mdl@(Module _ _ _ m _ _ _) = (mdl', intfEnv', tcEnv', vEnv', pEnv') where initState =- DTState m tcEnv vEnv clsEnv inEnv pEnv emptyAugEnv emptyDictEnv emptySpEnv 1+ DTState m tcEnv vEnv clsEnv inEnv pEnv emptyDictEnv emptySpEnv 1 (mdl', tcEnv', vEnv', pEnv') =- runDTM (augment mdl >>= dictTrans >>= specialize >>= cleanup) initState+ runDTM (dictTrans mdl >>= (if inlDi then specialize else return) >>= cleanup) initState intfEnv' = dictTransInterfaces vEnv' clsEnv intfEnv runDTM :: DTM a -> DTState -> (a, TCEnv, ValueEnv, OpPrecEnv)@@ -122,12 +121,6 @@ modifyPrecEnv :: (OpPrecEnv -> OpPrecEnv) -> DTM () modifyPrecEnv f = S.modify $ \s -> s { opPrecEnv = f $ opPrecEnv s } -getAugEnv :: DTM AugmentEnv-getAugEnv = S.gets augmentEnv--setAugEnv :: AugmentEnv -> DTM ()-setAugEnv augEnv = S.modify $ \s -> s { augmentEnv = augEnv }- getDictEnv :: DTM DictEnv getDictEnv = S.gets dictEnv @@ -154,167 +147,6 @@ return nid -- -------------------------------------------------------------------------------- Augmenting nullary class methods--- --------------------------------------------------------------------------------- To prevent unwanted sharing of non-determinism for nullary class methods--- we augment them with an additional unit argument.--type AugmentEnv = [QualIdent]--emptyAugEnv :: AugmentEnv-emptyAugEnv = []--initAugEnv :: ValueEnv -> AugmentEnv-initAugEnv = foldr (bindValue . snd) emptyAugEnv . allBindings- where bindValue (Value f True _ (ForAll _ (PredType _ ty)))- | arrowArity ty == 0 = (f :)- bindValue _ = id--isAugmented :: AugmentEnv -> QualIdent -> Bool-isAugmented = flip elem--augmentValues :: ValueEnv -> ValueEnv-augmentValues = fmap augmentValueInfo--augmentValueInfo :: ValueInfo -> ValueInfo-augmentValueInfo (Value f True a (ForAll n (PredType ps ty)))- | arrowArity ty == 0 = Value f True a $ ForAll n $ PredType ps ty'- where ty' = augmentType ty-augmentValueInfo vi = vi--augmentTypes :: TCEnv -> TCEnv-augmentTypes = fmap augmentTypeInfo--augmentTypeInfo :: TypeInfo -> TypeInfo-augmentTypeInfo (TypeClass cls k ms) =- TypeClass cls k $ map augmentClassMethod ms-augmentTypeInfo ti = ti--augmentClassMethod :: ClassMethod -> ClassMethod-augmentClassMethod mthd@(ClassMethod f a (PredType ps ty))- | arrowArity ty == 0 =- ClassMethod f (Just $ fromMaybe 0 a + 1) $ PredType ps $ augmentType ty- | otherwise = mthd--augmentInstances :: AugmentEnv -> InstEnv -> InstEnv-augmentInstances = Map.mapWithKey . augmentInstInfo--augmentInstInfo :: AugmentEnv -> InstIdent -> InstInfo -> InstInfo-augmentInstInfo augEnv (cls, _) (m, ps, is) =- (m, ps, map (augmentInstImpl augEnv cls) is)--augmentInstImpl :: AugmentEnv -> QualIdent -> (Ident, Int) -> (Ident, Int)-augmentInstImpl augEnv cls (f, a)- | isAugmented augEnv (qualifyLike cls f) = (f, a + 1)- | otherwise = (f, a)--class Augment a where- augment :: a PredType -> DTM (a PredType)--instance Augment Module where- augment (Module spi ps m es is ds) = do- augEnv <- initAugEnv <$> getValueEnv- setAugEnv augEnv- modifyValueEnv $ augmentValues- modifyTyConsEnv $ augmentTypes- modifyInstEnv $ augmentInstances augEnv- Module spi ps m es is <$> mapM (augmentDecl Nothing) ds---- The first parameter of the functions 'augmentDecl', 'augmentEquation' and--- 'augmentLhs' determines whether we have to unrename the function identifiers--- before checking if the function has to augmented or not. Furthermore, it--- specifies the module unqualified identifiers have to be qualified with.--- The unrenaming is necessary for both class and instance declarations as all--- identifiers within these have been renamed during the syntax check, while the--- qualifying is needed for function declarations within instance declarations--- as the implemented class methods can originate from another module. If not--- qualified properly, the lookup in the augmentation environment would fail.---- Since type signatures remain only in class declarations due to desugaring,--- we can always perform the unrenaming and it is safe to assume that all other--- functions mentioned in a type signature have to be augmented as well if the--- first one is affected.--augmentDecl :: Maybe ModuleIdent -> Decl PredType -> DTM (Decl PredType)-augmentDecl _ d@(TypeSig p fs qty) = do- m <- getModuleIdent- augEnv <- getAugEnv- return $ if isAugmented augEnv (qualifyWith m $ unRenameIdent $ head fs)- then TypeSig p fs $ augmentQualTypeExpr qty- else d-augmentDecl mm (FunctionDecl p pty f eqs) = do- eqs' <- mapM (augmentEquation mm) eqs- m <- maybe getModuleIdent return mm- augEnv <- getAugEnv- if isAugmented augEnv (qualifyWith m $ unRenameIdentIf (isJust mm) f)- then return $ FunctionDecl p (augmentPredType pty) f eqs'- else return $ FunctionDecl p pty f eqs'-augmentDecl _ (PatternDecl p t rhs) = PatternDecl p t <$> augment rhs-augmentDecl _ (ClassDecl p cx cls tv ds) = do- m <- getModuleIdent- ClassDecl p cx cls tv <$> mapM (augmentDecl $ Just m) ds-augmentDecl _ (InstanceDecl p cx cls ty ds) =- InstanceDecl p cx cls ty <$> mapM (augmentDecl $ qidModule cls) ds-augmentDecl _ d = return d--augmentEquation :: Maybe ModuleIdent -> Equation PredType- -> DTM (Equation PredType)-augmentEquation mm (Equation p lhs rhs) =- Equation p <$> augmentLhs mm lhs <*> augment rhs--augmentLhs :: Maybe ModuleIdent -> Lhs PredType -> DTM (Lhs PredType)-augmentLhs mm lhs@(FunLhs spi f ts) = do- m <- maybe getModuleIdent return mm- augEnv <- getAugEnv- if isAugmented augEnv (qualifyWith m $ unRenameIdentIf (isJust mm) f)- then return $ FunLhs spi f- $ ConstructorPattern NoSpanInfo predUnitType qUnitId [] : ts- else return lhs-augmentLhs _ lhs =- internalError $ "Dictionary.augmentLhs" ++ show lhs--instance Augment Rhs where- augment (SimpleRhs p e []) = simpleRhs p <$> augment e- augment rhs =- internalError $ "Dictionary.augment: " ++ show rhs--instance Augment Expression where- augment l@(Literal _ _ _) = return l- augment v@(Variable _ pty v') = do- augEnv <- getAugEnv- return $ if isAugmented augEnv v'- then apply (Variable NoSpanInfo (augmentPredType pty) v')- [Constructor NoSpanInfo predUnitType qUnitId]- else v- augment c@(Constructor _ _ _) = return c- augment (Typed spi e qty) = flip (Typed spi) qty <$> augment e- augment (Apply spi e1 e2) = Apply spi <$> augment e1 <*> augment e2- augment (Lambda spi ts e) = Lambda spi ts <$> augment e- augment (Let spi ds e) =- Let spi <$> mapM (augmentDecl Nothing) ds <*> augment e- augment (Case spi ct e as) =- Case spi ct <$> augment e <*> mapM augment as- augment e =- internalError $ "Dictionary.augment: " ++ show e--instance Augment Alt where- augment (Alt p t rhs) = Alt p t <$> augment rhs--augmentPredType :: PredType -> PredType-augmentPredType (PredType ps ty) = PredType ps $ augmentType ty--augmentType :: Type -> Type-augmentType = TypeArrow unitType--augmentQualTypeExpr :: QualTypeExpr -> QualTypeExpr-augmentQualTypeExpr (QualTypeExpr spi cx ty) =- QualTypeExpr spi cx $ augmentTypeExpr ty--augmentTypeExpr :: TypeExpr -> TypeExpr-augmentTypeExpr = ArrowType NoSpanInfo $ ConstructorType NoSpanInfo qUnitId---- ----------------------------------------------------------------------------- -- Lifting class and instance declarations -- ----------------------------------------------------------------------------- @@ -324,10 +156,10 @@ liftDecls :: Decl PredType -> DTM [Decl PredType] liftDecls (DefaultDecl _ _) = return []-liftDecls (ClassDecl _ _ cls tv ds) = do+liftDecls (ClassDecl _ _ _ cls tv ds) = do m <- getModuleIdent liftClassDecls (qualifyWith m cls) tv ds-liftDecls (InstanceDecl _ cx cls ty ds) = do+liftDecls (InstanceDecl _ _ cx cls ty ds) = do clsEnv <- getClassEnv let PredType ps ty' = toPredType [] $ QualTypeExpr NoSpanInfo cx ty ps' = minPredSet clsEnv ps@@ -390,7 +222,7 @@ createInstDictDecl :: PredSet -> QualIdent -> Type -> DTM (Decl PredType) createInstDictDecl ps cls ty = do pty <- PredType ps . arrowBase <$> getInstDictConstrType cls ty- funDecl NoSpanInfo pty (instFunId cls ty) [] <$> createInstDictExpr cls ty+ funDecl NoSpanInfo pty (instFunId cls ty) [ConstructorPattern NoSpanInfo predUnitType qUnitId []] <$> createInstDictExpr cls ty createInstDictExpr :: QualIdent -> Type -> DTM (Expression PredType) createInstDictExpr cls ty = do@@ -414,13 +246,7 @@ defaultClassMethodDecl :: QualIdent -> Ident -> DTM (Decl PredType) defaultClassMethodDecl cls f = do pty@(PredType _ ty) <- getClassMethodType cls f- augEnv <- getAugEnv- let augmented = isAugmented augEnv (qualifyLike cls f)- pats = if augmented- then [ConstructorPattern NoSpanInfo predUnitType qUnitId []]- else []- ty' = if augmented then arrowBase ty else ty- return $ funDecl NoSpanInfo pty f pats $ preludeError (instType ty') $+ return $ funDecl NoSpanInfo pty f [] $ preludeError (instType ty) $ "No instance or default method for class operation " ++ escName f getClassMethodType :: QualIdent -> Ident -> DTM PredType@@ -482,7 +308,7 @@ -- class dictionary from the provided class dictionary. createStubs :: Decl PredType -> DTM [Decl Type]-createStubs (ClassDecl _ _ cls _ _) = do+createStubs (ClassDecl _ _ _ cls _ _) = do m <- getModuleIdent vEnv <- getValueEnv clsEnv <- getClassEnv@@ -498,52 +324,42 @@ splitAt (length sclss) $ map (TypeArrow dictTy) superDictAndMethodTys superDictVs <- mapM (freshVar "_#super" . instType) superDictTys methodVs <- mapM (freshVar "_#meth" . instType) methodTys- methodDictTyss <- zipWithM (computeMethodDictTypes ocls) fs methodTys- methodDictVss <- mapM (mapM $ freshVar "_#dict" . instType) methodDictTyss let patternVs = superDictVs ++ methodVs pattern = createDictPattern (instType dictTy) ocls patternVs superStubs = zipWith3 (createSuperDictStubDecl pattern ocls) superStubTys sclss superDictVs- methodStubs = zipWith4 (createMethodStubDecl pattern)- methodStubTys fs methodVs methodDictVss+ methodStubs = zipWith3 (createMethodStubDecl pattern)+ methodStubTys fs methodVs return $ superStubs ++ methodStubs createStubs _ = return [] --- Computes the additional dictionary arguments of a transformed method type--- which correspond to the constraints of the original class method's type.--computeMethodDictTypes :: QualIdent -> Ident -> Type -> DTM [Type]-computeMethodDictTypes cls f ty = do- PredType _ ty' <- getClassMethodType cls f- return $ take (length tys - arrowArity ty') tys- where tys = arrowArgs ty--createDictPattern :: a -> QualIdent -> [(a, Ident)] -> Pattern a+createDictPattern :: Type -> QualIdent -> [(Type, Ident)] -> Pattern Type createDictPattern a cls = constrPattern a (qDictConstrId cls) -createSuperDictStubDecl :: Pattern a -> QualIdent -> a -> QualIdent- -> (a, Ident) -> Decl a+createSuperDictStubDecl :: Pattern Type -> QualIdent -> Type -> QualIdent+ -> (Type, Ident) -> Decl Type createSuperDictStubDecl t cls a super v =- createStubDecl t a (superDictStubId cls super) v []+ createStubDecl t a (superDictStubId cls super) v -createMethodStubDecl :: Pattern a -> a -> Ident -> (a, Ident) -> [(a, Ident)]- -> Decl a+createMethodStubDecl :: Pattern Type -> Type -> Ident -> (Type, Ident) -> Decl Type createMethodStubDecl = createStubDecl -createStubDecl :: Pattern a -> a -> Ident -> (a, Ident) -> [(a, Ident)]- -> Decl a-createStubDecl t a f v us =- FunctionDecl NoSpanInfo a f [createStubEquation t f v us]+createStubDecl :: Pattern Type -> Type -> Ident -> (Type, Ident) -> Decl Type+createStubDecl t a f v =+ FunctionDecl NoSpanInfo a f [createStubEquation t f v] -createStubEquation :: Pattern a -> Ident -> (a, Ident) -> [(a, Ident)]- -> Equation a-createStubEquation t f v us =- mkEquation NoSpanInfo f (t : map (uncurry (VariablePattern NoSpanInfo)) us) $- apply (uncurry mkVar v) (map (uncurry mkVar) us)+createStubEquation :: Pattern Type -> Ident -> (Type, Ident) -> Equation Type+createStubEquation t f v = + mkEquation NoSpanInfo f [VariablePattern NoSpanInfo (TypeArrow unitType (typeOf t)) (mkIdent "_#temp")] $+ mkLet [FunctionDecl NoSpanInfo (TypeArrow (typeOf t) (fst v)) (mkIdent "_#lambda")+ [mkEquation NoSpanInfo (mkIdent "_#lambda") [t] $ uncurry mkVar v]]+ (apply (Variable NoSpanInfo (TypeArrow (typeOf t) (fst v)) (qualify $ mkIdent "_#lambda"))+ [apply (Variable NoSpanInfo (TypeArrow unitType (typeOf t)) (qualify $ mkIdent "_#temp"))+ [Constructor NoSpanInfo unitType qUnitId]]) superDictStubType :: QualIdent -> QualIdent -> Type -> Type superDictStubType cls super ty =- TypeArrow (dictType $ Pred cls ty) (dictType $ Pred super ty)+ TypeArrow (rtDictType $ Pred cls ty) (rtDictType $ Pred super ty) -- ----------------------------------------------------------------------------- -- Entering new bindings into the environments@@ -557,7 +373,7 @@ bindDictType m clsEnv (TypeClass cls k ms) = bindEntity m tc ti where ti = DataType tc (KindArrow k KindStar) [c] tc = qDictTypeId cls- c = DataConstr (dictConstrId cls) (map dictType (Set.toAscList ps) ++ tys)+ c = DataConstr (dictConstrId cls) (map rtDictType (Set.toAscList ps) ++ tys) sclss = superClasses cls clsEnv ps = Set.fromList [Pred scls (TypeVariable 0) | scls <- sclss] tys = map (generalizeMethodType . transformMethodPredType . methodType) ms@@ -603,7 +419,7 @@ bindSuperStubs m = flip . foldr . bindSuperStub m bindSuperStub :: ModuleIdent -> QualIdent -> QualIdent -> ValueEnv -> ValueEnv-bindSuperStub m cls scls = bindEntity m f $ Value f False 1 $ polyType ty+bindSuperStub m cls scls = bindEntity m f $ Value f Nothing 1 $ polyType ty where f = qSuperDictStubId cls scls ty = superDictStubType cls scls (TypeVariable 0) @@ -622,7 +438,7 @@ bindInstDict :: ModuleIdent -> QualIdent -> Type -> ModuleIdent -> PredSet -> ValueEnv -> ValueEnv bindInstDict m cls ty m' ps =- bindMethod m (qInstFunId m' cls ty) 0 $ PredType ps $ dictType $ Pred cls ty+ bindMethod m (qInstFunId m' cls ty) 1 $ PredType ps $ rtDictType $ Pred cls ty bindInstMethods :: ModuleIdent -> ClassEnv -> QualIdent -> Type -> ModuleIdent -> PredSet -> [(Ident, Int)] -> ValueEnv -> ValueEnv@@ -638,7 +454,7 @@ bindMethod :: ModuleIdent -> QualIdent -> Int -> PredType -> ValueEnv -> ValueEnv-bindMethod m f n pty = bindEntity m f $ Value f False n $ typeScheme pty+bindMethod m f n pty = bindEntity m f $ Value f Nothing n $ typeScheme pty -- The function 'bindEntity' introduces a binding for an entity into a top-level -- environment. Depending on whether the entity is defined in the current module@@ -696,8 +512,8 @@ dictTransValueInfo (NewtypeConstructor c l (ForAll n pty)) = NewtypeConstructor c l (ForAll n (predType (unpredType pty))) dictTransValueInfo (Value f cm a (ForAll n pty)) =- Value f False a' $ ForAll n $ predType ty- where a' = a + if cm then 1 else arrowArity ty - arrowArity (unpredType pty)+ Value f Nothing a' $ ForAll n $ predType ty+ where a' = a + if isJust cm then 1 else arrowArity ty - arrowArity (unpredType pty) ty = transformPredType pty dictTransValueInfo (Label l cs (ForAll n pty)) = Label l cs $ ForAll n $ predType $ unpredType pty@@ -711,11 +527,11 @@ addExports Nothing _ = internalError "Dictionary.addExports" dictExports :: Decl a -> DTM [Export]-dictExports (ClassDecl _ _ cls _ _) = do+dictExports (ClassDecl _ _ _ cls _ _) = do m <- getModuleIdent clsEnv <- getClassEnv return $ classExports m clsEnv cls-dictExports (InstanceDecl _ _ cls ty _) = do+dictExports (InstanceDecl _ _ _ cls ty _) = do m <- getModuleIdent clsEnv <- getClassEnv return $ instExports m clsEnv cls (toType [] ty)@@ -746,7 +562,7 @@ dictTrans :: a PredType -> DTM (a Type) instance DictTrans Module where- dictTrans (Module spi ps m es is ds) = do+ dictTrans (Module spi li ps m es is ds) = do liftedDs <- concatMapM liftDecls ds stubDs <- concatMapM createStubs ds tcEnv <- getTyConsEnv@@ -759,7 +575,7 @@ modifyValueEnv $ dictTransValues modifyTyConsEnv $ dictTransTypes dictEs <- addExports es <$> concatMapM dictExports ds- return $ Module spi ps m dictEs is $ transDs ++ stubDs+ return $ Module spi li ps m dictEs is $ transDs ++ stubDs -- We use and transform the type from the type constructor environment for -- transforming a constructor declaration as it contains the reduced and@@ -788,7 +604,7 @@ dictTrans $ FunctionDecl p pty v [Equation p (FunLhs NoSpanInfo v []) rhs] _ -> withLocalDictEnv $ PatternDecl p <$> dictTrans t <*> dictTrans rhs dictTrans d@(FreeDecl _ _) = return $ fmap unpredType d- dictTrans d@(ExternalDecl _ _) = return $ fmap unpredType d+ dictTrans d@(ExternalDecl _ _) = return $ fmap transformPredType d dictTrans d = internalError $ "Dictionary.dictTrans: " ++ show d @@ -812,8 +628,8 @@ internalError $ "Dictionary.dictTrans: " ++ show eq instance DictTrans Rhs where- dictTrans (SimpleRhs p e []) = simpleRhs p <$> dictTrans e- dictTrans rhs =+ dictTrans (SimpleRhs p _ e []) = simpleRhs p <$> dictTrans e+ dictTrans rhs = internalError $ "Dictionary.dictTrans: " ++ show rhs instance DictTrans Pattern where@@ -850,12 +666,12 @@ dictTrans (Lambda _ ts e) = withLocalValueEnv $ withLocalDictEnv $ do ts' <- mapM dictTrans ts modifyValueEnv $ bindPatterns ts'- Lambda NoSpanInfo ts' <$> dictTrans e- dictTrans (Let _ ds e) = withLocalValueEnv $ do+ mkLambda ts' <$> dictTrans e+ dictTrans (Let _ _ ds e) = withLocalValueEnv $ do modifyValueEnv $ bindDecls ds- Let NoSpanInfo <$> mapM dictTrans ds <*> dictTrans e- dictTrans (Case _ ct e as) =- Case NoSpanInfo ct <$> dictTrans e <*> mapM dictTrans as+ mkLet <$> mapM dictTrans ds <*> dictTrans e+ dictTrans (Case _ _ ct e as) =+ mkCase ct <$> dictTrans e <*> mapM dictTrans as dictTrans e = internalError $ "Dictionary.dictTrans: " ++ show e @@ -875,7 +691,7 @@ addDictArgs :: [Pred] -> [Pattern PredType] -> DTM [Pattern Type] addDictArgs pls ts = do- dictVars <- mapM (freshVar "_#dict" . dictType) pls+ dictVars <- mapM (freshVar "_#dict" . rtDictType) pls clsEnv <- getClassEnv modifyDictEnv $ (++) $ dicts clsEnv $ zip pls (map (uncurry mkVar) dictVars) (++) (map (uncurry (VariablePattern NoSpanInfo )) dictVars)@@ -911,7 +727,7 @@ instFunApp m pls p@(Pred cls ty) = apply (Variable NoSpanInfo ty' f) <$> mapM dictArg pls where f = qInstFunId m cls ty- ty' = foldr1 TypeArrow $ map dictType $ pls ++ [p]+ ty' = foldr1 TypeArrow $ map rtDictType $ pls ++ [p] instPredList :: Pred -> DTM (ModuleIdent, [Pred]) instPredList (Pred cls ty) = case unapplyType True ty of@@ -954,7 +770,7 @@ predListMatch [] ty = Just ty predListMatch (p:ps) ty = case ty of TypeForall _ ty' -> predListMatch (p : ps) ty'- TypeArrow ty1 ty2 | ty1 == dictType (instPred p) -> predListMatch ps ty2+ TypeArrow ty1 ty2 | ty1 == rtDictType (instPred p) -> predListMatch ps ty2 _ -> Nothing splits :: [a] -> [([a], [a])]@@ -986,11 +802,11 @@ specialize :: a Type -> DTM (a Type) instance Specialize Module where- specialize (Module spi ps m es is ds) = do+ specialize (Module spi li ps m es is ds) = do clsEnv <- getClassEnv inEnv <- getInstEnv setSpEnv $ initSpEnv clsEnv inEnv- Module spi ps m es is <$> mapM specialize ds+ Module spi li ps m es is <$> mapM specialize ds instance Specialize Decl where specialize (FunctionDecl p ty f eqs) =@@ -1002,8 +818,8 @@ specialize (Equation p lhs rhs) = Equation p lhs <$> specialize rhs instance Specialize Rhs where- specialize (SimpleRhs p e []) = simpleRhs p <$> specialize e- specialize rhs =+ specialize (SimpleRhs p _ e []) = simpleRhs p <$> specialize e+ specialize rhs = internalError $ "Dictionary.specialize: " ++ show rhs instance Specialize Expression where@@ -1029,14 +845,14 @@ specialize' (Lambda _ ts e) es = do e' <- specialize e return $ apply (Lambda NoSpanInfo ts e') es-specialize' (Let _ ds e) es = do+specialize' (Let _ _ ds e) es = do ds' <- mapM specialize ds e' <- specialize e- return $ apply (Let NoSpanInfo ds' e') es-specialize' (Case _ ct e as) es = do+ return $ apply (mkLet ds' e') es+specialize' (Case _ _ ct e as) es = do e' <- specialize e as' <- mapM specialize as- return $ apply (Case NoSpanInfo ct e' as') es+ return $ apply (mkCase ct e' as') es specialize' e _ = internalError $ "Dictionary.specialize': " ++ show e @@ -1055,12 +871,12 @@ -- transformation. cleanup :: Module a -> DTM (Module a)-cleanup (Module spi ps m es is ds) = do+cleanup (Module spi li ps m es is ds) = do cleanedEs <- traverse cleanupExportSpec es cleanedDs <- concatMapM cleanupInfixDecl ds cleanupTyConsEnv cleanupPrecEnv- return $ Module spi ps m cleanedEs is cleanedDs+ return $ Module spi li ps m cleanedEs is cleanedDs cleanupExportSpec :: ExportSpec -> DTM ExportSpec cleanupExportSpec (Exporting p es) = Exporting p <$> concatMapM cleanupExport es@@ -1229,6 +1045,9 @@ -- The function 'dictType' returns the type of the dictionary corresponding to -- a particular C-T instance. +rtDictType :: Pred -> Type+rtDictType = TypeArrow unitType . dictType+ dictType :: Pred -> Type dictType (Pred cls ty) = TypeApply (TypeConstructor $ qDictTypeId cls) ty @@ -1237,7 +1056,7 @@ transformPredType :: PredType -> Type transformPredType (PredType ps ty) =- foldr (TypeArrow . dictType) ty $ Set.toList ps+ foldr (TypeArrow . rtDictType) ty $ Set.toList ps -- The function 'transformMethodPredType' first deletes the implicit class -- constraint and then transforms the resulting predicated type as above.
src/Transformations/Lift.hs view
@@ -47,11 +47,11 @@ import Env.Value lift :: ValueEnv -> Module Type -> (Module Type, ValueEnv)-lift vEnv (Module spi ps m es is ds) = (lifted, valueEnv s')+lift vEnv (Module spi li ps m es is ds) = (lifted, valueEnv s') where (ds', s') = S.runState (mapM (absDecl "" []) ds) initState initState = LiftState m vEnv Map.empty- lifted = Module spi ps m es is $ concatMap liftFunDecl ds'+ lifted = Module spi li ps m es is $ concatMap liftFunDecl ds' -- ----------------------------------------------------------------------------- -- Abstraction@@ -113,8 +113,8 @@ absEquation _ _ = error "Lift.absEquation: no pattern match" absRhs :: String -> [Ident] -> Rhs Type -> LiftM (Rhs Type)-absRhs pre lvs (SimpleRhs p e _) = simpleRhs p <$> absExpr pre lvs e-absRhs _ _ _ = error "Lift.absRhs: no simple RHS"+absRhs pre lvs (SimpleRhs p _ e _) = simpleRhs p <$> absExpr pre lvs e+absRhs _ _ _ = error "Lift.absRhs: no simple RHS" -- Within a declaration group we have to split the list of declarations -- into the function and value declarations. Only the function@@ -178,7 +178,7 @@ absFunDecls pre lvs [] vds e = do vds' <- mapM (absDecl pre lvs) vds e' <- absExpr pre lvs e- return (Let NoSpanInfo vds' e')+ return (mkLet vds' e') absFunDecls pre lvs (fds:fdss) vds e = do m <- getModuleIdent env <- getAbstractEnv@@ -236,7 +236,7 @@ fds' <- mapM (absFunDecl pre fvs lvs) [d | d <- fds, any (`elem` fs') (bv d)] -- abstract remaining declarations e' <- absFunDecls pre lvs fdss vds e- return (Let NoSpanInfo fds' e')+ return (mkLet fds' e') -- When the free variables of a function are abstracted, the type of the -- function must be changed as well.@@ -248,7 +248,8 @@ d <- absDecl pre lvs $ FunctionDecl p undefined f' eqs' let FunctionDecl _ _ _ eqs'' = d modifyValueEnv $ bindGlobalInfo- (\qf tySc -> Value qf False (eqnArity $ head eqs') tySc) m f' $ polyType ty''+ (\qf tySc -> Value qf Nothing (eqnArity $ head eqs') tySc) m f' $+ polyType ty'' return $ FunctionDecl p ty'' f' eqs'' where f' = liftIdent pre f ty' = foldr TypeArrow (typeOf rhs') (map typeOf ts')@@ -269,7 +270,7 @@ absVar pre (Var ty f) = do m <- getModuleIdent modifyValueEnv $ bindGlobalInfo- (\qf tySc -> Value qf False (arrowArity ty) tySc) m f' $ polyType ty+ (\qf tySc -> Value qf Nothing (arrowArity ty) tySc) m f' $ polyType ty return $ Var ty f' where f' = liftIdent pre f @@ -296,9 +297,9 @@ absExpr _ _ c@(Constructor _ _ _) = return c absExpr pre lvs (Apply spi e1 e2) = Apply spi <$> absExpr pre lvs e1 <*> absExpr pre lvs e2-absExpr pre lvs (Let _ ds e) = absDeclGroup pre lvs ds e-absExpr pre lvs (Case spi ct e bs) =- Case spi ct <$> absExpr pre lvs e <*> mapM (absAlt pre lvs) bs+absExpr pre lvs (Let _ _ ds e) = absDeclGroup pre lvs ds e+absExpr pre lvs (Case _ _ ct e bs) =+ mkCase ct <$> absExpr pre lvs e <*> mapM (absAlt pre lvs) bs absExpr pre lvs (Typed spi e ty) = flip (Typed spi) ty <$> absExpr pre lvs e absExpr _ _ e = internalError $ "Lift.absExpr: " ++ show e@@ -331,8 +332,8 @@ where (rhs', ds') = liftRhs rhs liftRhs :: Eq a => Rhs a -> (Rhs a, [Decl a])-liftRhs (SimpleRhs p e _) = first (simpleRhs p) (liftExpr e)-liftRhs _ = error "Lift.liftRhs: no pattern match"+liftRhs (SimpleRhs p _ e _) = first (simpleRhs p) (liftExpr e)+liftRhs _ = error "Lift.liftRhs: no pattern match" liftDeclGroup :: Eq a => [Decl a] -> ([Decl a], [Decl a]) liftDeclGroup ds = (vds', concat (map liftFunDecl fds ++ dss'))@@ -346,10 +347,10 @@ liftExpr (Apply spi e1 e2) = (Apply spi e1' e2', ds1 ++ ds2) where (e1', ds1) = liftExpr e1 (e2', ds2) = liftExpr e2-liftExpr (Let _ ds e) = (mkLet ds' e', ds1 ++ ds2)+liftExpr (Let _ _ ds e) = (mkLet ds' e', ds1 ++ ds2) where (ds', ds1) = liftDeclGroup ds (e' , ds2) = liftExpr e-liftExpr (Case spi ct e alts) = (Case spi ct e' alts', concat $ ds' : dss')+liftExpr (Case _ _ ct e alts) = (mkCase ct e' alts', concat $ ds' : dss') where (e' , ds' ) = liftExpr e (alts', dss') = unzip $ map liftAlt alts liftExpr (Typed spi e ty) =@@ -393,8 +394,8 @@ renamePattern t (rm, ts) = (rm, t : ts) renameRhs :: Eq a => RenameMap a -> Rhs a -> Rhs a-renameRhs rm (SimpleRhs p e _) = simpleRhs p (renameExpr rm e)-renameRhs _ _ = error "Lift.renameRhs"+renameRhs rm (SimpleRhs p _ e _) = simpleRhs p (renameExpr rm e)+renameRhs _ _ = error "Lift.renameRhs" renameExpr :: Eq a => RenameMap a -> Expression a -> Expression a renameExpr _ l@(Literal _ _ _) = l@@ -407,10 +408,10 @@ renameExpr rm (Typed spi e ty) = Typed spi (renameExpr rm e) ty renameExpr rm (Apply spi e1 e2) = Apply spi (renameExpr rm e1) (renameExpr rm e2)-renameExpr rm (Let spi ds e) =- Let spi (map (renameDecl rm) ds) (renameExpr rm e)-renameExpr rm (Case spi ct e alts) =- Case spi ct (renameExpr rm e) (map (renameAlt rm) alts)+renameExpr rm (Let _ _ ds e) =+ mkLet (map (renameDecl rm) ds) (renameExpr rm e)+renameExpr rm (Case _ _ ct e alts) =+ mkCase ct (renameExpr rm e) (map (renameAlt rm) alts) renameExpr _ _ = error "Lift.renameExpr" renameDecl :: Eq a => RenameMap a -> Decl a -> Decl a
src/Transformations/Newtypes.hs view
@@ -30,8 +30,10 @@ import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue) -removeNewtypes :: ValueEnv -> Module Type -> Module Type-removeNewtypes vEnv mdl = R.runReader (nt mdl) vEnv+removeNewtypes :: Bool -> ValueEnv -> Module Type -> Module Type+removeNewtypes remNT vEnv mdl+ | remNT = R.runReader (nt mdl) vEnv+ | otherwise = mdl type NTM a = R.Reader ValueEnv a @@ -42,7 +44,7 @@ nt = mapM nt instance Show a => Newtypes (Module a) where- nt (Module spi ps m es is ds) = Module spi ps m es is <$> mapM nt ds+ nt (Module spi li ps m es is ds) = Module spi li ps m es is <$> mapM nt ds instance Show a => Newtypes (Decl a) where nt d@(InfixDecl _ _ _ _) = return d@@ -66,8 +68,8 @@ "Newtypes.Newtypes.nt: unexpected left-hand-side: " ++ show lhs instance Show a => Newtypes (Rhs a) where- nt (SimpleRhs p e []) = flip (SimpleRhs p) [] <$> nt e- nt rhs = internalError $+ nt (SimpleRhs p li e []) = flip (SimpleRhs p li) [] <$> nt e+ nt rhs = internalError $ "Newtypes.Newtypes.nt: unexpected right-hand-side: " ++ show rhs instance Show a => Newtypes (Pattern a) where@@ -94,8 +96,8 @@ isNc <- isNewtypeConstr c if isNc then nt e2 else Apply spi <$> nt e1 <*> nt e2 _ -> Apply spi <$> nt e1 <*> nt e2- nt (Case spi ct e as) = Case spi ct <$> nt e <*> mapM nt as- nt (Let spi ds e) = Let spi <$> nt ds <*> nt e+ nt (Case spi li ct e as) = Case spi li ct <$> nt e <*> mapM nt as+ nt (Let spi li ds e) = Let spi li <$> nt ds <*> nt e nt (Typed spi e qty) = flip (Typed spi) qty <$> nt e nt e = internalError $ "Newtypes.Newtypes.nt: unexpected expression: " ++ show e
src/Transformations/Qual.hs view
@@ -51,10 +51,10 @@ qual m tcEnv tyEnv mdl = R.runReader (qModule mdl) (QualEnv m tcEnv tyEnv) qModule :: Qual (Module a)-qModule (Module spi ps m es is ds) = do+qModule (Module spi li ps m es is ds) = do es' <- qExportSpec es ds' <- mapM qDecl ds- return (Module spi ps m es' is ds')+ return (Module spi li ps m es' is ds') qExportSpec :: Qual (Maybe ExportSpec) qExportSpec Nothing = return Nothing@@ -67,22 +67,22 @@ qExport m@(ExportModule _ _) = return m qDecl :: Qual (Decl a)-qDecl i@(InfixDecl _ _ _ _) = return i-qDecl (DataDecl p n vs cs clss) = DataDecl p n vs <$>+qDecl i@(InfixDecl _ _ _ _) = return i+qDecl (DataDecl p n vs cs clss) = DataDecl p n vs <$> mapM qConstrDecl cs <*> mapM qClass clss-qDecl e@(ExternalDataDecl _ _ _) = return e-qDecl (NewtypeDecl p n vs nc clss) = NewtypeDecl p n vs <$>+qDecl e@(ExternalDataDecl _ _ _) = return e+qDecl (NewtypeDecl p n vs nc clss) = NewtypeDecl p n vs <$> qNewConstrDecl nc <*> mapM qClass clss-qDecl (TypeDecl p n vs ty) = TypeDecl p n vs <$> qTypeExpr ty-qDecl (TypeSig p fs qty) = TypeSig p fs <$> qQualTypeExpr qty-qDecl (FunctionDecl a p f eqs) = FunctionDecl a p f <$> mapM qEquation eqs-qDecl e@(ExternalDecl _ _) = return e-qDecl (PatternDecl p t rhs) = PatternDecl p <$> qPattern t <*> qRhs rhs-qDecl vs@(FreeDecl _ _) = return vs-qDecl (DefaultDecl p tys) = DefaultDecl p <$> mapM qTypeExpr tys-qDecl (ClassDecl p cx cls tv ds) = ClassDecl p <$>+qDecl (TypeDecl p n vs ty) = TypeDecl p n vs <$> qTypeExpr ty+qDecl (TypeSig p fs qty) = TypeSig p fs <$> qQualTypeExpr qty+qDecl (FunctionDecl a p f eqs) = FunctionDecl a p f <$> mapM qEquation eqs+qDecl e@(ExternalDecl _ _) = return e+qDecl (PatternDecl p t rhs) = PatternDecl p <$> qPattern t <*> qRhs rhs+qDecl vs@(FreeDecl _ _) = return vs+qDecl (DefaultDecl p tys) = DefaultDecl p <$> mapM qTypeExpr tys+qDecl (ClassDecl p li cx cls tv ds) = ClassDecl p li <$> qContext cx <*> pure cls <*> pure tv <*> mapM qDecl ds-qDecl (InstanceDecl p cx qcls ty ds) = InstanceDecl p <$>+qDecl (InstanceDecl p li cx qcls ty ds) = InstanceDecl p li <$> qContext cx <*> qClass qcls <*> qTypeExpr ty <*> mapM qDecl ds qConstrDecl :: Qual ConstrDecl@@ -156,10 +156,10 @@ InfixFuncPattern spi a <$> qPattern t1 <*> qIdent op <*> qPattern t2 qRhs :: Qual (Rhs a)-qRhs (SimpleRhs spi e ds) =- SimpleRhs spi <$> qExpr e <*> mapM qDecl ds-qRhs (GuardedRhs spi es ds) =- GuardedRhs spi <$> mapM qCondExpr es <*> mapM qDecl ds+qRhs (SimpleRhs spi li e ds) =+ SimpleRhs spi li <$> qExpr e <*> mapM qDecl ds+qRhs (GuardedRhs spi li es ds) =+ GuardedRhs spi li <$> mapM qCondExpr es <*> mapM qDecl ds qCondExpr :: Qual (CondExpr a) qCondExpr (CondExpr p g e) = CondExpr p <$> qExpr g <*> qExpr e@@ -199,16 +199,16 @@ <*> qExpr e qExpr (Lambda spi ts e) = Lambda spi <$> mapM qPattern ts <*> qExpr e-qExpr (Let spi ds e) = Let spi <$> mapM qDecl ds <*> qExpr e-qExpr (Do spi sts e) = Do spi <$> mapM qStmt sts <*> qExpr e+qExpr (Let spi li ds e) = Let spi li <$> mapM qDecl ds <*> qExpr e+qExpr (Do spi li sts e) = Do spi li <$> mapM qStmt sts <*> qExpr e qExpr (IfThenElse spi e1 e2 e3) = IfThenElse spi <$> qExpr e1 <*> qExpr e2 <*> qExpr e3-qExpr (Case spi ct e as) = Case spi ct <$> qExpr e <*> mapM qAlt as+qExpr (Case spi li ct e as) = Case spi li ct <$> qExpr e <*> mapM qAlt as qStmt :: Qual (Statement a)-qStmt (StmtExpr spi e) = StmtExpr spi <$> qExpr e-qStmt (StmtBind spi t e) = StmtBind spi <$> qPattern t <*> qExpr e-qStmt (StmtDecl spi ds) = StmtDecl spi <$> mapM qDecl ds+qStmt (StmtExpr spi e) = StmtExpr spi <$> qExpr e+qStmt (StmtBind spi t e) = StmtBind spi <$> qPattern t <*> qExpr e+qStmt (StmtDecl spi li ds) = StmtDecl spi li <$> mapM qDecl ds qAlt :: Qual (Alt a) qAlt (Alt p t rhs) = Alt p <$> qPattern t <*> qRhs rhs
src/Transformations/Simplify.hs view
@@ -53,7 +53,7 @@ -- ----------------------------------------------------------------------------- simplify :: ValueEnv -> Module Type -> (Module Type, ValueEnv)-simplify vEnv mdl@(Module _ _ m _ _ _) = (mdl', valueEnv s')+simplify vEnv mdl@(Module _ _ _ m _ _ _) = (mdl', valueEnv s') where (mdl', s') = S.runState (simModule mdl) (SimplifyState m vEnv 1) -- -----------------------------------------------------------------------------@@ -96,8 +96,8 @@ -- ----------------------------------------------------------------------------- simModule :: Module Type -> SIM (Module Type)-simModule (Module spi ps m es is ds) = Module spi ps m es is- <$> mapM (simDecl Map.empty) ds+simModule (Module spi li ps m es is ds) = Module spi li ps m es is+ <$> mapM (simDecl Map.empty) ds -- Inline an expression for a variable type InlineEnv = Map.Map Ident (Expression Type)@@ -114,8 +114,8 @@ inlineFun env p lhs rhs' simRhs :: InlineEnv -> Rhs Type -> SIM (Rhs Type)-simRhs env (SimpleRhs p e _) = simpleRhs p <$> simExpr env e-simRhs _ (GuardedRhs _ _ _) = error "Simplify.simRhs: guarded rhs"+simRhs env (SimpleRhs p _ e _) = simpleRhs p <$> simExpr env e+simRhs _ (GuardedRhs _ _ _ _) = error "Simplify.simRhs: guarded rhs" -- ----------------------------------------------------------------------------- -- Inlining of Functions@@ -152,7 +152,7 @@ inlineFun env p lhs rhs = do m <- getModuleIdent case rhs of- SimpleRhs _ (Let NoSpanInfo [FunctionDecl _ _ f' eqs'] e) _+ SimpleRhs _ _ (Let _ _ [FunctionDecl _ _ f' eqs'] e) _ | -- @f'@ is not recursive f' `notElem` qfv m eqs' -- @f'@ does not perform any pattern matching@@ -161,7 +161,7 @@ let a = eqnArity $ head eqs' (n, vs', e') = etaReduce 0 [] (reverse (snd $ flatLhs lhs)) e if -- the eta-reduced rhs of @f@ is a call to @f'@- e' == Variable NoSpanInfo (typeOf e') (qualify f')+ setSpanInfo NoSpanInfo e' == Variable NoSpanInfo (typeOf e') (qualify f') -- @f'@ was fully applied before eta-reduction && n == a then mapM (mergeEqns p vs') eqs'@@ -169,12 +169,12 @@ _ -> return [Equation p lhs rhs] where etaReduce n1 vs (VariablePattern _ ty v : ts1)- (Apply NoSpanInfo e1 (Variable NoSpanInfo _ v'))+ (Apply _ e1 (Variable _ _ v')) | qualify v == v' = etaReduce (n1 + 1) ((ty, v) : vs) ts1 e1 etaReduce n1 vs _ e1 = (n1, vs, e1) - mergeEqns p1 vs (Equation _ (FunLhs _ _ ts2) (SimpleRhs p2 e _))- = Equation p1 lhs <$> simRhs env (simpleRhs p2 (Let NoSpanInfo ds e))+ mergeEqns p1 vs (Equation _ (FunLhs _ _ ts2) (SimpleRhs p2 _ e _))+ = Equation p1 lhs <$> simRhs env (simpleRhs p2 (mkLet ds e)) where ds = zipWith (\t v -> PatternDecl NoSpanInfo t (simpleRhs p2 (uncurry mkVar v))) ts2@@ -215,20 +215,20 @@ maybe (return v) (simExpr env . withType ty) (Map.lookup (unqualify x) env) -- simplification of application simExpr env (Apply _ e1 e2) = case e1 of- Let _ ds e' -> simExpr env (Let NoSpanInfo ds (Apply NoSpanInfo e' e2))- Case _ ct e' bs -> simExpr env (Case NoSpanInfo ct e' (map (applyToAlt e2) bs))- _ -> Apply NoSpanInfo <$> simExpr env e1 <*> simExpr env e2+ Let _ _ ds e' -> simExpr env (mkLet ds (Apply NoSpanInfo e' e2))+ Case _ _ ct e' bs -> simExpr env (mkCase ct e' (map (applyToAlt e2) bs))+ _ -> Apply NoSpanInfo <$> simExpr env e1 <*> simExpr env e2 where applyToAlt e (Alt p t rhs) = Alt p t (applyToRhs e rhs)- applyToRhs e (SimpleRhs p e1' _) = simpleRhs p (Apply NoSpanInfo e1' e)- applyToRhs _ (GuardedRhs _ _ _) = error "Simplify.simExpr.applyRhs: Guarded rhs"+ applyToRhs e (SimpleRhs p _ e1' _) = simpleRhs p (Apply NoSpanInfo e1' e)+ applyToRhs _ (GuardedRhs _ _ _ _) = error "Simplify.simExpr.applyRhs: Guarded rhs" -- simplification of declarations-simExpr env (Let _ ds e) = do+simExpr env (Let _ _ ds e) = do m <- getModuleIdent dss <- mapM sharePatternRhs ds simplifyLet env (scc bv (qfv m) (foldr hoistDecls [] (concat dss))) e-simExpr env (Case _ ct e bs) =- Case NoSpanInfo ct <$> simExpr env e <*> mapM (simplifyAlt env) bs+simExpr env (Case _ _ ct e bs) =+ mkCase ct <$> simExpr env e <*> mapM (simplifyAlt env) bs simExpr env (Typed _ e qty) = flip (Typed NoSpanInfo) qty <$> simExpr env e simExpr _ _ = error "Simplify.simExpr: no pattern match"@@ -256,7 +256,7 @@ -- Lift up nested let declarations in pattern declarations, i.e., replace -- @let p = let ds' in e'; ds in e@ by @let ds'; p = e'; ds in e@. hoistDecls :: Decl a -> [Decl a] -> [Decl a]-hoistDecls (PatternDecl p t (SimpleRhs p' (Let NoSpanInfo ds' e) _)) ds+hoistDecls (PatternDecl p t (SimpleRhs p' _ (Let _ _ ds' e) _)) ds = foldr hoistDecls ds (PatternDecl p t (simpleRhs p' e) : ds') hoistDecls d ds = d : ds @@ -293,7 +293,7 @@ inlineVars :: InlineEnv -> [Decl Type] -> SIM InlineEnv inlineVars env ds = case ds of- [PatternDecl _ (VariablePattern _ _ v) (SimpleRhs _ e _)] -> do+ [PatternDecl _ (VariablePattern _ _ v) (SimpleRhs _ _ e _)] -> do allowed <- canInlineVar v e return $ if allowed then Map.insert v e env else env _ -> return env@@ -308,13 +308,13 @@ mkLet' :: ModuleIdent -> [Decl Type] -> Expression Type -> Expression Type mkLet' m [FreeDecl p vs] e | null vs' = e- | otherwise = Let NoSpanInfo [FreeDecl p vs'] e -- remove unused free variables+ | otherwise = mkLet [FreeDecl p vs'] e -- remove unused free variables where vs' = filter ((`elem` qfv m e) . varIdent) vs-mkLet' m [PatternDecl _ (VariablePattern _ ty v) (SimpleRhs _ e _)] (Variable _ _ v')+mkLet' m [PatternDecl _ (VariablePattern _ ty v) (SimpleRhs _ _ e _)] (Variable _ _ v') | v' == qualify v && v `notElem` qfv m e = withType ty e -- inline single binding mkLet' m ds e | not (any (`elem` qfv m e) (bv ds)) = e -- removed unused bindings- | otherwise = Let NoSpanInfo ds e+ | otherwise = mkLet ds e -- In order to implement lazy pattern matching in local declarations, -- pattern declarations 't = e' where 't' is not a variable@@ -331,17 +331,17 @@ -- fvs contains all variables used in the declarations and the body -- of the let expression. expandPatternBindings :: [Ident] -> Decl Type -> SIM [Decl Type]-expandPatternBindings fvs d@(PatternDecl p t (SimpleRhs _ e _)) = case t of+expandPatternBindings fvs d@(PatternDecl p t (SimpleRhs _ _ e _)) = case t of VariablePattern _ _ _ -> return [d] _ -> -- used variables mapM mkSelectorDecl (filter ((`elem` fvs) . fst3) (patternVars t)) where- pty = typeOf t -- type of patternNoSpaNoSpanInfonInfo+ pty = typeOf t -- type of pattern mkSelectorDecl (v, _, vty) = do let fty = TypeArrow pty vty f <- freshIdent (updIdentName (++ '#' : idName v) . fpSelectorId) return $ varDecl p vty v $- Let NoSpanInfo [funDecl p fty f [t] (mkVar vty v)]+ mkLet [funDecl p fty f [t] (mkVar vty v)] (Apply NoSpanInfo (mkVar fty f) e) expandPatternBindings _ d = return [d]
− src/cymake.hs
@@ -1,57 +0,0 @@-{- |- Module : $Header$- Description : Main module- Copyright : (c) 2005 Martin Engelke- 2011 - 2016 Björn Peemöller- License : BSD-3-clause-- Maintainer : bjp@informatik.uni-kiel.de- Stability : experimental- Portability : portable-- Command line tool for generating Curry representations (e.g. FlatCurry,- AbstractCurry) for a Curry source file including all imported modules.--}-module Main (main) where--import Curry.Base.Monad (runCYIO)--import Base.Messages-import Files.CymakePath (cymakeGreeting, cymakeVersion)--import CurryBuilder (buildCurry)-import CompilerOpts (Options (..), CymakeMode (..), getCompilerOpts, usage)---- |The command line tool cymake-main :: IO ()-main = getCompilerOpts >>= cymake---- |Invoke the curry builder w.r.t the command line arguments-cymake :: (String, Options, [String], [String]) -> IO ()-cymake (prog, opts, files, errs) = case optMode opts of- ModeHelp -> printUsage prog- ModeVersion -> printVersion- ModeNumericVersion -> printNumericVersion- ModeMake | not (null errs) -> badUsage prog errs- | null files -> badUsage prog ["No input files"]- | otherwise -> runCYIO (mapM_ (buildCurry opts) files) >>=- either abortWithMessages continueWithMessages- where continueWithMessages = warnOrAbort (optWarnOpts opts) . snd---- |Print the usage information of the command line tool-printUsage :: String -> IO ()-printUsage prog = putStrLn $ usage prog---- |Print the program version-printVersion :: IO ()-printVersion = putStrLn cymakeGreeting---- |Print the numeric program version-printNumericVersion :: IO ()-printNumericVersion = putStrLn cymakeVersion---- |Print errors and abort execution on bad parameters-badUsage :: String -> [String] -> IO ()-badUsage prog errs = do- putErrsLn $ map (\ err -> prog ++ ": " ++ err) errs- abortWith ["Try '" ++ prog ++ " --help' for more information"]
test/TestFrontend.hs view
@@ -28,7 +28,10 @@ import qualified Control.Exception as E (SomeException, catch) import Data.List (isInfixOf, sort)-import Distribution.TestSuite+import qualified Data.Map as Map (insert)+import Distribution.TestSuite ( Test (..), TestInstance (..)+ , Progress (..), Result (..)+ , OptionDescr) import System.FilePath (FilePath, (</>), (<.>)) import Curry.Base.Message (Message, message, ppMessages, ppError)@@ -36,11 +39,12 @@ import Curry.Base.Pretty (text) import qualified CompilerOpts as CO ( Options (..), WarnOpts (..) , WarnFlag (..), Verbosity (VerbQuiet)- , defaultOptions, defaultWarnOpts)+ , CppOpts (..)+ , defaultOptions) import CurryBuilder (buildCurry) tests :: IO [Test]-tests = return [passingTests, warningTests, failingTests]+tests = return [failingTests, passingTests, warningTests] runSecure :: CYIO a -> IO (Either [Message] (a, [Message])) runSecure act = runCYIO act `E.catch` handler@@ -48,40 +52,47 @@ -- Execute a test by calling cymake runTest :: CO.Options -> String -> [String] -> IO Progress-runTest opts test [] = passOrFail <$> runSecure (buildCurry opts' test)- where- wOpts = CO.optWarnOpts opts- wFlags = CO.WarnUnusedBindings- : CO.WarnUnusedGlobalBindings- : CO.wnWarnFlags wOpts- opts' = opts { CO.optForce = True- , CO.optWarnOpts = wOpts { CO.wnWarnFlags = wFlags }- }- passOrFail = Finished . either fail pass- fail msgs- | null msgs = Pass- | otherwise = Fail $ "An unexpected failure occurred: " ++ showMessages msgs- pass _ = Pass-runTest opts test errorMsgs = catchE <$> runSecure (buildCurry opts' test)- where- wOpts = CO.optWarnOpts opts- wFlags = CO.WarnUnusedBindings- : CO.WarnUnusedGlobalBindings- : CO.wnWarnFlags wOpts- opts' = opts { CO.optForce = True- , CO.optWarnOpts = wOpts { CO.wnWarnFlags = wFlags }- }- catchE = Finished . either pass fail- pass msgs = let errorStr = showMessages msgs- leftOverMsgs = filter (not . flip isInfixOf errorStr) errorMsgs- in if null leftOverMsgs- then Pass- else Fail $ "Expected warnings/failures did not occur: " ++ unwords leftOverMsgs- fail = pass . snd+runTest opts test errorMsgs =+ if null errorMsgs+ then passOrFail <$> runSecure (buildCurry opts' test)+ else catchE <$> runSecure (buildCurry opts' test)+ where+ cppOpts = CO.optCppOpts opts+ cppDefs = Map.insert "__PAKCS__" 3 (CO.cppDefinitions cppOpts)+ wOpts = CO.optWarnOpts opts+ wFlags = CO.WarnUnusedBindings+ : CO.WarnUnusedGlobalBindings+ : CO.wnWarnFlags wOpts+ opts' = opts { CO.optForce = True+ , CO.optWarnOpts = wOpts+ { CO.wnWarnFlags = wFlags }+ , CO.optCppOpts = cppOpts+ { CO.cppDefinitions = cppDefs }+ }+ passOrFail = Finished . either fail (const Pass)+ catchE = Finished . either pass (pass . snd)+ fail msgs+ | null msgs = Pass+ | otherwise = Fail $ "An unexpected failure occurred: " +++ showMessages msgs+ pass msgs+ | null otherMsgs = Pass+ | otherwise = Fail $ "Expected warnings/failures did not occur: " +++ unwords otherMsgs+ where+ errorStr = showMessages msgs+ otherMsgs = filter (not . flip isInfixOf errorStr) errorMsgs showMessages :: [Message] -> String showMessages = show . ppMessages ppError . sort +-- group of test which should fail yielding a specific error message+failingTests :: Test+failingTests = Group { groupName = "Failing Tests"+, concurrently = False+, groupTests = map (mkTest "test/fail/") failInfos+}+ -- group of tests which should pass passingTests :: Test passingTests = Group { groupName = "Passing Tests"@@ -89,13 +100,6 @@ , groupTests = map (mkTest "test/pass/") passInfos } --- group of test which should fail yielding a specific error message-failingTests :: Test-failingTests = Group { groupName = "Failing Tests"- , concurrently = False- , groupTests = map (mkTest "test/fail/") failInfos- }- -- group of tests which should pass producing a specific warning message warningTests :: Test warningTests = Group { groupName = "Warning Tests"@@ -130,57 +134,6 @@ type SetOption = String -> String -> Either String TestInstance ----------------------------------------------------------------------------------- Definition of passing tests------------------------------------------------------------------------------------- generate a simple passing test-mkPassTest :: String -> TestInfo-mkPassTest name = (name, [], [], Nothing, [])---- To add a passing test to the test suite simply add the module name of the--- test code to the following list-passInfos :: [TestInfo]-passInfos = map mkPassTest- [ "AbstractCurryBug"- , "ACVisibility"- , "AnonymVar"- , "CaseComplete"- , "DefaultPrecedence"- , "Dequeue"- , "ExplicitLayout"- , "FCase"- , "FP_Lifting"- , "FP_NonCyclic"- , "FP_NonLinearity"- , "FunctionalPatterns"- , "HaskellRecords"- , "Hierarchical"- , "Infix"- , "Inline"- , "Lambda"- , "Maybe"- , "NegLit"- , "Newtype1"- , "Newtype2"- , "NonLinearLHS"- , "OperatorDefinition"- , "PatDecl"- , "Prelude"- , "Pretty"- , "RecordsPolymorphism"- , "RecordTest1"- , "RecordTest2"- , "RecordTest3"- , "ReexportTest"- , "SelfExport"- , "SpaceLeak"- , "TyConsTest"- , "TypedExpr"- , "UntypedAcy"- , "Unzip"- ]---------------------------------------------------------------------------------- -- Definition of failing tests -------------------------------------------------------------------------------- @@ -192,7 +145,15 @@ -- test code and the expected error message(s) to the following list failInfos :: [TestInfo] failInfos = map (uncurry mkFailTest)- [ ("ErrorMultipleSignature", ["More than one type signature for `f'"])+ [ ("DataFail",+ [ "Missing instance for Prelude.Data Test1"+ , "Missing instance for Prelude.Data (Test2"+ , "Missing instance for Prelude.Data (Test2"+ , "Missing instance for Prelude.Data Test1"+ ]+ )+ , ("ErrorMultipleSignature", ["More than one type signature for `f'"])+ , ("ErrorMultipleSignature", ["More than one type signature for `f'"]) , ("ExportCheck/AmbiguousName", ["Ambiguous name `not'"]) , ("ExportCheck/AmbiguousType", ["Ambiguous type `Bool'"]) , ("ExportCheck/ModuleNotImported", ["Module `Foo' not imported"])@@ -212,6 +173,7 @@ , "Functional patterns are not supported inside a do sequence" ] )+ , ("HaskellRecordsFail", ["Unexpected token `,'"]) , ("FP_NonGlobal", ["Function `f1' in functional pattern is not global"]) , ("ImportError", [ "Module Prelude does not export foo"@@ -223,6 +185,8 @@ , "Type variable b occurs more than once in left hand side of type declaration" ] )+ , ("MissingLabelInUpdate",+ ["Undefined record label `l1'"] ) , ("MultipleArities", ["Equations for `test' have different arities"]) , ("MultipleDefinitions", ["Multiple definitions for data/record constructor `Rec'"]@@ -248,11 +212,75 @@ , "Function: h" , "Type signature too general" , "Function: g'"+ , "Type signature too general"+ , "Function: n" ] )+ , ("UnboundTypeVariable",+ [ "Unbound type variable b"+ , "Unbound type variable c"+ ]+ ) ] --------------------------------------------------------------------------------+-- Definition of passing tests+--------------------------------------------------------------------------------++-- generate a simple passing test+mkPassTest :: String -> TestInfo+mkPassTest = flip mkFailTest []++-- To add a passing test to the test suite simply add the module name of the+-- test code to the following list+passInfos :: [TestInfo]+passInfos = map mkPassTest+ [ "AbstractCurryBug"+ , "ACVisibility"+ , "AnonymVar"+ , "CaseComplete"+ , "DataPass"+ , "DefaultPrecedence"+ , "Dequeue"+ , "EmptyWhere"+ , "ExplicitLayout"+ , "FCase"+ , "FP_Lifting"+ , "FP_NonCyclic"+ , "FP_NonLinearity"+ , "FunctionalPatterns"+ , "HaskellRecords"+ , "HaskellRecordsPass"+ , "Hierarchical"+ , "ImportRestricted"+ , "ImportRestricted2"+ , "Infix"+ , "Inline"+ , "Lambda"+ , "Maybe"+ , "NegLit"+ , "Newtype1"+ , "Newtype2"+ , "NonLinearLHS"+ , "OperatorDefinition"+ , "PatDecl"+ , "Prelude"+ , "Pretty"+ , "RecordsPolymorphism"+ , "RecordTest1"+ , "RecordTest2"+ , "RecordTest3"+ , "ReexportTest"+ , "SelfExport"+ , "SpaceLeak"+ , "TyConsTest"+ , "TypedExpr"+ , "UntypedAcy"+ , "Unzip"+ , "WhereAfterDo"+ ]++-------------------------------------------------------------------------------- -- Definition of warning tests -------------------------------------------------------------------------------- @@ -305,6 +333,7 @@ , "In an equation for `tuple'", "In an equation for `tuple2'" , "In an equation for `g'", "In an equation for `rec'"] )+ , ("NoRedundant", []) , ("OverlappingPatterns", [ "Pattern matches are potentially unreachable", "In a case alternative" , "An fcase expression is potentially non-deterministic due to overlapping rules"@@ -312,6 +341,12 @@ , "Function `j' is potentially non-deterministic due to overlapping rules" , "Function `k' is potentially non-deterministic due to overlapping rules" ]+ )+ , ("QualRedundant",+ [ "Redundant context in type signature for function `f': 'P.Eq a'"]+ )+ , ("Redundant",+ [ "Redundant context in type signature for function `f': 'Eq a'"] ) , ("ShadowingSymbols", [ "Unused declaration of variable `x'", "Shadowing symbol `x'"])