pax_global_header00006660000000000000000000000064134777117360014532gustar00rootroot0000000000000052 comment=28c04fa53ddca60793ae94ae244b1758ef2a6dcc curry-base-v1.1.1/000077500000000000000000000000001347771173600137745ustar00rootroot00000000000000curry-base-v1.1.1/.gitignore000066400000000000000000000000651347771173600157650ustar00rootroot00000000000000cabal-dev/ dist/ .cabal-sandbox/ cabal.sandbox.configcurry-base-v1.1.1/CHANGELOG.md000066400000000000000000000141351347771173600156110ustar00rootroot00000000000000Change log for curry-base ========================= Version (1.2.0) (WIP) ===================== * Added support for latex-style in literate curry Version (1.1.0) =============== * Added SpanInfos to AST Version (1.0.0) =============== * Add support for typeclasses as known from Haskell. Version (0.4.2) =============== * Licenses made more specific. * Introduced a new annotated variant of FlatCurry. Version (0.4.1) =============== * Added new operator `@>` to return the left operand with the source code position obtained from the right operand. * Parenthesized type expressions are now represented accordingly in the abstract syntax tree * Derive `Show` and `Read` instances also for identifiers to facilitate debugging and reading/writing from/to files * Emitted FlatCurry files now contain newlines to improve readability for humans * Implemented pretty printer for extended FlatCurry * Added syntax extension `ExistentialQuantification` that allows the use of existentially quantified types in data and newtype constructors * Representation for spans (start and end position) added Version 0.4.0 ============= * Introduced new representation of AbstractCurry - AbstractCurry files now contain version information - support for new record syntax - support for newtype declarations - evaluation annotations removed - arity of constructor declarations removed - simplified representation of function rules - String literals added * Removed support for Curry's record syntax and introduced Haskell's record syntax instead * Lexer is now capable of lexing binary integer literals, for instance `0b101010` or `0B101010` can now be lexed and are converted to `42`. * Removed record type extensions * Moved `CYT` monads to `curry-base` (`Curry.Base.Monad`) and removed `MessageM` monad * Adapted Curry syntax and parser: Now declaration of operator precendence in declarations of infix operators is optional * Moved module `InterfaceEquivalence` (curry-frontend) to `Curry.Syntax.InterfaceEquivalence` (curry-base) * Removed module `Curry.Base.Equiv` * Replaced module `Curry.ExtendedFlat.Interface.Equality` by `Curry.ExtendedFlat.InterfaceEquivalence` using a type class to implement equivalence of FlatCurry interfaces * Removed file name extensions for FlatCurry XML files. * Added syntax extension `NegativeLiterals` to translate negated literals into negative literals instead of a call to `Prelude.negate` and `Prelude.negateFloat`, respectively. * Added `CYMAKE` to the list of recognized tools when parsing an options pragma (`{-# OPTIONS_CYMAKE opt1 opt2 ... optN #-}`). Version 0.3.10 ============== * Updated internal structure of `Curry.Base.Filenames` and `Curry.Base.PathUtils`. * Fixed bug in parser which complained `:-> expected` when it really looked for `:>`. * Make library compile under GHC 7.8 without warnings. * Unliterating and lexing/parsing of source files are now decoupled to support custom preprocessors. * Split `Curry.AbstractCurry` and `Curry.FlatCurry` into two modules `.Type` and `.Files`, where `.Type` now only contains the type definition while `.Files` contains read/write functions. Both are subsumed by the parent modules `Curry.AbstractCurry` and `Curry.FlatCurry` for convenience. Version 0.3.9 ============= * Implementation of module pragmas added. Module pragmas of the following types are now parsed and represented in the abstract syntax tree: ~~~ {.curry} {-# LANGUAGE LANG_EXT+ #-} {-# OPTIONS "string" #-} {-# OPTIONS_TOOL "string" #-} module Main where ~~~ where - `LANGEXT+` is a non-empty, comma-separated list of the following language extensions: `AnonFreeVars`, `FunctionalPatterns`, `NoImplicitPrelude`, `Records` - `TOOL` is either `KICS2`, `PAKCS`, or some other tool, represented as `Unknown String`. Note that, naturally, the curry-base library only recognizes the above mentioned pragmas, while the processing is up to the respective tool. All other texts given in the pragma braces is ignored and treated as a nested comment. * Reactivation of Curry interface files. During adaption of the MCC frontend to FlatCurry the Curry interface files have been deactivated and replaced by FlatCurry's interface files. To allow the later addition of type classes to Curry, they have now been reactivated. Version 0.3.8 ============= * The parser now takes the layout into respect when parsing the import list. This fixes issue #494 where a module with imports without restrictions, directly followed by an operator definition, could not be parsed. * Various internal improvements. Version 0.3.7 ============= * Support for typed FlatCurry expressions added. Now additional type information given by the programmer as in ~~~ {.curry} null (unknown :: [()]) ~~~ is represented in FlatCurry and cann therefore be processed by other programs like PAKCS or KICS2. Version 0.3.6 ============= * Fixed a bug where character constants not contained in the ASCII alphabet were translated incorrectly. Version 0.3.5 ============= * Fixed a bug w.r.t. pretty-printing of records. Version 0.3.4 ============= * Made compiler messages comparable to allow later sorting of compiler errors and warnings to present them in the order of their occurence. Version 0.3.3 ============= * Improved pretty printing of Curry modules. Version 0.3.2 ============= * Improved pretty-printing of warnings and errors. * Improved error message for missing precendence after fixity declaration. * Changed syntax of records to allow disambiguation of record selection and case branches. * Various improvements. Version 0.3.1 ============= * Improved support for anonymous identifiers (test predicate, parser also returns source code position). Version 0.3.0 ============= * Massive refactoring of the previous version. * All compiler warnings removed. * Fixed various implementation bugs. curry-base-v1.1.1/LICENSE000066400000000000000000000027461347771173600150120ustar00rootroot00000000000000Copyright (c) 1998-2004, Wolfgang Lux Copyright (c) 2005-2016, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. None of the names of the copyright holders and contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. curry-base-v1.1.1/Setup.hs000066400000000000000000000000561347771173600154310ustar00rootroot00000000000000import Distribution.Simple main = defaultMain curry-base-v1.1.1/curry-base.cabal000066400000000000000000000055421347771173600170420ustar00rootroot00000000000000Name: curry-base Version: 1.1.0 Cabal-Version: >= 1.10 Synopsis: Functions for manipulating Curry programs Description: This package serves as a foundation for Curry compilers. It defines the intermediate language formats FlatCurry. Additionally, it provides functionality for the smooth integration of compiler frontends and backends. Category: Language License: BSD3 License-File: LICENSE Author: Wolfgang Lux, Martin Engelke, Bernd Braßel, Holger Siegel, Björn Peemöller, Finn Teegen Maintainer: fte@informatik.uni-kiel.de Homepage: http://curry-language.org Build-Type: Simple Stability: experimental Extra-Source-Files: CHANGELOG.md source-repository head type: git location: git://git-ps.informatik.uni-kiel.de/curry/curry-base.git Flag broken-directory Description: Is the cabal configuration of directory incomplete? Default: False Flag old-time Description: Does the directory package use the old time implementation? Default: False Library hs-source-dirs: src default-language: Haskell2010 Build-Depends: base == 4.*, transformers if impl(ghc < 7.4) Build-Depends: either < 4, contravariant < 0.5, semigroupoids < 3.0.3 if flag(broken-directory) { Build-Depends: time, directory == 1.2.0.0, base >= 4.6 } else { if flag(old-time) { Build-Depends: old-time, directory } else { Build-Depends: time, directory >= 1.2.0.1 } } Build-Depends: mtl , containers , filepath , extra >= 1.4.6 , parsec , pretty ghc-options: -Wall Exposed-Modules: 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 Test-Suite test-base type: detailed-0.9 hs-source-dirs: test default-language: Haskell2010 test-module: TestBase build-depends: base == 4.*, Cabal >= 1.20, curry-base, filepath, mtl curry-base-v1.1.1/debian/000077500000000000000000000000001347771173600152165ustar00rootroot00000000000000curry-base-v1.1.1/debian/changelog000066400000000000000000000003521347771173600170700ustar00rootroot00000000000000curry-base (2:1.1.0-0) UNRELEASED; urgency=medium * Upstream-provided Debian package for curry-base. See upstream CHANGELOG.md for recent changes. -- Mike Gabriel Thu, 22 Nov 2018 14:30:00 +0200 curry-base-v1.1.1/debian/compat000066400000000000000000000000021347771173600164140ustar00rootroot000000000000009 curry-base-v1.1.1/debian/control000066400000000000000000000070241347771173600166240ustar00rootroot00000000000000Source: curry-base Maintainer: Debian Curry Maintainers Uploaders: Mike Gabriel , Michael Hanus , Debian Haskell Group Priority: optional Section: haskell Build-Depends: debhelper (>= 9) , dpkg-dev (>= 1.16.1.1~) , haskell-devscripts (>= 0.8) , cdbs , ghc , ghc-prof , libghc-extra-dev (>= 1.4.6), , libghc-extra-prof (>= 1.4.6), , libghc-mtl-dev , libghc-mtl-prof , libghc-parsec3-dev, , libghc-parsec3-prof, , libghc-syb-dev (>= 0.3) , libghc-syb-prof (>= 0.3) , libghc-transformers-dev , libghc-transformers-prof Build-Depends-Indep: ghc-doc , libghc-extra-doc (>= 1.4.6), , libghc-mtl-doc , libghc-syb-doc (>= 0.3) , libghc-transformers-doc Homepage: https://git.ps.informatik.uni-kiel.de/curry/curry-base Vcs-Browser: https://anonscm.debian.org/git/pkg-curry/curry-base.git Vcs-Git: https://anonscm.debian.org/git/pkg-curry/curry-base.git Standards-Version: 4.1.1 Package: libghc-curry-base-dev Architecture: any Depends: ${shlibs:Depends} , ${haskell:Depends} , ${misc:Depends} Recommends: ${haskell:Recommends} Suggests: ${haskell:Suggests} Conflicts: ${haskell:Conflicts} Provides: ${haskell:Provides} Replaces: ${haskell:Replaces} Description: Functions for manipulating Curry programs This package serves as a foundation for Curry compilers. It defines the intermediate language formats FlatCurry and ExtendedFlat. Additionally, it provides functionality for the smooth integration of compiler frontends and backends. . This package provides a library for the Haskell programming language. See http:///www.haskell.org/ for more information on Haskell. Package: libghc-curry-base-prof Architecture: any Depends: ${shlibs:Depends} , ${haskell:Depends} , ${misc:Depends} Recommends: ${haskell:Recommends} Suggests: ${haskell:Suggests} Conflicts: ${haskell:Conflicts} Provides: ${haskell:Provides} Replaces: ${haskell:Replaces} Description: Functions for manipulating Curry programs; profiling libraries This package serves as a foundation for Curry compilers. It defines the intermediate language formats FlatCurry and ExtendedFlat. Additionally, it provides functionality for the smooth integration of compiler frontends and backends. . This package provides a library for the Haskell programming language, compiled for profiling. See http:///www.haskell.org/ for more information on Haskell. Package: libghc-curry-base-doc Architecture: all Section: doc Depends: ${shlibs:Depends} , ${haskell:Depends} , ${misc:Depends} Recommends: ${haskell:Recommends} Suggests: ${haskell:Suggests} Conflicts: ${haskell:Conflicts} Provides: ${haskell:Provides} Replaces: ${haskell:Replaces} Description: Functions for manipulating Curry programs; documentation This package serves as a foundation for Curry compilers. It defines the intermediate language formats FlatCurry and ExtendedFlat. Additionally, it provides functionality for the smooth integration of compiler frontends and backends. . This package provides the documentation for a library for the Haskell programming language. See http:///www.haskell.org/ for more information on Haskell. curry-base-v1.1.1/debian/copyright000066400000000000000000000146741347771173600171650ustar00rootroot00000000000000Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ Upstream-Name: curry-base Upstream-Contact: Michael Hanus Source: https://git.ps.informatik.uni-kiel.de/curry/curry-base Files: src/Curry/Base/Monad.hs Copyright: 2014 - 2016, Björn Peemöller License: BSD-3-clause Files: src/Curry/FlatCurry/Goodies.hs Copyright: 2006, Sebastian Fischer 2011, Björn Peemöller License: BSD-3-clause Files: src/Curry/Base/Ident.hs Copyright: 1999 - 2004, Wolfgang Lux 2011 - 2013, Björn Peemöller 2016, Finn Teegen License: BSD-3-clause Files: src/Curry/FlatCurry.hs Copyright: 2014, Björn Peemöller License: BSD-3-clause Files: src/Curry/Syntax/Utils.hs Copyright: 1999 - 2004, Wolfgang Lux 2005, Martin Engelke 2011 - 2014, Björn Peemöller 2015, Jan Tikovsky License: BSD-3-clause Files: src/Curry/Base/Message.hs Copyright: 2009, Holger Siegel 2012 - 2015, Björn Peemöller License: BSD-3-clause Files: src/Curry/AbstractCurry/Type.hs Copyright: 2004, Michael Hanus 2005, Martin Engelke 2015, Björn Peemöller 2016, Finn Teegen License: BSD-3-clause Files: src/Curry/AbstractCurry/Files.hs Copyright: 2004, Michael Hanus 2005, Martin Engelke 2014, Björn Peemöller 2016, Finn Teegen License: BSD-3-clause Files: src/Curry/Files/Filenames.hs Copyright: 2009, Holger Siegel 2013 - 2014, Björn Peemöller License: BSD-3-clause Files: src/Curry/Base/Position.hs Copyright: , Wolfgang Lux License: BSD-3-clause Files: src/Curry/FlatCurry/Files.hs Copyright: 2014, Björn Peemöller 2017, Finn Teegen License: BSD-3-clause Files: src/Curry/Base/LLParseComb.hs Copyright: 1999-2004, Wolfgang Lux 2016, Jan Tikovsky License: BSD-3-clause Files: src/Curry/AbstractCurry.hs Copyright: 2004, Michael Hanus 2005, Martin Engelke 2013, Björn Peemöller License: BSD-3-clause Files: src/Curry/Base/Span.hs Copyright: 2016, Jan Tikovsky 2016, Finn Teegen License: BSD-3-clause Files: src/Curry/Syntax/ShowModule.hs Copyright: 2008, Sebastian Fischer 2011 - 2015, Björn Peemöller 2016, Finn Teegen License: BSD-3-clause Files: src/Curry/Syntax/Lexer.hs Copyright: 1999 - 2004, Wolfgang Lux 2005, Martin Engelke 2011 - 2013, Björn Peemöller 2016, Jan Tikovsky 2016, Finn Teegen License: BSD-3-clause Files: src/Curry/Syntax/Parser.hs Copyright: 1999 - 2004, Wolfgang Lux 2005, Martin Engelke 2011 - 2015, Björn Peemöller 2016 - 2017, Finn Teegen License: BSD-3-clause Files: src/Curry/Syntax/Pretty.hs Copyright: 1999 - 2004, Wolfgang Lux 2005, Martin Engelke 2011 - 2015, Björn Peemöller 2016, Finn Teegen License: BSD-3-clause Files: src/Curry/Syntax/Type.hs Copyright: 1999 - 2004, Wolfgang Lux 2005, Martin Engelke 2011 - 2015, Björn Peemöller 2014, Jan Rasmus Tikovsky License: BSD-3-clause Files: src/Curry/Base/LexComb.hs Copyright: 1999 - 2004, Wolfgang Lux 2012 - 2013, Björn Peemöller 2016, Jan Tikovsky License: BSD-3-clause Files: src/Curry/Syntax.hs Copyright: 2009, Holger Siegel 2011 - 2013, Björn Peemöller 2016, Finn Teegen 2016, Jan Tikovsky License: BSD-3-clause Files: src/Curry/FlatCurry/Pretty.hs Copyright: 2015, Björn Peemöller License: BSD-3-clause Files: src/Curry/Files/Unlit.hs Copyright: 2009, Holger Siegel 2012 - 2014, Björn Peemöller License: BSD-3-clause Files: src/Curry/Syntax/InterfaceEquivalence.hs Copyright: 2000 - 2007, Wolfgang Lux 2014 - 2015, Björn Peemöller 2014, Jan Tikovsky License: BSD-3-clause Files: src/Curry/Syntax/Extension.hs Copyright: 2013 - 2014, Björn Peemöller 2016, Finn Teegen License: BSD-3-clause Files: src/Curry/FlatCurry/Type.hs Copyright: 2003, Michael Hanus 2004, Martin Engelke 2005, Bernd Brassel License: BSD-3-clause Files: src/Curry/Files/PathUtils.hs Copyright: 1999 - 2003, Wolfgang Lux 2011 - 2014, Björn Peemöller 2017, Finn teegen License: BSD-3-clause Files: src/Curry/Base/Pretty.hs Copyright: 2013 - 2014, Björn Peemöller License: BSD-3-clause Files: util/canonfint.hs Copyright: 2016, Björn Peemöller License: BSD-3-clause Files: src/Curry/CondCompile/Parser.hs src/Curry/CondCompile/Transform.hs src/Curry/CondCompile/Type.hs Copyright: 2017, Kai-Oliver Prott 2017, Finn Teegen License: BSD-3-clause Files: src/Curry/FlatCurry/Annotated/Goodies.hs src/Curry/FlatCurry/Annotated/Type.hs src/Curry/FlatCurry/Annotated/Typing.hs Copyright: 2016-2017, Finn Teegen 2017, Finn Teegen License: BSD-3-clause Files: src/Curry/FlatCurry/InterfaceEquivalence.hs Copyright: 2006, Martin Engelke 2011-2014, Björn Peemöller 2014, Jan Tikovsky License: BSD-3-clause Files: test/HaskellRecords.curry test/TestBase.hs test/Pragmas.curry util/lex.hs util/parse.hs .gitignore CHANGELOG.md Setup.hs curry-base.cabal overview.md Copyright: 1998-2004, Wolfgang Lux 2005-2016, Michael Hanus License: BSD-3-clause Comment: Assuming copyright information as found in LICENSE file. Files: debian/* Copyright: 2016, Mike Gabriel License: BSD-3-clause License: BSD-3-clause Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: . - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. . - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. . - None of the names of the copyright holders and contributors may be used to endorse or promote products derived from this software without specific prior written permission. . THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. curry-base-v1.1.1/debian/rules000077500000000000000000000005761347771173600163060ustar00rootroot00000000000000#!/usr/bin/make -f DEB_CABAL_PACKAGE = curry-base DEB_DEFAULT_COMPILER = ghc export DEB_BUILD_MAINT_OPTIONS = hardening=+all DPKG_EXPORT_BUILDFLAGS = 1 include /usr/share/dpkg/buildflags.mk include /usr/share/cdbs/1/rules/debhelper.mk include /usr/share/cdbs/1/class/hlibrary.mk get-orig-source: uscan --noconf --force-download --rename --download-current-version --destdir=.. curry-base-v1.1.1/debian/source/000077500000000000000000000000001347771173600165165ustar00rootroot00000000000000curry-base-v1.1.1/debian/source/format000066400000000000000000000000031347771173600177220ustar00rootroot000000000000001.0curry-base-v1.1.1/overview.md000066400000000000000000000030041347771173600161610ustar00rootroot00000000000000Module overview of package `curry-base` ======================================= * `Currry.AbstractCurry`: Definition of AbstractCurry * `Curry.Base` * `.Ident` : Identifier (unqualified, qualified, module identifier) * `.LexComb` : CPS lexer combinators * `.LLParseComb` : CPS parser combinators * `.Message` : Error/Warning monad * `.Position` : source code position * `Curry.ExtendedFlat` * `.CurryArithmetics` : * `.EraseTypes` : * `.Goodies` : * `.InterfaceEquivalence`: Check the equality of two FlatCurry interfaces * `.LiftLetrec` : * `.MonadicGoodies` : * `.Type` : Definition of ExtendedFlatCurry * `.TypeInference` : * `.UnMutual` : * `Curry.Files` * `.Filenames`: Curry file extensions and file name manipulation * `.PathUtils`: lookup/read/write of Curry files-Dateien * `.Unlit` : unliteration of literate Curry * `Curry.FlatCurry` * `.Goodies`: Auxiliary functions for working with FlatCurry * `.Pretty` : Pretty printer for FlatCurry * `.Type` : Definition of FlatCurry * `Curry.Syntax`: Curry AST and related functions * `.Lexer` : Lexer for Curry * `.Parser` : Parser for Curry * `.Pretty` : Pretty-Printer for Curry * `.ShowModule`: artificial Show instance * `.Type` : Definition of the abstract syntax tree * `.Utils` : Auxiliary functions curry-base-v1.1.1/src/000077500000000000000000000000001347771173600145635ustar00rootroot00000000000000curry-base-v1.1.1/src/Curry/000077500000000000000000000000001347771173600156675ustar00rootroot00000000000000curry-base-v1.1.1/src/Curry/AbstractCurry.hs000066400000000000000000000020121347771173600210060ustar00rootroot00000000000000{- | 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 curry-base-v1.1.1/src/Curry/AbstractCurry/000077500000000000000000000000001347771173600204575ustar00rootroot00000000000000curry-base-v1.1.1/src/Curry/AbstractCurry/Files.hs000066400000000000000000000041321347771173600220550ustar00rootroot00000000000000{- | 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" curry-base-v1.1.1/src/Curry/AbstractCurry/Type.hs000066400000000000000000000276161347771173600217500ustar00rootroot00000000000000{- | 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 2.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) -- TODO: Remove context and existential quantified type variables. -- |A constructor declaration consists of a list of existentially -- quantified type variables, a context, 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 [CTVarIName] CContext QName CVisibility [CTypeExpr] | CRecord [CTVarIName] CContext 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) curry-base-v1.1.1/src/Curry/Base/000077500000000000000000000000001347771173600165415ustar00rootroot00000000000000curry-base-v1.1.1/src/Curry/Base/Ident.hs000066400000000000000000000735161347771173600201540ustar00rootroot00000000000000{- | 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 -- ** 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 , 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 -- ** 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 -- * Extended functionality -- ** Functional patterns , fpSelectorId, isFpSelectorId, isQualFpSelectorId -- ** Records , recSelectorId, qualRecSelectorId, recUpdateId, qualRecUpdateId , recordExt, recordExtId, isRecordExtId, fromRecordExtId , labelExt, labelExtId, isLabelExtId, fromLabelExtId , renameLabel, mkLabelIdent ) where #if __GLASGOW_HASKELL__ >= 804 import Prelude hiding ((<>)) #endif import Data.Char (isAlpha, isAlphaNum) import Data.Function (on) import Data.List (intercalate, isInfixOf, isPrefixOf) import Data.Maybe (isJust, fromMaybe) 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 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 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 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 (getSpanInfo 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" -- --------------------------------------------------------------------------- -- 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 "." -- | '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 -- --------------------------------------------------------------------------- -- 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 -- | '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) curry-base-v1.1.1/src/Curry/Base/LLParseComb.hs000066400000000000000000000362521347771173600212100ustar00rootroot00000000000000{- | 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 (flip seqPP p2) ps1) Parser (Just p1) ps1 <*> ~p2@(Parser e2 ps2) = Parser (fmap (seqEE p1) e2) (Map.union (fmap (flip 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 = const 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 = const 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 = const () <$> 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 curry-base-v1.1.1/src/Curry/Base/LexComb.hs000066400000000000000000000150051347771173600204270ustar00rootroot00000000000000{- | 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, span2Pos , 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` \_ -> p2 -- |Fail to lex on a 'Span', given an error message failP :: Span -> String -> P a failP sp msg _ _ _ _ = failMessageAt (span2Pos 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 (span2Pos 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 (span2Pos 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 curry-base-v1.1.1/src/Curry/Base/Message.hs000066400000000000000000000052041347771173600204620ustar00rootroot00000000000000{- | 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, showWarning, showError , ppMessage, ppWarning, ppError, ppMessages ) where #if __GLASGOW_HASKELL__ >= 804 import Prelude hiding ((<>)) #endif import Data.Maybe (fromMaybe) import Curry.Base.Position import Curry.Base.Pretty -- --------------------------------------------------------------------------- -- Message -- --------------------------------------------------------------------------- -- |Compiler message data Message = Message { msgPos :: Maybe Position -- ^ optional source code position , msgTxt :: Doc -- ^ the message itself } instance Eq Message where Message p1 t1 == Message p2 t2 = (p1, show t1) == (p2, show t2) instance Ord Message where Message p1 t1 `compare` Message p2 t2 = compare (p1, show t1) (p2, show t2) instance Show Message where showsPrec _ = shows . ppMessage instance HasPosition Message where getPosition = fromMaybe NoPos . msgPos setPosition p m = m { msgPos = Just p } instance Pretty Message where pPrint = ppMessage -- |Construct a 'Message' without a 'Position' message :: Doc -> Message message = Message Nothing -- |Construct a message from an entity with a 'Position' and a text posMessage :: HasPosition p => p -> Doc -> Message posMessage p msg = Message (Just $ getPosition p) 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 mbPos txt) = posPP <+> keyPP $$ nest 4 txt where posPP = maybe empty ((<> colon) . ppPosition) mbPos 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 curry-base-v1.1.1/src/Curry/Base/Monad.hs000066400000000000000000000067441347771173600201460ustar00rootroot00000000000000{- | 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, posMessage) import Curry.Base.Position 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 position and a `String` indicating -- the cause of failure. failMessageAt :: Monad m => Position -> String -> CYT m a failMessageAt pos s = failMessage $ posMessage pos $ 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 => Position -> String -> CYT m () warnMessageAt pos s = warnMessage $ posMessage pos $ 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)) curry-base-v1.1.1/src/Curry/Base/Position.hs000066400000000000000000000060331347771173600207030ustar00rootroot00000000000000{- | 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. -} {-# LANGUAGE CPP #-} module Curry.Base.Position ( -- * Source code position HasPosition (..), Position (..), (@>) , showPosition, ppPosition, ppLine, showLine , first, next, incr, tab, tabWidth, nl ) where #if __GLASGOW_HASKELL__ >= 804 import Prelude hiding ((<>)) #endif 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 -- |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 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 curry-base-v1.1.1/src/Curry/Base/Pretty.hs000066400000000000000000000141651347771173600203730ustar00rootroot00000000000000{- | 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 #if __GLASGOW_HASKELL__ >= 804 import Prelude hiding ((<>)) #endif 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 pp = maybe empty pp -- | 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 _ xs = pPrintList xs -- | 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] curry-base-v1.1.1/src/Curry/Base/Span.hs000066400000000000000000000070431347771173600200020ustar00rootroot00000000000000{- | 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. -} {-# LANGUAGE CPP #-} module Curry.Base.Span where #if __GLASGOW_HASKELL__ >= 804 import Prelude hiding ((<>)) #endif 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 -- |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 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 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 curry-base-v1.1.1/src/Curry/Base/SpanInfo.hs000066400000000000000000000056201347771173600206150ustar00rootroot00000000000000{- | 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(..), HasSpanInfo(..) , fromSrcSpan, fromSrcSpanBoth, getSrcSpan, setSrcSpan , fromSrcInfoPoints, getSrcInfoPoints, setSrcInfoPoints , getStartPosition, getSrcSpanEnd, setStartPosition, setEndPosition , spanInfo2Pos ) where import Curry.Base.Position import Curry.Base.Span data SpanInfo = SpanInfo { srcSpan :: Span , srcInfoPoints :: [Span] } | NoSpanInfo deriving (Eq, Read, Show) class HasPosition a => HasSpanInfo a where getSpanInfo :: a -> SpanInfo setSpanInfo :: SpanInfo -> a -> a updateEndPos :: a -> a updateEndPos = id instance HasSpanInfo SpanInfo where getSpanInfo = id setSpanInfo = const instance HasPosition SpanInfo where getPosition = getStartPosition setPosition = setStartPosition 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 curry-base-v1.1.1/src/Curry/CondCompile/000077500000000000000000000000001347771173600200635ustar00rootroot00000000000000curry-base-v1.1.1/src/Curry/CondCompile/Parser.hs000066400000000000000000000057001347771173600216550ustar00rootroot00000000000000{- | 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 curry-base-v1.1.1/src/Curry/CondCompile/Transform.hs000066400000000000000000000074441347771173600224030ustar00rootroot00000000000000{- | 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 "" curry-base-v1.1.1/src/Curry/CondCompile/Type.hs000066400000000000000000000045561347771173600213520ustar00rootroot00000000000000{- | 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 ">=" curry-base-v1.1.1/src/Curry/Files/000077500000000000000000000000001347771173600167315ustar00rootroot00000000000000curry-base-v1.1.1/src/Curry/Files/Filenames.hs000066400000000000000000000213371347771173600211760ustar00rootroot00000000000000{- | 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 , currySubdir, hasCurrySubdir, addCurrySubdir, addCurrySubdirModule , ensureCurrySubdir -- * File name extensions -- ** Curry files , curryExt, lcurryExt, icurryExt -- ** FlatCurry files , typedFlatExt, flatExt, flatIntExt -- ** AbstractCurry files , acyExt, uacyExt -- ** Source and object files , sourceRepExt, sourceExts, moduleExts -- * Functions for computing file names , interfName, typedFlatName, typeAnnFlatName, 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 currySubdir :: String currySubdir = ".curry" -- |Does the given 'FilePath' contain the 'currySubdir' -- as its last directory component? hasCurrySubdir :: FilePath -> Bool hasCurrySubdir f = not (null dirs) && last dirs == currySubdir where dirs = splitDirectories $ takeDirectory f -- |Add the 'currySubdir' to the given 'FilePath' if the flag is 'True' and -- the path does not already contain it, otherwise leave the path untouched. addCurrySubdir :: Bool -> FilePath -> FilePath addCurrySubdir b fn = if b then ensureCurrySubdir fn else fn -- |Add the 'currySubdir' to the given 'FilePath' if the flag is 'True' and -- the path does not already contain it, otherwise leave the path untouched. addCurrySubdirModule :: Bool -> ModuleIdent -> FilePath -> FilePath addCurrySubdirModule b m fn | b = let (pre, file) = splitModuleFileName m fn in ensureCurrySubdir pre file | otherwise = fn -- | Ensure that the 'currySubdir' is the last component of the -- directory structure of the given 'FilePath'. If the 'FilePath' already -- contains the sub-directory, it remains unchanged. ensureCurrySubdir :: FilePath -- ^ original 'FilePath' -> FilePath -- ^ new 'FilePath' ensureCurrySubdir fn = normalise $ addSub (splitDirectories d) f where (d, f) = splitFileName fn addSub dirs | null dirs = currySubdir | last dirs == currySubdir = joinPath dirs | otherwise = joinPath dirs currySubdir -- ----------------------------------------------------------------------------- -- 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 typeAnnFlatExt :: String typeAnnFlatExt = ".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 typeAnnFlatName :: FilePath -> FilePath typeAnnFlatName = replaceExtensionWith typeAnnFlatExt -- |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 curry-base-v1.1.1/src/Curry/Files/PathUtils.hs000066400000000000000000000152251347771173600212070ustar00rootroot00000000000000{- | 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 , addVersion , checkVersion ) where import qualified Control.Exception as C (IOException, handle) import Control.Monad (liftM) import Data.List (isPrefixOf, isSuffixOf) 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 -- | 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) curry-base-v1.1.1/src/Curry/Files/Unlit.hs000066400000000000000000000114731347771173600203660ustar00rootroot00000000000000{-# 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.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 (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 (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 (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 (Position f l 1) msg where msg = concat [ "When reading literate source: " , "Spurious '" ++ cause ++ "'." ] curry-base-v1.1.1/src/Curry/FlatCurry.hs000066400000000000000000000010111347771173600201270ustar00rootroot00000000000000{- | 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 curry-base-v1.1.1/src/Curry/FlatCurry/000077500000000000000000000000001347771173600176025ustar00rootroot00000000000000curry-base-v1.1.1/src/Curry/FlatCurry/Annotated/000077500000000000000000000000001347771173600215175ustar00rootroot00000000000000curry-base-v1.1.1/src/Curry/FlatCurry/Annotated/Goodies.hs000066400000000000000000000560471347771173600234600ustar00rootroot00000000000000{- | 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 , 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 pattern _ (APattern a name args) = pattern a name args trAPattern _ lpattern (ALPattern a l) = lpattern 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 pattern lpattern where pattern a name args = APattern (fannot a) (fn name) (fa args) lpattern 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 curry-base-v1.1.1/src/Curry/FlatCurry/Annotated/Type.hs000066400000000000000000000037771347771173600230120ustar00rootroot00000000000000{- | 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 Curry.FlatCurry.Typeable import Curry.FlatCurry.Type ( QName, VarIndex, Visibility (..), TVarIndex , TypeDecl (..), OpDecl (..), Fixity (..) , TypeExpr (..), ConsDecl (..) , 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 curry-base-v1.1.1/src/Curry/FlatCurry/Files.hs000066400000000000000000000046071347771173600212070ustar00rootroot00000000000000{- | 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 ) where import Control.Monad (liftM) import Data.Char (isSpace) import Curry.Files.Filenames (typedFlatName, flatName, flatIntName) import Curry.Files.PathUtils (writeModule, 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 = liftM (liftM (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 curry-base-v1.1.1/src/Curry/FlatCurry/Goodies.hs000066400000000000000000000743641347771173600215450ustar00rootroot00000000000000{- | 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 -> [TVarIndex] -> [ConsDecl] -> a) -> (QName -> Visibility -> [TVarIndex] -> TypeExpr -> 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 -- |get name of type declaration typeName :: TypeDecl -> QName typeName = trType (\name _ _ _ -> name) (\name _ _ _ -> name) -- |get visibility of type declaration typeVisibility :: TypeDecl -> Visibility typeVisibility = trType (\_ vis _ _ -> vis) (\_ vis _ _ -> vis) -- |get type parameters of type declaration typeParams :: TypeDecl -> [TVarIndex] typeParams = trType (\_ _ params _ -> params) (\_ _ params _ -> params) -- |get constructor declarations from type declaration typeConsDecls :: TypeDecl -> [ConsDecl] typeConsDecls = trType (\_ _ _ cs -> cs) (error "Curry.FlatCurry.Goodies: type synonym") -- |get synonym of type declaration typeSyn :: TypeDecl -> TypeExpr typeSyn = trType undefined (\_ _ _ syn -> syn) -- |is type declaration a type synonym? isTypeSyn :: TypeDecl -> Bool isTypeSyn = trType (\_ _ _ _ -> False) (\_ _ _ _ -> True) -- | is type declaration declaring a regular type? isDataTypeDecl :: TypeDecl -> Bool isDataTypeDecl = trType (\_ _ _ cs -> not (null cs)) (\_ _ _ _ -> False) -- | is type declaration declaring an external type? isExternalType :: TypeDecl -> Bool isExternalType = trType (\_ _ _ cs -> null cs) (\_ _ _ _ -> False) -- |Is the 'TypeDecl' public? isPublicType :: TypeDecl -> Bool isPublicType = (== Public) . typeVisibility -- Update Operations -- |update type declaration updType :: (QName -> QName) -> (Visibility -> Visibility) -> ([TVarIndex] -> [TVarIndex]) -> ([ConsDecl] -> [ConsDecl]) -> (TypeExpr -> TypeExpr) -> TypeDecl -> TypeDecl updType fn fv fp fc fs = trType typ typesyn where typ name vis params cs = Type (fn name) (fv vis) (fp params) (fc cs) 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 -- |update visibility of type declaration updTypeVisibility :: Update TypeDecl Visibility updTypeVisibility f = updType id f id id id -- |update type parameters of type declaration updTypeParams :: Update TypeDecl [TVarIndex] updTypeParams f = updType id id f id id -- |update constructor declarations of type declaration updTypeConsDecls :: Update TypeDecl [ConsDecl] updTypeConsDecls f = updType id id id f id -- |update synonym of type declaration updTypeSynonym :: Update TypeDecl TypeExpr updTypeSynonym = updType 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)) (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)) -- 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) -> ([TVarIndex] -> a -> a) -> TypeExpr -> a trTypeExpr tvar _ _ _ (TVar n) = tvar n 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 :: ([TVarIndex] -> 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 (:[]) (const concat) (++) (++) -- |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) curry-base-v1.1.1/src/Curry/FlatCurry/InterfaceEquivalence.hs000066400000000000000000000033531347771173600242240ustar00rootroot00000000000000{- | 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 (=~=) = (==) curry-base-v1.1.1/src/Curry/FlatCurry/Pretty.hs000066400000000000000000000163661347771173600214410ustar00rootroot00000000000000{- | 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. -} module Curry.FlatCurry.Pretty ( ppProg, ppHeader, ppExports, ppImport, ppTypeDecl, ppTypeExpr , ppFuncDecl, ppExpr, ppLiteral, ppOpDecl ) where import Data.Char (ord) import Curry.Base.Pretty import Curry.FlatCurry.Type -- |pretty-print a FlatCurry module ppProg :: Prog -> Doc ppProg (Prog m is ts fs os) = sepByBlankLine [ ppHeader m ts fs , vcat (map ppImport is) , vcat (map ppOpDecl os) , sepByBlankLine (map ppTypeDecl ts) , sepByBlankLine (map ppFuncDecl fs) ] -- |pretty-print the module header 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) -- |pretty-print a type export 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 (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 -- |pretty-print a operator fixity declaration ppOpDecl :: OpDecl -> Doc ppOpDecl (Op qn fix n) = ppFixity fix <+> integer n <+> ppInfixOp qn -- |pretty-print the associativity keyword ppFixity :: Fixity -> Doc ppFixity InfixOp = text "infix" ppFixity InfixlOp = text "infixl" ppFixity InfixrOp = text "infixr" -- |pretty-print a type declaration ppTypeDecl :: TypeDecl -> Doc ppTypeDecl (Type qn _ vs cs) = text "data" <+> ppQName qn <+> hsep (map ppTVarIndex vs) $+$ ppConsDecls cs ppTypeDecl (TypeSyn qn _ vs ty) = text "type" <+> ppQName qn <+> hsep (map ppTVarIndex vs) <+> equals <+> ppTypeExpr 0 ty -- |pretty-print the constructor declarations ppConsDecls :: [ConsDecl] -> Doc ppConsDecls cs = indent $ vcat $ zipWith (<+>) (equals : repeat (char '|')) (map ppConsDecl cs) -- |pretty print a single constructor ppConsDecl :: ConsDecl -> Doc ppConsDecl (Cons qn _ _ tys) = fsep $ ppPrefixOp qn : map (ppTypeExpr 2) tys -- |pretty-print a type expression ppTypeExpr :: Int -> TypeExpr -> Doc ppTypeExpr _ (TVar v) = ppTVarIndex v ppTypeExpr p (FuncType ty1 ty2) = parenIf (p > 0) $ fsep [ppTypeExpr 1 ty1, rarrow, ppTypeExpr 0 ty2] ppTypeExpr p (TCons qn tys) = parenIf (p > 1 && not (null tys)) $ fsep (ppPrefixOp qn : map (ppTypeExpr 2) tys) ppTypeExpr p (ForallType vs ty) | null vs = ppTypeExpr p ty | otherwise = parenIf (p > 0) $ ppQuantifiedVars vs <+> ppTypeExpr 0 ty -- |pretty-print explicitly quantified type variables ppQuantifiedVars :: [TVarIndex] -> Doc ppQuantifiedVars vs | null vs = empty | otherwise = text "forall" <+> hsep (map ppTVarIndex vs) <+> char '.' -- |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'] ] -- |pretty-print a function declaration ppFuncDecl :: FuncDecl -> Doc ppFuncDecl (Func qn _ _ ty r) = hsep [ppPrefixOp qn, text "::", ppTypeExpr 0 ty] $+$ ppPrefixOp qn <+> ppRule r -- |pretty-print a function rule ppRule :: Rule -> Doc ppRule (Rule vs e) = fsep (map ppVarIndex vs) <+> equals <+> indent (ppExpr 0 e) ppRule (External _) = text "external" -- |pretty-print an expression ppExpr :: Int -> Expr -> Doc ppExpr _ (Var v) = ppVarIndex v ppExpr _ (Lit l) = ppLiteral l ppExpr p (Comb _ qn es) = ppComb p qn es ppExpr p (Free vs e) | null vs = ppExpr p e | otherwise = parenIf (p > 0) $ sep [ text "let" <+> list (map ppVarIndex vs) <+> text "free" , text "in" <+> ppExpr 0 e ] ppExpr p (Let ds e) = parenIf (p > 0) $ sep [text "let" <+> ppDecls ds, text "in" <+> ppExpr 0 e] ppExpr p (Or e1 e2) = parenIf (p > 0) $ ppExpr 1 e1 <+> text "?" <+> ppExpr 1 e2 ppExpr p (Case ct e bs) = parenIf (p > 0) $ ppCaseType ct <+> ppExpr 0 e <+> text "of" $$ indent (vcat (map ppBranch bs)) ppExpr p (Typed e ty) = parenIf (p > 0) $ ppExpr 0 e <+> text "::" <+> ppTypeExpr 0 ty -- |pretty-print a variable ppVarIndex :: VarIndex -> Doc ppVarIndex i = text $ 'v' : show i -- |pretty-print a literal ppLiteral :: Literal -> Doc ppLiteral (Intc i) = integer i ppLiteral (Floatc f) = double f ppLiteral (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 [ppExpr 1 e1, ppInfixOp qn, ppExpr 1 e2] ppComb p qn es = parenIf (p > 0) $ hsep (ppPrefixOp qn : map (ppExpr 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 <+> ppExpr 0 e -- |pretty-print the type of a case expression ppCaseType :: CaseType -> Doc ppCaseType Rigid = text "case" ppCaseType Flex = text "fcase" -- |pretty-print a case branch ppBranch :: BranchExpr -> Doc ppBranch (Branch p e) = ppPattern p <+> rarrow <+> ppExpr 0 e -- |pretty-print a pattern ppPattern :: Pattern -> Doc ppPattern (Pattern c [v1,v2]) | isInfixOp c = ppVarIndex v1 <+> ppInfixOp c <+> ppVarIndex v2 ppPattern (Pattern c vs) = fsep (ppPrefixOp c : map ppVarIndex vs) ppPattern (LPattern l) = ppLiteral 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 curry-base-v1.1.1/src/Curry/FlatCurry/Type.hs000066400000000000000000000236721347771173600210710ustar00rootroot00000000000000{- | 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 -- * Data types for FlatCurry , Visibility (..), Prog (..), TypeDecl (..), TypeExpr (..) , ConsDecl (..), OpDecl (..), Fixity (..) , FuncDecl (..), Rule (..), Expr (..), Literal (..) , CombType (..), CaseType (..), BranchExpr (..), Pattern (..) ) where -- --------------------------------------------------------------------------- -- 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 [TVarIndex] [ConsDecl] | TypeSyn QName Visibility [TVarIndex] TypeExpr deriving (Eq, Read, Show) -- |Type variables are represented by @(TVar i)@ where @i@ is a -- type variable index. type TVarIndex = Int -- |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) -- |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 [TVarIndex] TypeExpr -- ^ forall type deriving (Eq, 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","if_then_else") [e1,e2,e3])@ -- -- 2.Higher order applications are represented as calls to the (external) -- function @apply@. For instance, the rule -- -- @app f x = f x@ -- -- is represented as -- -- @(Rule [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1]))@ -- -- 3.A conditional rule is represented as a call to an external function -- @cond@ where the first argument is the condition (a constraint). -- -- For instance, the rule -- -- @equal2 x | x=:=2 = success@ -- -- is represented as -- -- @ -- (Rule [0] -- (Comb FuncCall ("Prelude","cond") -- [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)], -- Comb FuncCall ("Prelude","success") []])) -- @ -- -- 4.Functions with evaluation annotation @choice@ are represented -- by a rule whose right-hand side is enclosed in a call to the -- external function @Prelude.commit@. -- Furthermore, all rules of the original definition must be -- represented by conditional expressions (i.e., (cond [c,e])) -- after pattern matching. -- -- Example: -- -- @ -- m eval choice -- m [] y = y -- m x [] = x -- @ -- -- is translated into (note that the conditional branches can be also -- wrapped with Free declarations in general): -- -- @ -- Rule [0,1] -- (Comb FuncCall ("Prelude","commit") -- [Or (Case Rigid (Var 0) -- [(Pattern ("Prelude","[]") [] -- (Comb FuncCall ("Prelude","cond") -- [Comb FuncCall ("Prelude","success") [], -- Var 1]))] ) -- (Case Rigid (Var 1) -- [(Pattern ("Prelude","[]") [] -- (Comb FuncCall ("Prelude","cond") -- [Comb FuncCall ("Prelude","success") [], -- Var 0]))] )]) -- @ -- -- Operational meaning of @(Prelude.commit e)@: -- evaluate @e@ with local search spaces and commit to the first -- @(Comb FuncCall ("Prelude","cond") [c,ge])@ in @e@ whose constraint @c@ -- is satisfied 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) curry-base-v1.1.1/src/Curry/FlatCurry/Typeable.hs000066400000000000000000000010321347771173600216770ustar00rootroot00000000000000{- | 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 curry-base-v1.1.1/src/Curry/FlatCurry/Typed/000077500000000000000000000000001347771173600206675ustar00rootroot00000000000000curry-base-v1.1.1/src/Curry/FlatCurry/Typed/Goodies.hs000066400000000000000000000542221347771173600226210ustar00rootroot00000000000000{- | 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 , 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 pattern _ (TPattern ty name args) = pattern ty name args trTPattern _ lpattern (TLPattern a l) = lpattern 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 curry-base-v1.1.1/src/Curry/FlatCurry/Typed/Type.hs000066400000000000000000000050701347771173600221460ustar00rootroot00000000000000{- | 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 Curry.FlatCurry.Typeable import Curry.FlatCurry.Type ( QName, VarIndex, Visibility (..), TVarIndex , TypeDecl (..), OpDecl (..), Fixity (..) , TypeExpr (..), ConsDecl (..) , 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 curry-base-v1.1.1/src/Curry/Syntax.hs000066400000000000000000000057211347771173600175160ustar00rootroot00000000000000{- | 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 , ppModule, ppInterface, ppIDecl , showModule ) where import Curry.Base.Monad (CYM) import Curry.Base.Span (Span) 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 (ppModule, ppInterface, ppIDecl) 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 curry-base-v1.1.1/src/Curry/Syntax/000077500000000000000000000000001347771173600171555ustar00rootroot00000000000000curry-base-v1.1.1/src/Curry/Syntax/Extension.hs000066400000000000000000000043711347771173600214720ustar00rootroot00000000000000{- | 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.Char (toUpper) import Curry.Base.Ident (Ident (..)) import Curry.Base.Position -- |Specified language extensions, either known or unknown. data Extension = KnownExtension Position KnownExtension -- ^ a known extension | UnknownExtension Position String -- ^ an unknown extension deriving (Eq, Read, Show) instance HasPosition Extension where getPosition (KnownExtension p _) = p getPosition (UnknownExtension p _) = p setPosition p (KnownExtension _ e) = KnownExtension p e setPosition p (UnknownExtension _ e) = UnknownExtension p e -- |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 (getPosition i) e _ -> UnknownExtension (getPosition 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) -- |Classifies a 'String' as a 'Tool' classifyTool :: String -> Tool classifyTool str = case reads (map toUpper str) of [(t, "")] -> t _ -> UnknownTool str curry-base-v1.1.1/src/Curry/Syntax/InterfaceEquivalence.hs000066400000000000000000000203751347771173600236020ustar00rootroot00000000000000{- | 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 curry-base-v1.1.1/src/Curry/Syntax/Lexer.hs000066400000000000000000001103141347771173600205700ustar00rootroot00000000000000{- | 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 "" -- --------------------------------------------------------------------------- -- 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 -- (_, []) -> fail p "Unterminated line comment" p [] (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 = suc sp (tok VSemicolon) sp s False ctxt | otherwise = lexToken suc fail sp s False ctxt where col = column (span2Pos sp) -- 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) 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 curry-base-v1.1.1/src/Curry/Syntax/Parser.hs000066400000000000000000001540131347771173600207510ustar00rootroot00000000000000{- | 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 (uncurry <$> moduleHeader <*> layout moduleDecls) lexer -- TODO position on prefix parsers? -- |Parse only pragmas of a 'Module' parsePragmas :: FilePath -> String -> CYM (Module ()) parsePragmas = prefixParser ((\ps sp -> setEndPosition NoPos (Module (SpanInfo sp []) ps mainMIdent Nothing [] [])) <$> modulePragmas <*> spanPosition) lexer -- |Parse a 'Module' header parseHeader :: FilePath -> String -> CYM (Module ()) parseHeader = prefixParser (moduleHeader <*> startLayout importDecls <*> succeed []) lexer where importDecls = many (importDecl <*-> many semicolon) -- |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 ([ImportDecl] -> [Decl b] -> Module b) moduleHeader = (\sp ps (m, es, inf) is ds -> updateEndPos (Module (SpanInfo sp inf) 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 ()]) moduleDecls = impDecl <$> importDecl <*> (semicolon <-*> moduleDecls `opt` ([], [])) <|> (,) [] <$> topDecls where impDecl i (is, ds) = (i:is ,ds) -- |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 ()] topDecls = topDecl `sepBy` 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 <*> spanPosition <*> localDecls where rhsExpr = mkSimpleRhs <$> spanPosition <*-> eq <*> expr <|> mkGuardedRhs <$> spanPosition <*> many1 (condExpr eq) mkSimpleRhs sp1 e sp2 ds = updateEndPos $ SimpleRhs (SpanInfo sp1 [sp2]) e ds mkGuardedRhs sp1 ce sp2 ds = updateEndPos $ GuardedRhs (SpanInfo sp1 [sp2]) ce ds whereClause :: Parser a Token [b] -> Parser a Token [b] whereClause decls = token KW_where <-*> layout decls `opt` [] localDecls :: Parser a Token [Decl ()] localDecls = whereClause valueDecls valueDecls :: Parser a Token [Decl ()] valueDecls = choice [infixDecl, valueDecl] `sepBy` semicolon 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 = (\(sp1, ss, cx, cls, tv) sp2 -> updateEndPos . ClassDecl (SpanInfo sp1 (sp1 : (ss ++ [sp2]))) cx cls tv) <$> classInstHead KW_class tycls clsvar <*> spanPosition <*> whereClause innerDecls where innerDecls = innerDecl `sepBy` semicolon --TODO: Refactor by left-factorization --TODO: Support infixDecl innerDecl = foldr1 (<|?>) [ spanPosition <**> (fun `sepBy1Sp` comma <**> typeSig) , spanPosition <**> funRule {-, infixDecl-} ] instanceDecl :: Parser a Token (Decl ()) instanceDecl = (\(sp1, ss, cx, qcls, inst) sp2 -> updateEndPos . InstanceDecl (SpanInfo sp1 (sp1 : (ss ++ [sp2]))) cx qcls inst) <$> classInstHead KW_instance qtycls type2 <*> spanPosition <*> whereClause innerDecls where innerDecls = (spanPosition <**> funRule) `sepBy` semicolon -- --------------------------------------------------------------------------- -- 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])) -- TODO: ??? 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 ::= 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 ::= '\'' '\'' -- | -- | -- | '"' '"' 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 p = setEndPosition (end (getSrcSpan idt)) p 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 ::= | | | 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 sp2 e = updateEndPos $ Let (SpanInfo sp1 [sp1, sp2]) ds e doExpr :: Parser a Token (Expression ()) doExpr = mkDo <$> tokenSpan KW_do <*> layout stmts where mkDo sp (stms, ex) = updateEndPos $ Do (SpanInfo sp [sp]) 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 `sepBy1` semicolon) where mkCase ct sp1 e sp2 = updateEndPos . Case (SpanInfo sp1 [sp1, sp2]) ct e 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 ()) stmts = stmt reqStmts optStmts reqStmts :: Parser a Token (Statement () -> ([Statement ()], Expression ())) reqStmts = (\ (sts, e) st -> (st : sts, e)) <$-> semicolon <*> stmts optStmts :: Parser a Token (Expression () -> ([Statement ()], Expression ())) optStmts = succeed mkStmtExpr <.> reqStmts `opt` (,) [] 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) = updateEndPos $ Let (SpanInfo sp2 [sp2, sp1]) ds e stmtDecl' (sp2, ds) = updateEndPos $ StmtDecl (SpanInfo sp2 [sp2]) 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 <*> spanPosition <*> localDecls where mkGoal sp1 ex sp2 ds = updateEndPos $ Goal (SpanInfo sp1 [sp2]) 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 -> Parser a Token b startLayout p = layoutOff <-*> leftBrace <-*> p <|> layoutOn <-*> p layout :: Parser a Token b -> Parser a Token b layout p = layoutOff <-*> braces p <|> layoutOn <-*> p <*-> (token VRightBrace <|> layoutEnd) -- --------------------------------------------------------------------------- -- 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 curry-base-v1.1.1/src/Curry/Syntax/Pretty.hs000066400000000000000000000443031347771173600210040ustar00rootroot00000000000000{- | 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. -} {-# LANGUAGE CPP #-} module Curry.Syntax.Pretty ( ppModule, ppInterface, ppIDecl, ppDecl, ppIdent, ppPattern, ppFieldPatt , ppExpr, ppOp, ppStmt, ppFieldExpr, ppQualTypeExpr, ppTypeExpr, ppKindExpr , ppAlt, ppQIdent, ppConstraint, ppInstanceType, ppConstr, ppNewConstr , ppFieldDecl, ppEquation, ppMIdent ) where #if __GLASGOW_HASKELL__ >= 804 import Prelude hiding ((<>)) #endif import Curry.Base.Ident import Curry.Base.Pretty import Curry.Syntax.Type import Curry.Syntax.Utils (opName) -- TODO use span infos -- |Pretty print a module ppModule :: Module a -> Doc ppModule (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 ppImportDecl is) where header = (vcat $ map ppModulePragma ps) $+$ text "module" <+> ppMIdent m <+> maybePP ppExportSpec es <+> text "where" ppModulePragma :: ModulePragma -> Doc ppModulePragma (LanguagePragma _ exts) = ppPragma "LANGUAGE" $ list $ map ppExtension exts ppModulePragma (OptionsPragma _ tool args) = ppPragma "OPTIONS" $ maybe empty ((text "_" <>) . ppTool) tool <+> text args ppPragma :: String -> Doc -> Doc ppPragma kw doc = text "{-#" <+> text kw <+> doc <+> text "#-}" ppExtension :: Extension -> Doc ppExtension (KnownExtension _ e) = text (show e) ppExtension (UnknownExtension _ e) = text e ppTool :: Tool -> Doc ppTool (UnknownTool t) = text t ppTool t = text (show t) ppExportSpec :: ExportSpec -> Doc ppExportSpec (Exporting _ es) = parenList (map ppExport es) ppExport :: Export -> Doc ppExport (Export _ x) = ppQIdent x ppExport (ExportTypeWith _ tc cs) = ppQIdent tc <> parenList (map ppIdent cs) ppExport (ExportTypeAll _ tc) = ppQIdent tc <> text "(..)" ppExport (ExportModule _ m) = text "module" <+> ppMIdent m ppImportDecl :: ImportDecl -> Doc ppImportDecl (ImportDecl _ m q asM is) = text "import" <+> ppQualified q <+> ppMIdent m <+> maybePP ppAs asM <+> maybePP ppImportSpec is where ppQualified q' = if q' then text "qualified" else empty ppAs m' = text "as" <+> ppMIdent m' ppImportSpec :: ImportSpec -> Doc ppImportSpec (Importing _ is) = parenList (map ppImport is) ppImportSpec (Hiding _ is) = text "hiding" <+> parenList (map ppImport is) ppImport :: Import -> Doc ppImport (Import _ x) = ppIdent x ppImport (ImportTypeWith _ tc cs) = ppIdent tc <> parenList (map ppIdent cs) ppImport (ImportTypeAll _ tc) = ppIdent tc <> text "(..)" ppBlock :: [Decl a] -> Doc ppBlock = vcat . map ppDecl ppSepBlock :: [Decl a] -> Doc ppSepBlock = vcat . map (\d -> text "" $+$ ppDecl d) -- |Pretty print a declaration ppDecl :: Decl a -> Doc ppDecl (InfixDecl _ fix p ops) = ppPrec fix p <+> list (map ppInfixOp ops) ppDecl (DataDecl _ tc tvs cs clss) = sep (ppTypeDeclLhs "data" tc tvs : map indent (zipWith (<+>) (equals : repeat vbar) (map ppConstr cs) ++ [ppDeriving clss])) ppDecl (ExternalDataDecl _ tc tvs) = ppTypeDeclLhs "external data" tc tvs ppDecl (NewtypeDecl _ tc tvs nc clss) = sep (ppTypeDeclLhs "newtype" tc tvs <+> equals : map indent [ppNewConstr nc, ppDeriving clss]) ppDecl (TypeDecl _ tc tvs ty) = sep [ppTypeDeclLhs "type" tc tvs <+> equals,indent (ppTypeExpr 0 ty)] ppDecl (TypeSig _ fs qty) = list (map ppIdent fs) <+> text "::" <+> ppQualTypeExpr qty ppDecl (FunctionDecl _ _ _ eqs) = vcat (map ppEquation eqs) ppDecl (ExternalDecl _ vs) = list (map ppVar vs) <+> text "external" ppDecl (PatternDecl _ t rhs) = ppRule (ppPattern 0 t) equals rhs ppDecl (FreeDecl _ vs) = list (map ppVar vs) <+> text "free" ppDecl (DefaultDecl _ tys) = text "default" <+> parenList (map (ppTypeExpr 0) tys) ppDecl (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) ppDecl (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] = ppConstraint c <+> darrow ppContext cs = parenList (map ppConstraint cs) <+> darrow ppConstraint :: Constraint -> Doc ppConstraint (Constraint _ qcls ty) = ppQIdent qcls <+> ppTypeExpr 2 ty ppInstanceType :: InstanceType -> Doc ppInstanceType = ppTypeExpr 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) ppConstr :: ConstrDecl -> Doc ppConstr (ConstrDecl _ c tys) = sep [ ppIdent c <+> fsep (map (ppTypeExpr 2) tys) ] ppConstr (ConOpDecl _ ty1 op ty2) = sep [ ppTypeExpr 1 ty1, ppInfixOp op <+> ppTypeExpr 1 ty2 ] ppConstr (RecordDecl _ c fs) = sep [ ppIdent c <+> record (list (map ppFieldDecl fs)) ] ppFieldDecl :: FieldDecl -> Doc ppFieldDecl (FieldDecl _ ls ty) = list (map ppIdent ls) <+> text "::" <+> ppTypeExpr 0 ty ppNewConstr :: NewConstrDecl -> Doc ppNewConstr (NewConstrDecl _ c ty) = sep [ppIdent c <+> ppTypeExpr 2 ty] ppNewConstr (NewRecordDecl _ c (i,ty)) = sep [ppIdent c <+> record (ppIdent i <+> text "::" <+> ppTypeExpr 0 ty)] ppQuantifiedVars :: [Ident] -> Doc ppQuantifiedVars tvs | null tvs = empty | otherwise = text "forall" <+> hsep (map ppIdent tvs) <+> char '.' ppEquation :: Equation a -> Doc ppEquation (Equation _ lhs rhs) = ppRule (ppLhs lhs) equals rhs ppLhs :: Lhs a -> Doc ppLhs (FunLhs _ f ts) = ppIdent f <+> fsep (map (ppPattern 2) ts) ppLhs (OpLhs _ t1 f t2) = ppPattern 1 t1 <+> ppInfixOp f <+> ppPattern 1 t2 ppLhs (ApLhs _ lhs ts) = parens (ppLhs lhs) <+> fsep (map (ppPattern 2) ts) ppRule :: Doc -> Doc -> Rhs a -> Doc ppRule lhs eq (SimpleRhs _ e ds) = sep [lhs <+> eq, indent (ppExpr 0 e)] $$ ppLocalDefs ds ppRule lhs eq (GuardedRhs _ es ds) = sep [lhs, indent (vcat (map (ppCondExpr eq) es))] $$ ppLocalDefs ds ppLocalDefs :: [Decl a] -> Doc ppLocalDefs ds | null ds = empty | otherwise = indent (text "where" <+> ppBlock ds) -- --------------------------------------------------------------------------- -- Interfaces -- --------------------------------------------------------------------------- -- |Pretty print an interface ppInterface :: Interface -> Doc ppInterface (Interface m is ds) = text "interface" <+> ppMIdent m <+> text "where" <+> lbrace $$ vcat (punctuate semi $ map ppIImportDecl is ++ map ppIDecl ds) $$ rbrace ppIImportDecl :: IImportDecl -> Doc ppIImportDecl (IImportDecl _ m) = text "import" <+> ppMIdent m -- |Pretty print an interface declaration ppIDecl :: IDecl -> Doc ppIDecl (IInfixDecl _ fix p op) = ppPrec fix (Just p) <+> ppQInfixOp op ppIDecl (HidingDataDecl _ tc k tvs) = text "hiding" <+> ppITypeDeclLhs "data" tc k tvs ppIDecl (IDataDecl _ tc k tvs cs hs) = sep (ppITypeDeclLhs "data" tc k tvs : map indent (zipWith (<+>) (equals : repeat vbar) (map ppConstr cs)) ++ [indent (ppHiding hs)]) ppIDecl (INewtypeDecl _ tc k tvs nc hs) = sep [ ppITypeDeclLhs "newtype" tc k tvs <+> equals , indent (ppNewConstr nc) , indent (ppHiding hs) ] ppIDecl (ITypeDecl _ tc k tvs ty) = sep [ppITypeDeclLhs "type" tc k tvs <+> equals,indent (ppTypeExpr 0 ty)] ppIDecl (IFunctionDecl _ f cm a qty) = sep [ ppQIdent f, maybePP (ppPragma "METHOD" . ppIdent) cm , int a, text "::", ppQualTypeExpr qty ] ppIDecl (HidingClassDecl _ cx qcls k clsvar) = text "hiding" <+> ppClassInstHead "class" cx (ppQIdentWithKind qcls k) (ppIdent clsvar) ppIDecl (IClassDecl _ cx qcls k clsvar ms hs) = ppClassInstHead "class" cx (ppQIdentWithKind qcls k) (ppIdent clsvar) <+> lbrace $$ vcat (punctuate semi $ map (indent . ppIMethodDecl) ms) $$ rbrace <+> ppHiding hs ppIDecl (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) ppIMethodDecl :: IMethodDecl -> Doc ppIMethodDecl (IMethodDecl _ f a qty) = ppIdent f <+> maybePP int a <+> text "::" <+> ppQualTypeExpr qty ppIMethodImpl :: IMethodImpl -> Doc ppIMethodImpl (f, a) = ppIdent f <+> int a ppQIdentWithKind :: QualIdent -> Maybe KindExpr -> Doc ppQIdentWithKind tc (Just k) = parens $ ppQIdent tc <+> text "::" <+> ppKindExpr 0 k ppQIdentWithKind tc Nothing = ppQIdent tc ppHiding :: [Ident] -> Doc ppHiding hs | null hs = empty | otherwise = ppPragma "HIDING" $ list $ map ppIdent hs -- --------------------------------------------------------------------------- -- Kinds -- --------------------------------------------------------------------------- ppKindExpr :: Int -> KindExpr -> Doc ppKindExpr _ Star = char '*' ppKindExpr p (ArrowKind k1 k2) = parenIf (p > 0) (fsep (ppArrowKind (ArrowKind k1 k2))) where ppArrowKind (ArrowKind k1' k2') = ppKindExpr 1 k1' <+> rarrow : ppArrowKind k2' ppArrowKind k = [ppKindExpr 0 k] -- --------------------------------------------------------------------------- -- Types -- --------------------------------------------------------------------------- -- |Pretty print a qualified type expression ppQualTypeExpr :: QualTypeExpr -> Doc ppQualTypeExpr (QualTypeExpr _ cx ty) = ppContext cx <+> ppTypeExpr 0 ty -- |Pretty print a type expression ppTypeExpr :: Int -> TypeExpr -> Doc ppTypeExpr _ (ConstructorType _ tc) = ppQIdent tc ppTypeExpr p (ApplyType _ ty1 ty2) = parenIf (p > 1) (ppApplyType ty1 [ty2]) where ppApplyType (ApplyType _ ty1' ty2') tys = ppApplyType ty1' (ty2' : tys) ppApplyType ty tys = ppTypeExpr 1 ty <+> fsep (map (ppTypeExpr 2) tys) ppTypeExpr _ (VariableType _ tv) = ppIdent tv ppTypeExpr _ (TupleType _ tys) = parenList (map (ppTypeExpr 0) tys) ppTypeExpr _ (ListType _ ty) = brackets (ppTypeExpr 0 ty) ppTypeExpr p (ArrowType spi ty1 ty2) = parenIf (p > 0) (fsep (ppArrowType (ArrowType spi ty1 ty2))) where ppArrowType (ArrowType _ ty1' ty2') = ppTypeExpr 1 ty1' <+> rarrow : ppArrowType ty2' ppArrowType ty = [ppTypeExpr 0 ty] ppTypeExpr _ (ParenType _ ty) = parens (ppTypeExpr 0 ty) ppTypeExpr p (ForallType _ vs ty) | null vs = ppTypeExpr p ty | otherwise = parenIf (p > 0) $ ppQuantifiedVars vs <+> ppTypeExpr 0 ty -- --------------------------------------------------------------------------- -- Literals -- --------------------------------------------------------------------------- ppLiteral :: Literal -> Doc ppLiteral (Char c) = text (show c) ppLiteral (Int i) = integer i ppLiteral (Float f) = double f ppLiteral (String s) = text (show s) -- --------------------------------------------------------------------------- -- Patterns -- --------------------------------------------------------------------------- -- |Pretty print a constructor term ppPattern :: Int -> Pattern a -> Doc ppPattern p (LiteralPattern _ _ l) = parenIf (p > 1 && isNegative l) (ppLiteral l) where isNegative (Char _) = False isNegative (Int i) = i < 0 isNegative (Float f) = f < 0.0 isNegative (String _) = False ppPattern p (NegativePattern _ _ l) = parenIf (p > 1) (ppInfixOp minusId <> ppLiteral l) ppPattern _ (VariablePattern _ _ v) = ppIdent v ppPattern p (ConstructorPattern _ _ c ts) = parenIf (p > 1 && not (null ts)) (ppQIdent c <+> fsep (map (ppPattern 2) ts)) ppPattern p (InfixPattern _ _ t1 c t2) = parenIf (p > 0) (sep [ppPattern 1 t1 <+> ppQInfixOp c, indent (ppPattern 0 t2)]) ppPattern _ (ParenPattern _ t) = parens (ppPattern 0 t) ppPattern _ (TuplePattern _ ts) = parenList (map (ppPattern 0) ts) ppPattern _ (ListPattern _ _ ts) = bracketList (map (ppPattern 0) ts) ppPattern _ (AsPattern _ v t) = ppIdent v <> char '@' <> ppPattern 2 t ppPattern _ (LazyPattern _ t) = char '~' <> ppPattern 2 t ppPattern p (FunctionPattern _ _ f ts) = parenIf (p > 1 && not (null ts)) (ppQIdent f <+> fsep (map (ppPattern 2) ts)) ppPattern p (InfixFuncPattern _ _ t1 f t2) = parenIf (p > 0) (sep [ppPattern 1 t1 <+> ppQInfixOp f, indent (ppPattern 0 t2)]) ppPattern p (RecordPattern _ _ c fs) = parenIf (p > 1) (ppQIdent c <+> record (list (map ppFieldPatt fs))) -- |Pretty print a record field pattern ppFieldPatt :: Field (Pattern a) -> Doc ppFieldPatt (Field _ l t) = ppQIdent l <+> equals <+> ppPattern 0 t -- --------------------------------------------------------------------------- -- Expressions -- --------------------------------------------------------------------------- ppCondExpr :: Doc -> CondExpr a -> Doc ppCondExpr eq (CondExpr _ g e) = vbar <+> sep [ppExpr 0 g <+> eq,indent (ppExpr 0 e)] -- |Pretty print an expression ppExpr :: Int -> Expression a -> Doc ppExpr _ (Literal _ _ l) = ppLiteral l ppExpr _ (Variable _ _ v) = ppQIdent v ppExpr _ (Constructor _ _ c) = ppQIdent c ppExpr _ (Paren _ e) = parens (ppExpr 0 e) ppExpr p (Typed _ e qty) = parenIf (p > 0) (ppExpr 0 e <+> text "::" <+> ppQualTypeExpr qty) ppExpr _ (Tuple _ es) = parenList (map (ppExpr 0) es) ppExpr _ (List _ _ es) = bracketList (map (ppExpr 0) es) ppExpr _ (ListCompr _ e qs) = brackets (ppExpr 0 e <+> vbar <+> list (map ppStmt qs)) ppExpr _ (EnumFrom _ e) = brackets (ppExpr 0 e <+> text "..") ppExpr _ (EnumFromThen _ e1 e2) = brackets (ppExpr 0 e1 <> comma <+> ppExpr 0 e2 <+> text "..") ppExpr _ (EnumFromTo _ e1 e2) = brackets (ppExpr 0 e1 <+> text ".." <+> ppExpr 0 e2) ppExpr _ (EnumFromThenTo _ e1 e2 e3) = brackets (ppExpr 0 e1 <> comma <+> ppExpr 0 e2 <+> text ".." <+> ppExpr 0 e3) ppExpr p (UnaryMinus _ e) = parenIf (p > 1) (ppInfixOp minusId <> ppExpr 1 e) ppExpr p (Apply _ e1 e2) = parenIf (p > 1) (sep [ppExpr 1 e1,indent (ppExpr 2 e2)]) ppExpr p (InfixApply _ e1 op e2) = parenIf (p > 0) (sep [ppExpr 1 e1 <+> ppQInfixOp (opName op), indent (ppExpr 1 e2)]) ppExpr _ (LeftSection _ e op) = parens (ppExpr 1 e <+> ppQInfixOp (opName op)) ppExpr _ (RightSection _ op e) = parens (ppQInfixOp (opName op) <+> ppExpr 1 e) ppExpr p (Lambda _ t e) = parenIf (p > 0) (sep [backsl <> fsep (map (ppPattern 2) t) <+> rarrow, indent (ppExpr 0 e)]) ppExpr p (Let _ ds e) = parenIf (p > 0) (sep [text "let" <+> ppBlock ds, text "in" <+> ppExpr 0 e]) ppExpr p (Do _ sts e) = parenIf (p > 0) (text "do" <+> (vcat (map ppStmt sts) $$ ppExpr 0 e)) ppExpr p (IfThenElse _ e1 e2 e3) = parenIf (p > 0) (text "if" <+> sep [ppExpr 0 e1, text "then" <+> ppExpr 0 e2, text "else" <+> ppExpr 0 e3]) ppExpr p (Case _ ct e alts) = parenIf (p > 0) (ppCaseType ct <+> ppExpr 0 e <+> text "of" $$ indent (vcat (map ppAlt alts))) ppExpr p (Record _ _ c fs) = parenIf (p > 0) (ppQIdent c <+> record (list (map ppFieldExpr fs))) ppExpr _ (RecordUpdate _ e fs) = ppExpr 0 e <+> record (list (map ppFieldExpr fs)) -- |Pretty print a statement ppStmt :: Statement a -> Doc ppStmt (StmtExpr _ e) = ppExpr 0 e ppStmt (StmtBind _ t e) = sep [ppPattern 0 t <+> larrow,indent (ppExpr 0 e)] ppStmt (StmtDecl _ ds) = text "let" <+> ppBlock ds ppCaseType :: CaseType -> Doc ppCaseType Rigid = text "case" ppCaseType Flex = text "fcase" -- |Pretty print an alternative in a case expression ppAlt :: Alt a -> Doc ppAlt (Alt _ t rhs) = ppRule (ppPattern 0 t) rarrow rhs -- |Pretty print a free variable ppVar :: Var a -> Doc ppVar (Var _ ident) = ppIdent ident -- |Pretty print a record field expression (Haskell syntax) ppFieldExpr :: Field (Expression a) -> Doc ppFieldExpr (Field _ l e) = ppQIdent l <+> equals <+> ppExpr 0 e -- |Pretty print an operator ppOp :: InfixOp a -> Doc ppOp (InfixOp _ op) = ppQInfixOp op ppOp (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 curry-base-v1.1.1/src/Curry/Syntax/ShowModule.hs000066400000000000000000000531221347771173600216020ustar00rootroot00000000000000{- | 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 ps mident espec imps decls) = showsString "Module " . 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 " . showsPosition p . space . shows e . showString ")" showsExtension (UnknownExtension p s) = showsString "(UnknownExtension " . showsPosition 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 context cls clsvar decls) = showsString "(ClassDecl " . showsSpanInfo spi . space . showsContext context . space . showsIdent cls . space . showsIdent clsvar . space . showsList showsDecl decls . showsString ")" showsDecl (InstanceDecl spi context qcls inst decls) = showsString "(InstanceDecl " . showsSpanInfo spi . 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 expr decls) = showsString "(SimpleRhs " . showsSpanInfo spi . space . showsExpression expr . space . showsList showsDecl decls . showsString ")" showsRhs (GuardedRhs spi cexps decls) = showsString "(GuardedRhs " . showsSpanInfo spi . 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 decls expr) = showsString "(Let " . showsSpanInfo spi . space . showsList showsDecl decls . space . showsExpression expr . showsString ")" showsExpression (Do spi stmts expr) = showsString "(Do " . showsSpanInfo spi . 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 ct expr alts) = showsString "(Case " . showsSpanInfo spi . 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 decls) = showsString "(StmtDecl " . showsSpanInfo spi . 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 ")" 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 "\"" curry-base-v1.1.1/src/Curry/Syntax/Type.hs000066400000000000000000001242471347771173600204440ustar00rootroot00000000000000{- | 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 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 [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] | 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 Context Ident Ident [Decl a] -- class C a => D a where {TypeSig|InfixDecl|FunctionDecl} | InstanceDecl SpanInfo 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 (Expression a) [Decl a] -- @expr where decls@ | GuardedRhs SpanInfo [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 [Decl a] (Expression a) | Do SpanInfo [Statement a] (Expression a) | IfThenElse SpanInfo (Expression a) (Expression a) (Expression a) | Case SpanInfo 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 [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 (Expression a) [Decl a] deriving (Eq, Read, Show) -- --------------------------------------------------------------------------- -- instances -- --------------------------------------------------------------------------- instance Functor Module where fmap f (Module sp ps m es is ds) = Module sp 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 cx cls clsvar ds) = ClassDecl sp cx cls clsvar (map (fmap f) ds) fmap f (InstanceDecl sp cx qcls inst ds) = InstanceDecl sp 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 e ds) = SimpleRhs p (fmap f e) (map (fmap f) ds) fmap f (GuardedRhs p cs ds) = GuardedRhs p (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 ds e) = Let p (map (fmap f) ds) (fmap f e) fmap f (Do p stms e) = Do p (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 ct e as) = Case p 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 ds) = StmtDecl p (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 e ds) = Goal p (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 _ ps m es is ds) = Module sp 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 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 _ cx cls clsvar ds) = ClassDecl sp cx cls clsvar ds setSpanInfo sp (InstanceDecl _ cx qcls inst ds) = InstanceDecl sp 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 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 _ ex ds) = SimpleRhs sp ex ds setSpanInfo sp (GuardedRhs _ cs ds) = GuardedRhs sp 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 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 _ ds e) = Let sp ds e setSpanInfo sp (Do _ stms e) = Do sp stms e setSpanInfo sp (IfThenElse _ e1 e2 e3) = IfThenElse sp e1 e2 e3 setSpanInfo sp (Case _ ct e as) = Case sp 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 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 _ ds) = StmtDecl sp 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 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 _ e ds) = Goal sp 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 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) curry-base-v1.1.1/src/Curry/Syntax/Utils.hs000066400000000000000000000267531347771173600206260ustar00rootroot00000000000000{- | 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 , 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 ps mid es is ds) | mid == mainMIdent = Module spi 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 e [] patDecl :: SpanInfo -> Pattern a -> Expression a -> Decl a patDecl spi t e = PatternDecl spi t (SimpleRhs spi 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 e []) mkLet :: [Decl a] -> Expression a -> Expression a mkLet ds e = if null ds then e else Let NoSpanInfo ds e mkVar :: a -> Ident -> Expression a mkVar ty = Variable NoSpanInfo ty . qualify 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 _ mid ex im ds) = Module spi [] mid ex im (map shortenAST ds) instance ShortenAST (Decl a) where shortenAST (FunctionDecl spi a idt _) = FunctionDecl spi a idt [] shortenAST (ClassDecl spi cx cls tyv ds) = ClassDecl spi cx cls tyv (map shortenAST ds) shortenAST (InstanceDecl spi cx cls tyv ds) = InstanceDecl spi cx cls tyv (map shortenAST ds) shortenAST d = d curry-base-v1.1.1/test/000077500000000000000000000000001347771173600147535ustar00rootroot00000000000000curry-base-v1.1.1/test/HaskellRecords.curry000066400000000000000000000013721347771173600207510ustar00rootroot00000000000000module M (D (C1, C2)) where data D = C1 Int | C2 String | C3 Bool -- data -- should be parsed -- data RD = RD {} -- data RD = RD { x,y,z :: Int, a :: Bool, r :: RD } -- data RD a = RD { f :: a } -- newtype -- should be parsed -- newtype RN = RN { x :: Int } -- should NOT be parsed -- newtype RN = RN { x,y :: Int } -- newtype RN = RN { x :: Int, y :: Bool } -- newtype RN = RN { } -- record construction -- r1 = R1 { x = 12, y = False } -- r2 = R2 { } -- r3 = R3 { x = 42, r = r3 } -- record selection -- i = x r3 -- record update -- should be parsed -- r3' = r3 { x = 24, y = 72 } -- r3' = (r r3) { x = 24, y = 72 } -- r3' = (r3 { }) -- record pattern -- f R1 { x = 45 } = True -- f R1 { x = 45, y = False } = True -- f R1 { } = True curry-base-v1.1.1/test/Pragmas.curry000066400000000000000000000001351347771173600174320ustar00rootroot00000000000000{-# LANGUAGE Records #-} {-# OPTIONS_KICS2 -v2 #-} module Pragmas where f :: a -> a f x = x curry-base-v1.1.1/test/TestBase.hs000066400000000000000000000133741347771173600170310ustar00rootroot00000000000000-------------------------------------------------------------------------------- -- Test Suite for Curry Base -------------------------------------------------------------------------------- -- -- This Test Suite supports three kinds of tests: -- -- 1) tests which should pass -- 2) tests which should pass with a specific warning -- 3) tests which should fail yielding a specific error message -- -- In order to add a test to this suite, proceed as follows: -- -- 1) Store your test code in a file (please use descriptive names) and put it -- in the corresponding subfolder (i.e. test/pass for passing tests, -- test/fail for failing tests and test/warning for passing tests producing -- warnings) -- 2) Extend the corresponding test information list (there is one for each test -- group at the end of this file) with the required information (i.e. name of -- the Curry module to be tested and expected warning/failure message(s)) -- 3) Run 'cabal test' {-# LANGUAGE CPP #-} module TestBase (tests) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif import Control.Monad.Trans (lift) import Data.List (isInfixOf, sort) import Distribution.TestSuite import System.FilePath (FilePath, (), (<.>)) import Curry.Base.Message (Message, ppMessages, ppError) import Curry.Base.Monad (CYIO, runCYIO, liftCYM) import Curry.Files.PathUtils (readModule) import Curry.Syntax (parseModule, unlit) tests :: IO [Test] tests = return [passingTests, warningTests, failingTests] -- Call the Curry parser parseCurry :: FilePath -> CYIO () parseCurry file = do msrc <- lift $ lift $ readModule file case msrc of Nothing -> error $ "Missing file " ++ file Just src -> liftCYM $ do ul <- unlit file src parseModule file ul return () -- Execute a test by calling cymake runTest :: String -> [String] -> IO Progress runTest test [] = runCYIO (parseCurry test) >>= passOrFail where passOrFail = (Finished <$>) . either fail pass fail msgs | null msgs = return Pass | otherwise = let errorStr = showMessages msgs in return $ Fail $ "An unexpected failure occurred: " ++ errorStr pass _ = return Pass runTest test errorMsgs = runCYIO (parseCurry test) >>= catchE where catchE = (Finished <$>) . either pass fail pass msgs = let errorStr = showMessages msgs in if all (`isInfixOf` errorStr) errorMsgs then return Pass else return $ Fail $ "Expected warning/failure did not occur: " ++ errorStr fail = pass . snd showMessages :: [Message] -> String showMessages = show . ppMessages ppError . sort -- group of tests which should pass passingTests :: Test passingTests = Group { groupName = "Passing Tests" , concurrently = False , 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" , concurrently = False , groupTests = map (mkTest "test/warning/") warnInfos } -- create a new test mkTest :: FilePath -> TestInfo -> Test mkTest path (testName, testTags, testOpts, mSetOpts, errorMsgs) = let file = path testName <.> "curry" test = TestInstance { run = runTest file errorMsgs , name = testName , tags = testTags , options = testOpts , setOption = maybe (\_ _ -> Right test) id mSetOpts } in Test test -- Information for a test instance: -- * name of test -- * tags to classify a test -- * options -- * function to set options -- * optional warning/error message which should be thrown on execution of test type TestInfo = (String, [String], [OptionDescr], Maybe SetOption, [String]) type SetOption = String -> String -> Either String TestInstance -------------------------------------------------------------------------------- -- Definition of 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 -- TODO: add test cases passInfos :: [TestInfo] passInfos = map mkPassTest [] -------------------------------------------------------------------------------- -- Definition of failing tests -------------------------------------------------------------------------------- -- generate a simple failing test mkFailTest :: String -> [String] -> TestInfo mkFailTest name errorMsgs = (name, [], [], Nothing, errorMsgs) -- To add a failing test to the test suite simply add the module name of the -- test code and the expected error message(s) to the following list -- TODO: add test cases failInfos :: [TestInfo] failInfos = map (uncurry mkFailTest) [] -------------------------------------------------------------------------------- -- Definition of warning tests -------------------------------------------------------------------------------- -- To add a warning test to the test suite simply add the module name of the -- test code and the expected warning message(s) to the following list -- TODO: add test cases warnInfos :: [TestInfo] warnInfos = map (uncurry mkFailTest) [] curry-base-v1.1.1/util/000077500000000000000000000000001347771173600147515ustar00rootroot00000000000000curry-base-v1.1.1/util/canonfint.hs000066400000000000000000000053701347771173600172710ustar00rootroot00000000000000{- | Module : $Header$ Description : Executable to fix FlatCurry interface files Copyright : (c) 2016 Björn Peemöller License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable This executable should be invoked as @canonfint old.fint new.fint@ to read the FlatCurry interface file @old.fint@, convert the declarations inside to a canonical representation (see below), and emit the fixed interface into @new.fint@. The conversion performs the following changes: * Imports are lexicographically sorted * Type declarations are restricted to public declarations and lexicographically sorted * the body of external function declarations is represented as @Rule [] (Var 0)@, so that internally and externally defined functions are not distinguished in interface files * The type variables in reexported functions are renumbered to start from 0 * Operator declarations are filtered for public operators and precendences that deviate from the default precendence * Operator declarations are lexicographically sorted This utility has been developed to aid the rewriting of the FlatCurry interface generation, to make new and old interface files comparable. -} module Main where import Data.Function (on) import Data.List (nub, sort, sortBy) import System.Directory (createDirectoryIfMissing) import System.Environment (getArgs) import System.FilePath (takeDirectory) import Curry.ExtendedFlat.Type import Curry.ExtendedFlat.Goodies main :: IO () main = do [f1, f2] <- getArgs mbFlat <- readFlat f1 case mbFlat of Nothing -> putStrLn $ "Could not read file " ++ f1 Just fcy -> do createDirectoryIfMissing True (takeDirectory f2) writeFlatCurry f2 $ fixDecls fcy fixDecls :: Prog -> Prog fixDecls (Prog m is ts fs os) = Prog m (sort is) ts' fs' os' where ts' = sortBy (compare `on` typeName) $ filter (isPublic . typeVisibility) ts fs' = sortBy (compare `on` funcName) $ map (updFuncType fixTypeVars . changeExternal) fs os' = sortBy (compare `on` opName ) $ filter (not . isDefaultPrec) $ filter (isPublicOp fs) os isPublic p = p == Public changeExternal = updFuncRule (const (Rule [] (Var 0))) fixTypeVars ty = rnmAllVarsInTypeExpr rnm ty where rnm v = case lookup v sub of Just v' -> v' _ -> error "normType" sub = zip (nub $ allVarsInTypeExpr ty) [0 ..] isDefaultPrec od = opFixity od == InfixlOp && opPrecedence od == 9 isPublicOp fs o = not $ null [ () | f <- fs , funcName f == opName o , isPublic (funcVisibility f) ] curry-base-v1.1.1/util/lex.hs000066400000000000000000000010761347771173600161010ustar00rootroot00000000000000module Main (main) where import Curry.Base.Monad import Curry.Files.PathUtils import Curry.Syntax import System.Environment (getArgs) main :: IO () main = do args <- getArgs case args of [] -> error $ "Missing argument" [file] -> do msrc <-readModule file case msrc of Nothing -> error $ "Missing file " ++ file Just src -> do let res = runCYM $ unlitLexSource file src case res of Left f -> print f Right m -> print $ m curry-base-v1.1.1/util/parse.hs000066400000000000000000000012121347771173600164130ustar00rootroot00000000000000module Main (main) where import Curry.Base.Monad import Curry.Files.PathUtils import Curry.Syntax import System.Environment (getArgs) main :: IO () main = do args <- getArgs case args of [] -> error $ "Missing argument" [file] -> do msrc <-readModule file case msrc of Nothing -> error $ "Missing file " ++ file Just src -> do let res = runCYM $ do ul <- unlit file src parseModule file ul case res of Left f -> print f Right m -> print $ m