diff --git a/.gitignore b/.gitignore index 6ce8edca2d7d8463b2a966d457c789770d461472..59e96cf0629ae05e88d4ccee868d159f7f3b676a 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ # Haskell and Cabal related files and folders +bin dist dist-* cabal-dev diff --git a/Makefile b/Makefile new file mode 100644 index 0000000000000000000000000000000000000000..61de8c82222633e78e824c0c64193884e1a3d990 --- /dev/null +++ b/Makefile @@ -0,0 +1,28 @@ +############################################################################## +# Makefile for installing the Curry front end +############################################################################## + +# the root directory of the installation +export ROOT=$(CURDIR) +# binary directory and executables +export BINDIR=$(ROOT)/bin +# The frontend binary +export CYMAKE = $(BINDIR)/curry-frontend + +# install front end (if sources are present): +.PHONY: frontend +frontend: + stack install --local-bin-path $(BINDIR) + +.PHONY: clean +clean: + stack clean + +.PHONY: cleanall +cleanall: + stack clean --full + rm -f $(CYMAKE) && rm -rf bin + +.PHONY: runtests +runtests: + stack test diff --git a/README.md b/README.md index 5707e1536e8f5c93e225314b23dce2ba10085c90..8c2f1493045c5c8c37f53b65a78f81dbb44de29f 100644 --- a/README.md +++ b/README.md @@ -1,29 +1,24 @@ # Curry Frontend -The Curry frontend parses source files (`.curry`), emits errors and -warnings, performs various checks and transformations and -generates FlatCurry (`.fcy`, `.fint`) or AbstractCurry (`.acy`, `.uacy`), -amonst other formats. - -The project originated from a modified version of the Münster-Curry-Compiler -(MCC) for use with [PAKCS](https://git.ps.informatik.uni-kiel.de/curry/pakcs), -but can also be used with a variety of other backends, most notably including +The frontend lexes, parses, type-checks and transforms Curry source files into a variety of intermediate formats, including + +* **FlatCurry** for program analyzers and backends +* **AbstractCurry** for program manipulation tools +* **HTML** for documentation + +It is used by the two major Curry compilers, [PAKCS](https://git.ps.informatik.uni-kiel.de/curry/pakcs) and [KiCS2](https://git.ps.informatik.uni-kiel.de/curry/kics2). ## Requirements -* `cabal-install` -* A recent version of the `curry-base` package, installed locally +* Make sure that a recent version of Haskell Stack is installed on your computer ## Building -To build the project, run `cabal v1-build`. - -## Running - -To run the project, use `cabal v1-run`. +* To build the project, run `make`. +* To test the project, run `make runtests`. -Alternatively, you can launch the built executable manually from `dist/build/curry-frontend`. +The built executable will be located at `bin/curry-frontend`. ## Usage diff --git a/src/cymake.hs b/app/cymake.hs similarity index 100% rename from src/cymake.hs rename to app/cymake.hs diff --git a/curry-frontend.cabal b/curry-frontend.cabal index db1434ac6fd46bc8106f0a7093787c11d1f2cd35..374755c0cb5289173f681400a8f8286b3fa5fa9a 100644 --- a/curry-frontend.cabal +++ b/curry-frontend.cabal @@ -1,9 +1,9 @@ -Name: curry-frontend -Version: 2.0.0 -Cabal-Version: 2.0 -Synopsis: Compile the functional logic language Curry to several +name: curry-frontend +version: 2.0.0 +cabal-version: 2.0 +synopsis: Compile the functional logic language Curry to several intermediate formats -Description: The Curry front end consists of the executable program +description: The Curry front end consists of the executable program "curry-frontend". It is used by various backends to compile Curry programs to an intermediate representation. @@ -14,30 +14,29 @@ Description: The Curry front end consists of the executable program representations. For further information, please check -Category: Language -License: BSD3 -License-File: LICENSE -Author: Wolfgang Lux, Martin Engelke, Bernd Brassel, Holger Siegel, +category: Language +license: BSD3 +license-file: LICENSE +author: Wolfgang Lux, Martin Engelke, Bernd Brassel, Holger Siegel, Bjoern Peemoeller, Finn Teegen -Maintainer: fte@informatik.uni-kiel.de -Homepage: http://curry-language.org -Build-Type: Simple -Stability: experimental +maintainer: fte@informatik.uni-kiel.de +homepage: http://curry-language.org +build-type: Simple +stability: experimental -Extra-Source-Files: LIESMICH CHANGELOG.md +extra-source-files: README.md CHANGELOG.md -Data-Dir: data -Data-Files: currysource.css +data-dir: data +data-files: currysource.css source-repository head type: git location: https://git.ps.informatik.uni-kiel.de/curry/curry-frontend.git -Executable curry-frontend +library hs-source-dirs: src - Main-is: cymake.hs default-language: Haskell2010 - other-extensions: CPP, TemplateHaskell, OverloadedStrings + other-extensions: CPP, TemplateHaskell ghc-options: -Wall build-depends: base >= 4.11 @@ -54,8 +53,10 @@ Executable curry-frontend , process , network-uri >= 2.6 , pretty - , curry-base == 1.2.0 - other-modules: + , binary + , time + , parsec + exposed-modules: Base.AnnotExpr , Base.CurryKinds , Base.CurryTypes @@ -88,6 +89,44 @@ Executable curry-frontend , Checks.TypeCheck , Checks.TypeSyntaxCheck , Checks.WarnCheck + , Curry.AbstractCurry + , Curry.AbstractCurry.Files + , Curry.AbstractCurry.Type + , Curry.Base.Ident + , Curry.Base.LexComb + , Curry.Base.LLParseComb + , Curry.Base.Message + , Curry.Base.Monad + , Curry.Base.Position + , Curry.Base.Pretty + , Curry.Base.Span + , Curry.Base.SpanInfo + , Curry.CondCompile.Parser + , Curry.CondCompile.Transform + , Curry.CondCompile.Type + , Curry.Files.Filenames + , Curry.Files.PathUtils + , Curry.Files.Unlit + , Curry.FlatCurry + , Curry.FlatCurry.Files + , Curry.FlatCurry.Goodies + , Curry.FlatCurry.InterfaceEquivalence + , Curry.FlatCurry.Pretty + , Curry.FlatCurry.Type + , Curry.FlatCurry.Typeable + , Curry.FlatCurry.Annotated.Goodies + , Curry.FlatCurry.Annotated.Type + , Curry.FlatCurry.Typed.Goodies + , Curry.FlatCurry.Typed.Type + , Curry.Syntax + , Curry.Syntax.Extension + , Curry.Syntax.InterfaceEquivalence + , Curry.Syntax.Lexer + , Curry.Syntax.Parser + , Curry.Syntax.Pretty + , Curry.Syntax.ShowModule + , Curry.Syntax.Type + , Curry.Syntax.Utils , CompilerEnv , CompilerOpts , CondCompile @@ -133,12 +172,21 @@ Executable curry-frontend autogen-modules: Paths_curry_frontend -Test-Suite test-frontend +executable curry-frontend + hs-source-dirs: app + main-is: cymake.hs + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >= 4.11 + , curry-frontend + +test-suite test-frontend type: detailed-0.9 - hs-source-dirs: test, src + hs-source-dirs: test test-module: TestFrontend default-language: Haskell2010 - other-extensions: CPP, TemplateHaskell, OverloadedStrings + other-extensions: CPP, TemplateHaskell ghc-options: -Wall build-depends: base >= 4.11 @@ -156,80 +204,4 @@ Test-Suite test-frontend , process , network-uri >= 2.6 , pretty - , curry-base == 1.2.0 - other-modules: - Base.AnnotExpr - , Base.CurryKinds - , Base.CurryTypes - , Base.Expr - , Base.KindSubst - , Base.Kinds - , Base.Messages - , Base.NestEnv - , Base.PrettyKinds - , Base.PrettyTypes - , Base.SCC - , Base.Subst - , Base.TopEnv - , Base.TypeExpansion - , Base.TypeSubst - , Base.Types - , Base.Typing - , Base.Utils - , Checks - , Checks.DeriveCheck - , Checks.ExportCheck - , Checks.ExtensionCheck - , Checks.ImportSyntaxCheck - , Checks.InstanceCheck - , Checks.InterfaceCheck - , Checks.InterfaceSyntaxCheck - , Checks.KindCheck - , Checks.PrecCheck - , Checks.SyntaxCheck - , Checks.TypeCheck - , Checks.TypeSyntaxCheck - , Checks.WarnCheck - , CompilerEnv - , CompilerOpts - , CondCompile - , CurryBuilder - , CurryDeps - , Env.Class - , Env.Instance - , Env.Interface - , Env.ModuleAlias - , Env.OpPrec - , Env.Type - , Env.TypeConstructor - , Env.Value - , Exports - , Generators - , Generators.GenAbstractCurry - , Generators.GenFlatCurry - , Generators.GenTypeAnnotatedFlatCurry - , Generators.GenTypedFlatCurry - , Html.CurryHtml - , Html.SyntaxColoring - , IL - , IL.Pretty - , IL.ShowModule - , IL.Type - , IL.Typing - , Imports - , Interfaces - , Modules - , TokenStream - , Transformations - , Transformations.CaseCompletion - , Transformations.CurryToIL - , Transformations.Derive - , Transformations.Desugar - , Transformations.Dictionary - , Transformations.Lift - , Transformations.Newtypes - , Transformations.Qual - , Transformations.Simplify - , Paths_curry_frontend - autogen-modules: - Paths_curry_frontend + , curry-frontend diff --git a/overview.md b/overview.md index a888f534530a4eee0e5e10e44825f4dbbaf6662a..80fcb4b60c6bedc2ea34466133e9059caae67fae 100644 --- a/overview.md +++ b/overview.md @@ -25,6 +25,38 @@ Module overview of package `curry-frontend` * `.SyntaxCheck`: Überprüfung der Syntax, Umbenennung von Variablen * `.TypeCheck` : Typüberprüfung * `.WarnCheck` : Erzeugung von Warnungen + * `Curry.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 * `Env`: Umgebungen für die Kompilierung * `.Eval` : Auswertungsannotationen * `.Interface` : Importierte Interfaces diff --git a/src/Base/PrettyTypes.hs b/src/Base/PrettyTypes.hs index f3c9f97bda1cfce047c6d26c0fc87db093db87f3..6ef7ae8a1b732a86d5db0f769efdcfb5656bd49e 100644 --- a/src/Base/PrettyTypes.hs +++ b/src/Base/PrettyTypes.hs @@ -23,7 +23,6 @@ import qualified Data.Set as Set (Set, toAscList) import Curry.Base.Ident (identSupply) import Curry.Base.Pretty -import Curry.Syntax.Pretty import Base.CurryTypes import Base.Types diff --git a/src/Checks/InterfaceSyntaxCheck.hs b/src/Checks/InterfaceSyntaxCheck.hs index 7365fc2ee712704d889db7607a5694950c18959e..5ede9ce3e6b370c4f2119e1a8b91c2abde4a83a8 100644 --- a/src/Checks/InterfaceSyntaxCheck.hs +++ b/src/Checks/InterfaceSyntaxCheck.hs @@ -40,7 +40,6 @@ import Curry.Base.Ident import Curry.Base.SpanInfo import Curry.Base.Pretty import Curry.Syntax -import Curry.Syntax.Pretty data ISCState = ISCState { typeEnv :: TypeEnv diff --git a/src/Curry/AbstractCurry.hs b/src/Curry/AbstractCurry.hs new file mode 100644 index 0000000000000000000000000000000000000000..2dce38bac229b2caf09f3c6ec3fb65d74844c329 --- /dev/null +++ b/src/Curry/AbstractCurry.hs @@ -0,0 +1,30 @@ +{- | + Module : $Header$ + Description : Library to support meta-programming in Curry + Copyright : Michael Hanus , 2004 + Martin Engelke , 2005 + Björn Peemöller, 2013 + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This library contains a definition for representing Curry programs + in Haskell by the type 'CurryProg' and I/O actions to read Curry programs + and transform them into this abstract representation as well as + write them to a file. + + Note that this defines a slightly new format for AbstractCurry + in comparison to the first proposal of 2003. + + /Assumption:/ An AbstractCurry program @Prog@ is stored in a file with + the file extension @acy@, i.e. in a file @Prog.acy@. +-} +module Curry.AbstractCurry + ( module Curry.AbstractCurry.Type + , module Curry.AbstractCurry.Files + ) where + +import Curry.AbstractCurry.Type +import Curry.AbstractCurry.Files diff --git a/src/Curry/AbstractCurry/Files.hs b/src/Curry/AbstractCurry/Files.hs new file mode 100644 index 0000000000000000000000000000000000000000..d4ea5676faeb762e330394261de305d246b7d365 --- /dev/null +++ b/src/Curry/AbstractCurry/Files.hs @@ -0,0 +1,61 @@ +{- | + Module : $Header$ + Description : Library to support meta-programming in Curry + Copyright : (c) Michael Hanus , 2004 + Martin Engelke , 2005 + Björn Peemöller, 2014 + Finn Teegen , 2016 + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This library contains I/O actions to read Curry programs + and transform them into this abstract representation as well as + write them to a file. +-} +module Curry.AbstractCurry.Files + ( readCurry, writeCurry, showCurry + ) where + +import qualified Control.Exception as C (catch) +import Data.List (intercalate) + +import Curry.Files.PathUtils ( writeModule, readModule + , addVersion, checkVersion) + +import Curry.AbstractCurry.Type + +-- --------------------------------------------------------------------------- +-- Reading and writing AbstractCurry terms +-- --------------------------------------------------------------------------- + +-- |Read an AbstractCurry file and return the corresponding AbstractCurry +-- program term of type 'CurryProg' +readCurry :: FilePath -> IO (Maybe CurryProg) +readCurry fn = do + mbSrc <- readModule fn + return $ case mbSrc of + Nothing -> Nothing + Just src -> case checkVersion version src of + Left _ -> Nothing + Right ac -> Just (read ac) + +-- |Write an AbstractCurry program term into a file. +writeCurry :: FilePath -> CurryProg -> IO () +writeCurry fn p = C.catch (writeModule fn $ addVersion version $ showCurry p) + ioError + +-- |Show an AbstractCurry program in a nicer way +showCurry :: CurryProg -> String +showCurry (CurryProg mname imps dflt clss insts types funcs ops) + = "CurryProg " ++ show mname ++ "\n" + ++ show imps ++ "\n" + ++ showsPrec 11 dflt "\n" + ++ wrapList clss + ++ wrapList insts + ++ wrapList types + ++ wrapList funcs + ++ wrapList ops + where wrapList xs = " [" ++ intercalate ",\n " (map show xs) ++ "]\n" diff --git a/src/Curry/AbstractCurry/Type.hs b/src/Curry/AbstractCurry/Type.hs new file mode 100644 index 0000000000000000000000000000000000000000..5fa29b6aee052f478ce5c46edcb4535f04b49f6e --- /dev/null +++ b/src/Curry/AbstractCurry/Type.hs @@ -0,0 +1,329 @@ +{- | + Module : $Header$ + Description : Library to support meta-programming in Curry + Copyright : Michael Hanus , 2004 + Martin Engelke , 2005 + Björn Peemöller, 2015 + Finn Teegen , 2016 + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This library contains a definition for representing Curry programs + in Haskell by the type 'CurryProg' and I/O actions to read Curry programs + and transform them into this abstract representation as well as + write them to a file. + + Note that this defines a slightly new format for AbstractCurry + in comparison to the first proposal of 2003. +-} +module Curry.AbstractCurry.Type + ( CurryProg (..), MName, QName, CVisibility (..), CTVarIName + , CDefaultDecl (..), CClassDecl (..), CInstanceDecl (..) + , CTypeDecl (..), CConsDecl (..), CFieldDecl (..) + , CConstraint, CContext (..), CTypeExpr (..), CQualTypeExpr (..) + , COpDecl (..), CFixity (..), Arity, CFuncDecl (..), CRhs (..), CRule (..) + , CLocalDecl (..), CVarIName, CExpr (..), CCaseType (..), CStatement (..) + , CPattern (..), CLiteral (..), CField, version + ) where + +-- --------------------------------------------------------------------------- +-- Abstract syntax +-- --------------------------------------------------------------------------- + +-- |Current version of AbstractCurry +version :: String +version = "AbstractCurry 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) + +-- |A constructor declaration consists of the name of the constructor +-- and a list of the argument types of the constructor. +-- The arity equals the number of types. +data CConsDecl + = CCons QName CVisibility [CTypeExpr] + | CRecord QName CVisibility [CFieldDecl] + deriving (Eq, Read, Show) + +-- |A record field declaration consists of the name of the +-- the label, the visibility and its corresponding type. +data CFieldDecl = CField QName CVisibility CTypeExpr + deriving (Eq, Read, Show) + +-- |The type for representing a class constraint. +type CConstraint = (QName, CTypeExpr) + +-- |The type for representing a context. +data CContext = CContext [CConstraint] + deriving (Eq, Read, Show) + +-- |Type expression. +-- A type expression is either a type variable, a function type, +-- a type constructor or a type application. +data CTypeExpr + -- |Type variable + = CTVar CTVarIName + -- |Function type @t1 -> t2@ + | CFuncType CTypeExpr CTypeExpr + -- |Type constructor + | CTCons QName + -- |Type application + | CTApply CTypeExpr CTypeExpr + deriving (Eq, Read, Show) + +-- |Qualified type expression. +data CQualTypeExpr = CQualType CContext CTypeExpr + deriving (Eq, Read, Show) + +-- |Labeled record fields +type CField a = (QName, a) + +-- |Operator precedence declaration. +-- An operator precedence declaration @fix p n@ in Curry corresponds to the +-- AbstractCurry term @(COp n fix p)@. +data COpDecl = COp QName CFixity Int + deriving (Eq, Read, Show) + +-- |Fixity declarations of infix operators +data CFixity + = CInfixOp -- ^ non-associative infix operator + | CInfixlOp -- ^ left-associative infix operator + | CInfixrOp -- ^ right-associative infix operator + deriving (Eq, Read, Show) + +-- |Function arity +type Arity = Int + +-- |Data type for representing function declarations. +-- A function declaration in FlatCurry is a term of the form +-- @ +-- (CFunc name arity visibility type (CRules eval [CRule rule1,...,rulek])) +-- @ +-- and represents the function @name@ with definition +-- @ +-- name :: type +-- rule1 +-- ... +-- rulek +-- @ +-- /Note:/ The variable indices are unique inside each rule. +-- External functions are represented as +-- @ +-- (CFunc name arity type (CExternal s)) +-- @ +-- where s is the external name associated to this function. +-- Thus, a function declaration consists of the name, arity, type, and +-- a list of rules. +-- If the list of rules is empty, the function is considered +-- to be externally defined. +data CFuncDecl = CFunc QName Arity CVisibility CQualTypeExpr [CRule] + deriving (Eq, Read, Show) + +-- |The general form of a function rule. It consists of a list of patterns +-- (left-hand side), a list of guards (@success@ if not present in the +-- source text) with their corresponding right-hand sides, and +-- a list of local declarations. +data CRule = CRule [CPattern] CRhs + deriving (Eq, Read, Show) + +-- |Right-hand-side of a 'CRule' or an @case@ expression +data CRhs + = CSimpleRhs CExpr [CLocalDecl] -- @expr where decls@ + | CGuardedRhs [(CExpr, CExpr)] [CLocalDecl] -- @| cond = expr where decls@ + deriving (Eq, Read, Show) + +-- | Local (let/where) declarations +data CLocalDecl + = CLocalFunc CFuncDecl -- ^ local function declaration + | CLocalPat CPattern CRhs -- ^ local pattern declaration + | CLocalVars [CVarIName] -- ^ local free variable declarations + deriving (Eq, Read, Show) + +-- |Variable names. +-- Object variables occurring in expressions are represented by @(Var i)@ +-- where @i@ is a variable index. +type CVarIName = (Int, String) + +-- |Pattern expressions. +data CPattern + -- |pattern variable (unique index / name) + = CPVar CVarIName + -- |literal (Integer/Float/Char constant) + | CPLit CLiteral + -- |application @(m.c e1 ... en)@ of n-ary constructor @m.c@ + -- (@CPComb (m,c) [e1,...,en]@) + | CPComb QName [CPattern] + -- |as-pattern (extended Curry) + | CPAs CVarIName CPattern + -- |functional pattern (extended Curry) + | CPFuncComb QName [CPattern] + -- |lazy pattern (extended Curry) + | CPLazy CPattern + -- |record pattern (extended curry) + | CPRecord QName [CField CPattern] + deriving (Eq, Read, Show) + +-- | Curry expressions. +data CExpr + -- |variable (unique index / name) + = CVar CVarIName + -- |literal (Integer/Float/Char/String constant) + | CLit CLiteral + -- |a defined symbol with module and name, i.e., a function or a constructor + | CSymbol QName + -- |application (e1 e2) + | CApply CExpr CExpr + -- |lambda abstraction + | CLambda [CPattern] CExpr + -- |local let declarations + | CLetDecl [CLocalDecl] CExpr + -- |do block + | CDoExpr [CStatement] + -- |list comprehension + | CListComp CExpr [CStatement] + -- |case expression + | CCase CCaseType CExpr [(CPattern, CRhs)] + -- |typed expression + | CTyped CExpr CQualTypeExpr + -- |record construction (extended Curry) + | CRecConstr QName [CField CExpr] + -- |record update (extended Curry) + | CRecUpdate CExpr [CField CExpr] + deriving (Eq, Read, Show) + +-- |Literals occurring in an expression or a pattern, +-- either an integer, a float, a character, or a string constant. +-- /Note:/ The constructor definition of 'CIntc' differs from the original +-- PAKCS definition. It uses Haskell type 'Integer' instead of 'Int' +-- to provide an unlimited range of integer numbers. Furthermore, +-- float values are represented with Haskell type 'Double' instead of +-- 'Float' to gain double precision. +data CLiteral + = CIntc Integer -- ^ Int literal + | CFloatc Double -- ^ Float literal + | CCharc Char -- ^ Char literal + | CStringc String -- ^ String literal + deriving (Eq, Read, Show) + +-- |Statements in do expressions and list comprehensions. +data CStatement + = CSExpr CExpr -- ^ an expression (I/O action or boolean) + | CSPat CPattern CExpr -- ^ a pattern definition + | CSLet [CLocalDecl] -- ^ a local let declaration + deriving (Eq, Read, Show) + +-- |Type of case expressions +data CCaseType + = CRigid -- ^ rigid case expression + | CFlex -- ^ flexible case expression + deriving (Eq, Read, Show) diff --git a/src/Curry/Base/Ident.hs b/src/Curry/Base/Ident.hs new file mode 100644 index 0000000000000000000000000000000000000000..b96fc8a6e392cd2e08a7f8ff44b3a261956d3a8c --- /dev/null +++ b/src/Curry/Base/Ident.hs @@ -0,0 +1,1036 @@ +{- | + Module : $Header$ + Description : Identifiers + Copyright : (c) 1999 - 2004, Wolfgang Lux + 2011 - 2013, Björn Peemöller + 2016 , Finn Teegen + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This module provides the implementation of identifiers and some + utility functions for identifiers. + + Identifiers comprise the name of the denoted entity and an /id/, + which can be used for renaming identifiers, e.g., in order to resolve + name conflicts between identifiers from different scopes. An + identifier with an /id/ @0@ is considered as not being renamed + and, hence, its /id/ will not be shown. + + Qualified identifiers may optionally be prefixed by a module name. +-} +{-# LANGUAGE CPP #-} +module Curry.Base.Ident + ( -- * Module identifiers + ModuleIdent (..), mkMIdent, moduleName, escModuleName + , fromModuleName, isValidModuleName, addPositionModuleIdent, mIdentLength + + -- * Local identifiers + , Ident (..), mkIdent, showIdent, escName, identSupply + , globalScope, hasGlobalScope, isRenamed, renameIdent, unRenameIdent + , updIdentName, addPositionIdent, isInfixOp, identLength + + -- * Qualified identifiers + , QualIdent (..), qualName, escQualName, isQInfixOp, qualify + , qualifyWith, qualQualify, qualifyLike, isQualified, unqualify, qualUnqualify + , localIdent, isLocalIdent, updQualIdent, qIdentLength + + -- * Predefined simple identifiers + -- ** Identifiers for modules + , emptyMIdent, mainMIdent, preludeMIdent + -- ** Identifiers for types + , arrowId, unitId, boolId, charId, intId, floatId, listId, ioId, successId + -- ** Identifiers for type classes + , eqId, ordId, enumId, boundedId, readId, showId + , numId, fractionalId + , monadId, monadFailId + , dataId + -- ** Identifiers for constructors + , trueId, falseId, nilId, consId, tupleId, isTupleId, tupleArity + -- ** Identifiers for values + , mainId, minusId, fminusId, applyId, errorId, failedId, idId + , succId, predId, toEnumId, fromEnumId, enumFromId, enumFromThenId + , enumFromToId, enumFromThenToId + , maxBoundId, minBoundId + , lexId, readsPrecId, readParenId + , showsPrecId, showParenId, showStringId + , andOpId, eqOpId, leqOpId, ltOpId, orOpId, appendOpId, dotOpId + , aValueId, dataEqId + , anonId, isAnonId + + -- * Predefined qualified identifiers + -- ** Identifiers for types + , qArrowId, qUnitId, qBoolId, qCharId, qIntId, qFloatId, qListId, qIOId + , qSuccessId, isPrimTypeId + -- ** Identifiers for type classes + , qEqId, qOrdId, qEnumId, qBoundedId, qReadId, qShowId + , qNumId, qFractionalId + , qMonadId, qMonadFailId + , qDataId + -- ** Identifiers for constructors + , qTrueId, qFalseId, qNilId, qConsId, qTupleId, isQTupleId, qTupleArity + -- ** Identifiers for values + , qApplyId, qErrorId, qFailedId, qIdId + , qFromEnumId, qEnumFromId, qEnumFromThenId, qEnumFromToId, qEnumFromThenToId + , qMaxBoundId, qMinBoundId + , qLexId, qReadsPrecId, qReadParenId + , qShowsPrecId, qShowParenId, qShowStringId + , qAndOpId, qEqOpId, qLeqOpId, qLtOpId, qOrOpId, qAppendOpId, qDotOpId + , qAValueId, qDataEqId + + -- * Extended functionality + -- ** Functional patterns + , fpSelectorId, isFpSelectorId, isQualFpSelectorId + -- ** Records + , recSelectorId, qualRecSelectorId, recUpdateId, qualRecUpdateId + , recordExt, recordExtId, isRecordExtId, fromRecordExtId + , labelExt, labelExtId, isLabelExtId, fromLabelExtId + , renameLabel, mkLabelIdent + ) where + +import Prelude hiding ((<>)) +import Data.Char (isAlpha, isAlphaNum) +import Data.Function (on) +import Data.List (intercalate, isInfixOf, isPrefixOf) +import Data.Maybe (isJust, fromMaybe) +import Data.Binary +import Control.Monad + +import Curry.Base.Position +import Curry.Base.Span hiding (file) +import Curry.Base.SpanInfo +import Curry.Base.Pretty + +-- --------------------------------------------------------------------------- +-- Module identifier +-- --------------------------------------------------------------------------- + +-- | Module identifier +data ModuleIdent = ModuleIdent + { midSpanInfo :: SpanInfo -- ^ source code 'SpanInfo' + , midQualifiers :: [String] -- ^ hierarchical idenfiers + } deriving (Read, Show) + +instance Eq ModuleIdent where + (==) = (==) `on` midQualifiers + +instance Ord ModuleIdent where + compare = compare `on` midQualifiers + +instance HasSpanInfo ModuleIdent where + getSpanInfo = midSpanInfo + setSpanInfo spi a = a { midSpanInfo = spi } + updateEndPos i = + setEndPosition (incr (getPosition i) (mIdentLength i - 1)) i + +instance HasPosition ModuleIdent where + getPosition = getStartPosition + setPosition = setStartPosition + +instance Pretty ModuleIdent where + pPrint = hcat . punctuate dot . map text . midQualifiers + +instance Binary ModuleIdent where + put (ModuleIdent sp qs) = put sp >> put qs + get = liftM2 ModuleIdent get get + +mIdentLength :: ModuleIdent -> Int +mIdentLength a = length (concat (midQualifiers a)) + + length (midQualifiers a) + +-- |Construct a 'ModuleIdent' from a list of 'String's forming the +-- the hierarchical module name. +mkMIdent :: [String] -> ModuleIdent +mkMIdent = ModuleIdent NoSpanInfo + +-- |Retrieve the hierarchical name of a module +moduleName :: ModuleIdent -> String +moduleName = intercalate "." . midQualifiers + +-- |Show the name of an 'ModuleIdent' escaped by ticks +escModuleName :: ModuleIdent -> String +escModuleName m = '`' : moduleName m ++ "'" + +-- |Add a source code 'Position' to a 'ModuleIdent' +addPositionModuleIdent :: Position -> ModuleIdent -> ModuleIdent +addPositionModuleIdent = setPosition + +-- |Check whether a 'String' is a valid module name. +-- +-- Valid module names must satisfy the following conditions: +-- +-- * The name must not be empty +-- * The name must consist of one or more single identifiers, +-- seperated by dots +-- * Each single identifier must be non-empty, start with a letter and +-- consist of letter, digits, single quotes or underscores only +isValidModuleName :: String -> Bool +isValidModuleName [] = False -- Module names may not be empty +isValidModuleName qs = all isModuleIdentifier $ splitIdentifiers qs + where + -- components of a module identifier may not be null + isModuleIdentifier [] = False + -- components of a module identifier must start with a letter and consist + -- of letter, digits, underscores or single quotes + isModuleIdentifier (c:cs) = isAlpha c && all isIdent cs + isIdent c = isAlphaNum c || c `elem` "'_" + +-- |Resemble the hierarchical module name from a 'String' by splitting +-- the 'String' at inner dots. +-- +-- /Note:/ This function does not check the 'String' to be a valid module +-- identifier, use isValidModuleName for this purpose. +fromModuleName :: String -> ModuleIdent +fromModuleName = mkMIdent . splitIdentifiers + +-- Auxiliary function to split a hierarchical module identifier at the dots +splitIdentifiers :: String -> [String] +splitIdentifiers s = let (pref, rest) = break (== '.') s in + pref : case rest of + [] -> [] + (_:s') -> splitIdentifiers s' + +-- --------------------------------------------------------------------------- +-- Simple identifier +-- --------------------------------------------------------------------------- + +-- |Simple identifier +data Ident = Ident + { idSpanInfo :: SpanInfo -- ^ Source code 'SpanInfo' + , idName :: String -- ^ Name of the identifier + , idUnique :: Integer -- ^ Unique number of the identifier + } deriving (Read, Show) + +instance Eq Ident where + Ident _ m i == Ident _ n j = (m, i) == (n, j) + +instance Ord Ident where + Ident _ m i `compare` Ident _ n j = (m, i) `compare` (n, j) + +instance HasSpanInfo Ident where + getSpanInfo = idSpanInfo + setSpanInfo spi a = a { idSpanInfo = spi } + updateEndPos i@(Ident (SpanInfo _ [_,ss]) _ _) = + setEndPosition (end ss) i + updateEndPos i = + setEndPosition (incr (getPosition i) (identLength i - 1)) i + +instance HasPosition Ident where + getPosition = getStartPosition + setPosition = setStartPosition + +instance Pretty Ident where + pPrint (Ident _ x n) | n == globalScope = text x + | otherwise = text x <> dot <> integer n + +instance Binary Ident where + put (Ident sp qs i) = put sp >> put qs >> put i + get = liftM3 Ident get get get + +identLength :: Ident -> Int +identLength a = length (idName a) + +-- |Global scope for renaming +globalScope :: Integer +globalScope = 0 + +-- |Construct an 'Ident' from a 'String' +mkIdent :: String -> Ident +mkIdent x = Ident NoSpanInfo x globalScope + +-- |Infinite list of different 'Ident's +identSupply :: [Ident] +identSupply = [ mkNewIdent c i | i <- [0 ..] :: [Integer], c <- ['a'..'z'] ] + where mkNewIdent c 0 = mkIdent [c] + mkNewIdent c n = mkIdent $ c : show n + +-- |Show function for an 'Ident' +showIdent :: Ident -> String +showIdent (Ident _ x n) | n == globalScope = x + | otherwise = x ++ '.' : show n + +-- |Show the name of an 'Ident' escaped by ticks +escName :: Ident -> String +escName i = '`' : idName i ++ "'" + +-- |Has the identifier global scope? +hasGlobalScope :: Ident -> Bool +hasGlobalScope = (== globalScope) . idUnique + +-- |Is the 'Ident' renamed? +isRenamed :: Ident -> Bool +isRenamed = (/= globalScope) . idUnique + +-- |Rename an 'Ident' by changing its unique number +renameIdent :: Ident -> Integer -> Ident +renameIdent ident n = ident { idUnique = n } + +-- |Revert the renaming of an 'Ident' by resetting its unique number +unRenameIdent :: Ident -> Ident +unRenameIdent ident = renameIdent ident globalScope + +-- |Change the name of an 'Ident' using a renaming function +updIdentName :: (String -> String) -> Ident -> Ident +updIdentName f (Ident p n i) = Ident p (f n) i + +-- |Add a 'Position' to an 'Ident' +addPositionIdent :: Position -> Ident -> Ident +addPositionIdent = setPosition + +-- |Check whether an 'Ident' identifies an infix operation +isInfixOp :: Ident -> Bool +isInfixOp (Ident _ ('<' : c : cs) _) = + last (c : cs) /= '>' || not (isAlphaNum c) && c `notElem` "_([" +isInfixOp (Ident _ (c : _) _) = not (isAlphaNum c) && c `notElem` "_([" +isInfixOp Ident{} = False -- error "Zero-length identifier" + +-- --------------------------------------------------------------------------- +-- Qualified identifier +-- --------------------------------------------------------------------------- + +-- |Qualified identifier +data QualIdent = QualIdent + { qidSpanInfo :: SpanInfo -- ^ Source code 'SpanInfo' + , qidModule :: Maybe ModuleIdent -- ^ optional module identifier + , qidIdent :: Ident -- ^ identifier itself + } deriving (Read, Show) + +instance Eq QualIdent where + QualIdent _ m i == QualIdent _ n j = (m, i) == (n, j) + +instance Ord QualIdent where + QualIdent _ m i `compare` QualIdent _ n j = (m, i) `compare` (n, j) + +instance HasSpanInfo QualIdent where + getSpanInfo = qidSpanInfo + setSpanInfo spi a = a { qidSpanInfo = spi } + updateEndPos i@(QualIdent (SpanInfo _ [_,ss]) _ _) = + setEndPosition (end ss) i + updateEndPos i = + setEndPosition (incr (getPosition i) (qIdentLength i - 1)) i + +instance HasPosition QualIdent where + getPosition = getStartPosition + setPosition = setStartPosition + +instance Pretty QualIdent where + pPrint = text . qualName + +instance Binary QualIdent where + put (QualIdent sp mid idt) = put sp >> put mid >> put idt + get = liftM3 QualIdent get get get + +qIdentLength :: QualIdent -> Int +qIdentLength (QualIdent _ (Just m) i) = identLength i + mIdentLength m +qIdentLength (QualIdent _ Nothing i) = identLength i + +-- |show function for qualified identifiers)= +qualName :: QualIdent -> String +qualName (QualIdent _ Nothing x) = idName x +qualName (QualIdent _ (Just m) x) = moduleName m ++ "." ++ idName x + +-- |Show the name of an 'QualIdent' escaped by ticks +escQualName :: QualIdent -> String +escQualName qn = '`' : qualName qn ++ "'" + +-- |Check whether an 'QualIdent' identifies an infix operation +isQInfixOp :: QualIdent -> Bool +isQInfixOp = isInfixOp . qidIdent + +-- --------------------------------------------------------------------------- +-- The functions \texttt{qualify} and \texttt{qualifyWith} convert an +-- unqualified identifier into a qualified identifier (without and with a +-- given module prefix, respectively). +-- --------------------------------------------------------------------------- + +-- | Convert an 'Ident' to a 'QualIdent' +qualify :: Ident -> QualIdent +qualify i = QualIdent (fromSrcSpan (getSrcSpan i)) Nothing i + +-- | Convert an 'Ident' to a 'QualIdent' with a given 'ModuleIdent' +qualifyWith :: ModuleIdent -> Ident -> QualIdent +qualifyWith mid i = updateEndPos $ + QualIdent (fromSrcSpan (getSrcSpan mid)) (Just mid) i + +-- | Convert an 'QualIdent' to a new 'QualIdent' with a given 'ModuleIdent'. +-- If the original 'QualIdent' already contains an 'ModuleIdent' it +-- remains unchanged. +qualQualify :: ModuleIdent -> QualIdent -> QualIdent +qualQualify m (QualIdent _ Nothing x) = qualifyWith m x +qualQualify _ x = x + +-- |Qualify an 'Ident' with the 'ModuleIdent' of the given 'QualIdent', +-- if present. +qualifyLike :: QualIdent -> Ident -> QualIdent +qualifyLike (QualIdent _ Nothing _) x = qualify x +qualifyLike (QualIdent _ (Just m) _) x = qualifyWith m x + +-- | Check whether a 'QualIdent' contains a 'ModuleIdent' +isQualified :: QualIdent -> Bool +isQualified = isJust . qidModule + +-- | Remove the qualification of an 'QualIdent' +unqualify :: QualIdent -> Ident +unqualify = qidIdent + +-- | Remove the qualification with a specific 'ModuleIdent'. If the +-- original 'QualIdent' has no 'ModuleIdent' or a different one, it +-- remains unchanged. +qualUnqualify :: ModuleIdent -> QualIdent -> QualIdent +qualUnqualify _ qid@(QualIdent _ Nothing _) = qid +qualUnqualify m (QualIdent spi (Just m') x) = QualIdent spi m'' x + where m'' | m == m' = Nothing + | otherwise = Just m' + +-- | Extract the 'Ident' of an 'QualIdent' if it is local to the +-- 'ModuleIdent', i.e. if the 'Ident' is either unqualified or qualified +-- with the given 'ModuleIdent'. +localIdent :: ModuleIdent -> QualIdent -> Maybe Ident +localIdent _ (QualIdent _ Nothing x) = Just x +localIdent m (QualIdent _ (Just m') x) + | m == m' = Just x + | otherwise = Nothing + +-- |Check whether the given 'QualIdent' is local to the given 'ModuleIdent'. +isLocalIdent :: ModuleIdent -> QualIdent -> Bool +isLocalIdent mid qid = isJust (localIdent mid qid) + +-- | Update a 'QualIdent' by applying functions to its components +updQualIdent :: (ModuleIdent -> ModuleIdent) -> (Ident -> Ident) + -> QualIdent -> QualIdent +updQualIdent f g (QualIdent spi m x) = QualIdent spi (fmap f m) (g x) + +-- --------------------------------------------------------------------------- +-- A few identifiers are predefined here. +-- --------------------------------------------------------------------------- +-- | 'ModuleIdent' for the empty module +emptyMIdent :: ModuleIdent +emptyMIdent = ModuleIdent NoSpanInfo [] + +-- | 'ModuleIdent' for the main module +mainMIdent :: ModuleIdent +mainMIdent = ModuleIdent NoSpanInfo ["main"] + +-- | 'ModuleIdent' for the Prelude +preludeMIdent :: ModuleIdent +preludeMIdent = ModuleIdent NoSpanInfo ["Prelude"] + +-- --------------------------------------------------------------------------- +-- Identifiers for types +-- --------------------------------------------------------------------------- + +-- | 'Ident' for the type '(->)' +arrowId :: Ident +arrowId = mkIdent "(->)" + +-- | 'Ident' for the type/value unit ('()') +unitId :: Ident +unitId = mkIdent "()" + +-- | 'Ident' for the type 'Bool' +boolId :: Ident +boolId = mkIdent "Bool" + +-- | 'Ident' for the type 'Char' +charId :: Ident +charId = mkIdent "Char" + +-- | 'Ident' for the type 'Int' +intId :: Ident +intId = mkIdent "Int" + +-- | 'Ident' for the type 'Float' +floatId :: Ident +floatId = mkIdent "Float" + +-- | 'Ident' for the type '[]' +listId :: Ident +listId = mkIdent "[]" + +-- | 'Ident' for the type 'IO' +ioId :: Ident +ioId = mkIdent "IO" + +-- | 'Ident' for the type 'Success' +successId :: Ident +successId = mkIdent "Success" + +-- | Construct an 'Ident' for an n-ary tuple where n > 1 +tupleId :: Int -> Ident +tupleId n + | n > 1 = mkIdent $ '(' : replicate (n - 1) ',' ++ ")" + | otherwise = error $ "Curry.Base.Ident.tupleId: wrong arity " ++ show n + +-- | Check whether an 'Ident' is an identifier for an tuple type +isTupleId :: Ident -> Bool +isTupleId (Ident _ x _) = n > 1 && x == idName (tupleId n) + where n = length x - 1 + +-- | Compute the arity of a tuple identifier +tupleArity :: Ident -> Int +tupleArity i@(Ident _ x _) + | n > 1 && x == idName (tupleId n) = n + | otherwise = error $ + "Curry.Base.Ident.tupleArity: no tuple identifier: " ++ showIdent i + where n = length x - 1 + +-- --------------------------------------------------------------------------- +-- Identifiers for type classes +-- --------------------------------------------------------------------------- + +-- | 'Ident' for the 'Eq' class +eqId :: Ident +eqId = mkIdent "Eq" + +-- | 'Ident' for the 'Ord' class +ordId :: Ident +ordId = mkIdent "Ord" + +-- | 'Ident' for the 'Enum' class +enumId :: Ident +enumId = mkIdent "Enum" + +-- | 'Ident' for the 'Bounded' class +boundedId :: Ident +boundedId = mkIdent "Bounded" + +-- | 'Ident' for the 'Read' class +readId :: Ident +readId = mkIdent "Read" + +-- | 'Ident' for the 'Show' class +showId :: Ident +showId = mkIdent "Show" + +-- | 'Ident' for the 'Num' class +numId :: Ident +numId = mkIdent "Num" + +-- | 'Ident' for the 'Fractional' class +fractionalId :: Ident +fractionalId = mkIdent "Fractional" + +-- | 'Ident' for the 'Monad' class +monadId :: Ident +monadId = mkIdent "Monad" + +-- | 'Ident' for the 'MonadFail' class +monadFailId :: Ident +monadFailId = mkIdent "MonadFail" + +-- | 'Ident' for the 'Data' class +dataId :: Ident +dataId = mkIdent "Data" + +-- --------------------------------------------------------------------------- +-- Identifiers for constructors +-- --------------------------------------------------------------------------- + +-- | 'Ident' for the value 'True' +trueId :: Ident +trueId = mkIdent "True" + +-- | 'Ident' for the value 'False' +falseId :: Ident +falseId = mkIdent "False" + +-- | 'Ident' for the value '[]' +nilId :: Ident +nilId = mkIdent "[]" + +-- | 'Ident' for the function ':' +consId :: Ident +consId = mkIdent ":" + +-- --------------------------------------------------------------------------- +-- Identifiers for values +-- --------------------------------------------------------------------------- + +-- | 'Ident' for the main function +mainId :: Ident +mainId = mkIdent "main" + +-- | 'Ident' for the minus function +minusId :: Ident +minusId = mkIdent "-" + +-- | 'Ident' for the minus function for Floats +fminusId :: Ident +fminusId = mkIdent "-." + +-- | 'Ident' for the apply function +applyId :: Ident +applyId = mkIdent "apply" + +-- | 'Ident' for the error function +errorId :: Ident +errorId = mkIdent "error" + +-- | 'Ident' for the failed function +failedId :: Ident +failedId = mkIdent "failed" + +-- | 'Ident' for the id function +idId :: Ident +idId = mkIdent "id" + +-- | 'Ident' for the maxBound function +maxBoundId :: Ident +maxBoundId = mkIdent "maxBound" + +-- | 'Ident' for the minBound function +minBoundId :: Ident +minBoundId = mkIdent "minBound" + +-- | 'Ident' for the pred function +predId :: Ident +predId = mkIdent "pred" + +-- | 'Ident' for the succ function +succId :: Ident +succId = mkIdent "succ" + +-- | 'Ident' for the toEnum function +toEnumId :: Ident +toEnumId = mkIdent "toEnum" + +-- | 'Ident' for the fromEnum function +fromEnumId :: Ident +fromEnumId = mkIdent "fromEnum" + +-- | 'Ident' for the enumFrom function +enumFromId :: Ident +enumFromId = mkIdent "enumFrom" + +-- | 'Ident' for the enumFromThen function +enumFromThenId :: Ident +enumFromThenId = mkIdent "enumFromThen" + +-- | 'Ident' for the enumFromTo function +enumFromToId :: Ident +enumFromToId = mkIdent "enumFromTo" + +-- | 'Ident' for the enumFromThenTo function +enumFromThenToId :: Ident +enumFromThenToId = mkIdent "enumFromThenTo" + +-- | 'Ident' for the lex function +lexId :: Ident +lexId = mkIdent "lex" + +-- | 'Ident' for the readsPrec function +readsPrecId :: Ident +readsPrecId = mkIdent "readsPrec" + +-- | 'Ident' for the readParen function +readParenId :: Ident +readParenId = mkIdent "readParen" + +-- | 'Ident' for the showsPrec function +showsPrecId :: Ident +showsPrecId = mkIdent "showsPrec" + +-- | 'Ident' for the showParen function +showParenId :: Ident +showParenId = mkIdent "showParen" + +-- | 'Ident' for the showString function +showStringId :: Ident +showStringId = mkIdent "showString" + +-- | 'Ident' for the '&&' operator +andOpId :: Ident +andOpId = mkIdent "&&" + +-- | 'Ident' for the '==' operator +eqOpId :: Ident +eqOpId = mkIdent "==" + +-- | 'Ident' for the '<=' operator +leqOpId :: Ident +leqOpId = mkIdent "<=" + +-- | 'Ident' for the '<' operator +ltOpId :: Ident +ltOpId = mkIdent "<" + +-- | 'Ident' for the '||' operator +orOpId :: Ident +orOpId = mkIdent "||" + +-- | 'Ident' for the '++' operator +appendOpId :: Ident +appendOpId = mkIdent "++" + +-- | 'Ident' for the '.' operator +dotOpId :: Ident +dotOpId = mkIdent "." + +aValueId :: Ident +aValueId = mkIdent "aValue" + +dataEqId :: Ident +dataEqId = mkIdent "===" + +-- | 'Ident' for anonymous variable +anonId :: Ident +anonId = mkIdent "_" + +-- |Check whether an 'Ident' represents an anonymous identifier ('anonId') +isAnonId :: Ident -> Bool +isAnonId = (== anonId) . unRenameIdent + +-- --------------------------------------------------------------------------- +-- Qualified Identifiers for types +-- --------------------------------------------------------------------------- + +-- | Construct a 'QualIdent' for an 'Ident' using the module prelude +qPreludeIdent :: Ident -> QualIdent +qPreludeIdent = qualifyWith preludeMIdent + +-- | 'QualIdent' for the type '(->)' +qArrowId :: QualIdent +qArrowId = qualify arrowId + +-- | 'QualIdent' for the type/value unit ('()') +qUnitId :: QualIdent +qUnitId = qualify unitId + +-- | 'QualIdent' for the type '[]' +qListId :: QualIdent +qListId = qualify listId + +-- | 'QualIdent' for the type 'Bool' +qBoolId :: QualIdent +qBoolId = qPreludeIdent boolId + +-- | 'QualIdent' for the type 'Char' +qCharId :: QualIdent +qCharId = qPreludeIdent charId + +-- | 'QualIdent' for the type 'Int' +qIntId :: QualIdent +qIntId = qPreludeIdent intId + +-- | 'QualIdent' for the type 'Float' +qFloatId :: QualIdent +qFloatId = qPreludeIdent floatId + +-- | 'QualIdent' for the type 'IO' +qIOId :: QualIdent +qIOId = qPreludeIdent ioId + +-- | 'QualIdent' for the type 'Success' +qSuccessId :: QualIdent +qSuccessId = qPreludeIdent successId + +-- | Check whether an 'QualIdent' is an primary type constructor +isPrimTypeId :: QualIdent -> Bool +isPrimTypeId tc = tc `elem` [qArrowId, qUnitId, qListId] || isQTupleId tc + +-- --------------------------------------------------------------------------- +-- Qualified Identifiers for type classes +-- --------------------------------------------------------------------------- + +-- | 'QualIdent' for the 'Eq' class +qEqId :: QualIdent +qEqId = qPreludeIdent eqId + +-- | 'QualIdent' for the 'Ord' class +qOrdId :: QualIdent +qOrdId = qPreludeIdent ordId + +-- | 'QualIdent' for the 'Enum' class +qEnumId :: QualIdent +qEnumId = qPreludeIdent enumId + +-- | 'QualIdent' for the 'Bounded' class +qBoundedId :: QualIdent +qBoundedId = qPreludeIdent boundedId + +-- | 'QualIdent' for the 'Read' class +qReadId :: QualIdent +qReadId = qPreludeIdent readId + +-- | 'QualIdent' for the 'Show' class +qShowId :: QualIdent +qShowId = qPreludeIdent showId + +-- | 'QualIdent' for the 'Num' class +qNumId :: QualIdent +qNumId = qPreludeIdent numId + +-- | 'QualIdent' for the 'Fractional' class +qFractionalId :: QualIdent +qFractionalId = qPreludeIdent fractionalId + +-- | 'QualIdent' for the 'Monad' class +qMonadId :: QualIdent +qMonadId = qPreludeIdent monadId + +-- | 'QualIdent' for the 'MonadFail' class +qMonadFailId :: QualIdent +qMonadFailId = qPreludeIdent monadFailId + +-- | 'QualIdent' for the 'Data' class +qDataId :: QualIdent +qDataId = qPreludeIdent dataId + +-- --------------------------------------------------------------------------- +-- Qualified Identifiers for constructors +-- --------------------------------------------------------------------------- + +-- | 'QualIdent' for the constructor 'True' +qTrueId :: QualIdent +qTrueId = qPreludeIdent trueId + +-- | 'QualIdent' for the constructor 'False' +qFalseId :: QualIdent +qFalseId = qPreludeIdent falseId + +-- | 'QualIdent' for the constructor '[]' +qNilId :: QualIdent +qNilId = qualify nilId + +-- | 'QualIdent' for the constructor ':' +qConsId :: QualIdent +qConsId = qualify consId + +-- | 'QualIdent' for the type of n-ary tuples +qTupleId :: Int -> QualIdent +qTupleId = qualify . tupleId + +-- | Check whether an 'QualIdent' is an identifier for an tuple type +isQTupleId :: QualIdent -> Bool +isQTupleId = isTupleId . unqualify + +-- | Compute the arity of an qualified tuple identifier +qTupleArity :: QualIdent -> Int +qTupleArity = tupleArity . unqualify + +-- --------------------------------------------------------------------------- +-- Qualified Identifiers for values +-- --------------------------------------------------------------------------- + +-- | 'QualIdent' for the apply function +qApplyId :: QualIdent +qApplyId = qPreludeIdent applyId + +-- | 'QualIdent' for the error function +qErrorId :: QualIdent +qErrorId = qPreludeIdent errorId + +-- | 'QualIdent' for the failed function +qFailedId :: QualIdent +qFailedId = qPreludeIdent failedId + +-- | 'QualIdent' for the id function +qIdId :: QualIdent +qIdId = qPreludeIdent idId + +-- | 'QualIdent' for the maxBound function +qMaxBoundId :: QualIdent +qMaxBoundId = qPreludeIdent maxBoundId + +-- | 'QualIdent' for the minBound function +qMinBoundId :: QualIdent +qMinBoundId = qPreludeIdent minBoundId + +-- | 'QualIdent' for the fromEnum function +qFromEnumId :: QualIdent +qFromEnumId = qPreludeIdent fromEnumId + +-- | 'QualIdent' for the enumFrom function +qEnumFromId :: QualIdent +qEnumFromId = qPreludeIdent enumFromId + +-- | 'QualIdent' for the enumFromThen function +qEnumFromThenId :: QualIdent +qEnumFromThenId = qPreludeIdent enumFromThenId + +-- | 'QualIdent' for the enumFromTo function +qEnumFromToId :: QualIdent +qEnumFromToId = qPreludeIdent enumFromToId + +-- | 'QualIdent' for the enumFromThenTo function +qEnumFromThenToId :: QualIdent +qEnumFromThenToId = qPreludeIdent enumFromThenToId + +-- | 'QualIdent' for the lex function +qLexId :: QualIdent +qLexId = qPreludeIdent lexId + +-- | 'QualIdent' for the readsPrec function +qReadsPrecId :: QualIdent +qReadsPrecId = qPreludeIdent readsPrecId + +-- | 'QualIdent' for the readParen function +qReadParenId :: QualIdent +qReadParenId = qPreludeIdent readParenId + +-- | 'QualIdent' for the showsPrec function +qShowsPrecId :: QualIdent +qShowsPrecId = qPreludeIdent showsPrecId + +-- | 'QualIdent' for the showParen function +qShowParenId :: QualIdent +qShowParenId = qPreludeIdent showParenId + +-- | 'QualIdent' for the showString function +qShowStringId :: QualIdent +qShowStringId = qPreludeIdent showStringId + +-- | 'QualIdent' for the '&&' operator +qAndOpId :: QualIdent +qAndOpId = qPreludeIdent andOpId + +-- | 'QualIdent' for the '==' operator +qEqOpId :: QualIdent +qEqOpId = qPreludeIdent eqOpId + +-- | 'QualIdent' for the '<=' operator +qLeqOpId :: QualIdent +qLeqOpId = qPreludeIdent leqOpId + +-- | 'QualIdent' for the '<' operator +qLtOpId :: QualIdent +qLtOpId = qPreludeIdent ltOpId + +-- | 'QualIdent' for the '||' operator +qOrOpId :: QualIdent +qOrOpId = qPreludeIdent orOpId + +-- | 'QualIdent' for the '.' operator +qDotOpId :: QualIdent +qDotOpId = qPreludeIdent dotOpId + +qAValueId :: QualIdent +qAValueId = qPreludeIdent aValueId + +qDataEqId :: QualIdent +qDataEqId = qPreludeIdent dataEqId + +-- | 'QualIdent' for the '++' operator +qAppendOpId :: QualIdent +qAppendOpId = qPreludeIdent appendOpId + +-- --------------------------------------------------------------------------- +-- Micellaneous functions for generating and testing extended identifiers +-- --------------------------------------------------------------------------- + +-- Functional patterns + +-- | Annotation for function pattern identifiers +fpSelExt :: String +fpSelExt = "_#selFP" + +-- | Construct an 'Ident' for a functional pattern +fpSelectorId :: Int -> Ident +fpSelectorId n = mkIdent $ fpSelExt ++ show n + +-- | Check whether an 'Ident' is an identifier for a functional pattern +isFpSelectorId :: Ident -> Bool +isFpSelectorId = (fpSelExt `isInfixOf`) . idName + +-- | Check whether an 'QualIdent' is an identifier for a function pattern +isQualFpSelectorId :: QualIdent -> Bool +isQualFpSelectorId = isFpSelectorId . unqualify + +-- Record selection + +-- | Annotation for record selection identifiers +recSelExt :: String +recSelExt = "_#selR@" + +-- | Construct an 'Ident' for a record selection pattern +recSelectorId :: QualIdent -- ^ identifier of the record + -> Ident -- ^ identifier of the label + -> Ident +recSelectorId = mkRecordId recSelExt + +-- | Construct a 'QualIdent' for a record selection pattern +qualRecSelectorId :: ModuleIdent -- ^ default module + -> QualIdent -- ^ record identifier + -> Ident -- ^ label identifier + -> QualIdent +qualRecSelectorId m r l = qualRecordId m r $ recSelectorId r l + +-- Record update + +-- | Annotation for record update identifiers +recUpdExt :: String +recUpdExt = "_#updR@" + +-- | Construct an 'Ident' for a record update pattern +recUpdateId :: QualIdent -- ^ record identifier + -> Ident -- ^ label identifier + -> Ident +recUpdateId = mkRecordId recUpdExt + +-- | Construct a 'QualIdent' for a record update pattern +qualRecUpdateId :: ModuleIdent -- ^ default module + -> QualIdent -- ^ record identifier + -> Ident -- ^ label identifier + -> QualIdent +qualRecUpdateId m r l = qualRecordId m r $ recUpdateId r l + +-- Auxiliary function to construct a selector/update identifier +mkRecordId :: String -> QualIdent -> Ident -> Ident +mkRecordId ann r l = mkIdent $ concat + [ann, idName (unqualify r), ".", idName l] + +-- Auxiliary function to qualify a selector/update identifier +qualRecordId :: ModuleIdent -> QualIdent -> Ident -> QualIdent +qualRecordId m r = qualifyWith (fromMaybe m $ qidModule r) + +-- Record tyes + +-- | Annotation for record identifiers +recordExt :: String +recordExt = "_#Rec:" + +-- | Construct an 'Ident' for a record +recordExtId :: Ident -> Ident +recordExtId r = mkIdent $ recordExt ++ idName r + +-- | Check whether an 'Ident' is an identifier for a record +isRecordExtId :: Ident -> Bool +isRecordExtId = (recordExt `isPrefixOf`) . idName + +-- | Retrieve the 'Ident' from a record identifier +fromRecordExtId :: Ident -> Ident +fromRecordExtId r + | p == recordExt = mkIdent r' + | otherwise = r + where (p, r') = splitAt (length recordExt) (idName r) + +-- Record labels + +-- | Annotation for record label identifiers +labelExt :: String +labelExt = "_#Lab:" + +-- | Construct an 'Ident' for a record label +labelExtId :: Ident -> Ident +labelExtId l = mkIdent $ labelExt ++ idName l + +-- | Check whether an 'Ident' is an identifier for a record label +isLabelExtId :: Ident -> Bool +isLabelExtId = (labelExt `isPrefixOf`) . idName + +-- | Retrieve the 'Ident' from a record label identifier +fromLabelExtId :: Ident -> Ident +fromLabelExtId l + | p == labelExt = mkIdent l' + | otherwise = l + where (p, l') = splitAt (length labelExt) (idName l) + +-- | Construct an 'Ident' for a record label +mkLabelIdent :: String -> Ident +mkLabelIdent c = renameIdent (mkIdent c) (-1) + +-- | Rename an 'Ident' for a record label +renameLabel :: Ident -> Ident +renameLabel l = renameIdent l (-1) diff --git a/src/Curry/Base/LLParseComb.hs b/src/Curry/Base/LLParseComb.hs new file mode 100644 index 0000000000000000000000000000000000000000..0233f74e7ad2dde43b939d579423d37540253206 --- /dev/null +++ b/src/Curry/Base/LLParseComb.hs @@ -0,0 +1,380 @@ +{- | + Module : $Header$ + Description : Parser combinators + Copyright : (c) 1999-2004, Wolfgang Lux + 2016 , Jan Tikovsky + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + The parsing combinators implemented in this module are based on the + LL(1) parsing combinators developed by Swierstra and Duponcheel. + They have been adapted to using continuation passing style in order to + work with the lexing combinators described in the previous section. + In addition, the facilities for error correction are omitted + in this implementation. + + The two functions 'applyParser' and 'prefixParser' use the specified + parser for parsing a string. When 'applyParser' is used, an error is + reported if the parser does not consume the whole string, + whereas 'prefixParser' discards the rest of the input string in this case. +-} +{-# LANGUAGE CPP #-} + +module Curry.Base.LLParseComb + ( -- * Data types + Parser + + -- * Parser application + , fullParser, prefixParser + + -- * Basic parsers + , position, spanPosition, succeed, failure, symbol + + -- * parser combinators + , (), (<|>), (<|?>), (<*>), (<\>), (<\\>) + , (<$>), (<$->), (<*->), (<-*>), (<**>), (), (<.>) + , opt, choice, flag, optional, option, many, many1, sepBy, sepBy1 + , sepBySp, sepBy1Sp + , chainr, chainr1, chainl, chainl1, between, ops + + -- * Layout combinators + , layoutOn, layoutOff, layoutEnd + ) where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative (Applicative, (<*>), (<$>), pure) +#endif +import Control.Monad +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Set as Set + +import Curry.Base.LexComb +import Curry.Base.Position +import Curry.Base.Span (span2Pos, Span, startCol, setDistance) + +infixl 5 <\>, <\\> +infixl 4 <$->, <*->, <-*>, <**>, , <.> +infixl 3 <|>, <|?> +infixl 2 , `opt` + +-- --------------------------------------------------------------------------- +-- Parser types +-- --------------------------------------------------------------------------- + +-- |Parsing function +type ParseFun a s b = (b -> SuccessP s a) -> FailP a -> SuccessP s a + +-- |CPS-Parser type +data Parser a s b = Parser + -- Parsing function for empty word + (Maybe (ParseFun a s b)) + -- Lookup table (continuations for 'Symbol's recognized by the parser) + (Map.Map s (Lexer s a -> ParseFun a s b)) + +instance Symbol s => Functor (Parser a s) where + fmap f p = succeed f <*> p + +instance Symbol s => Applicative (Parser a s) where + pure = succeed + + -- |Apply the result function of the first parser to the result of the + -- second parser. + Parser Nothing ps1 <*> p2 = Parser Nothing + (fmap (`seqPP` p2) ps1) + Parser (Just p1) ps1 <*> ~p2@(Parser e2 ps2) = Parser (fmap (seqEE p1) e2) + (Map.union (fmap (`seqPP` p2) ps1) (fmap (seqEP p1) ps2)) + +instance Show s => Show (Parser a s b) where + showsPrec p (Parser e ps) = showParen (p >= 10) $ + showString "Parser " . shows (isJust e) . + showChar ' ' . shows (Map.keysSet ps) + +-- --------------------------------------------------------------------------- +-- Parser application +-- --------------------------------------------------------------------------- + +-- |Apply a parser and lexer to a 'String', whereas the 'FilePath' is used +-- to identify the origin of the 'String' in case of parsing errors. +fullParser :: Symbol s => Parser a s a -> Lexer s a -> FilePath -> String + -> CYM a +fullParser p lexer = parse (lexer (choose p lexer successP failP) failP) + where successP x pos s + | isEOF s = returnP x + | otherwise = failP pos (unexpected s) + +-- |Apply a parser and lexer to parse the beginning of a 'String'. +-- The 'FilePath' is used to identify the origin of the 'String' in case of +-- parsing errors. +prefixParser :: Symbol s => Parser a s a -> Lexer s a -> FilePath -> String + -> CYM a +prefixParser p lexer = parse (lexer (choose p lexer discardP failP) failP) + where discardP x _ _ = returnP x + +-- |Choose the appropriate parsing function w.r.t. to the next 'Symbol'. +choose :: Symbol s => Parser a s b -> Lexer s a -> ParseFun a s b +choose (Parser e ps) lexer success failp pos s = case Map.lookup s ps of + Just p -> p lexer success failp pos s + Nothing -> case e of + Just p -> p success failp pos s + Nothing -> failp pos (unexpected s) + +-- |Fail on an unexpected 'Symbol' +unexpected :: Symbol s => s -> String +unexpected s + | isEOF s = "Unexpected end-of-file" + | otherwise = "Unexpected token " ++ show s + +-- --------------------------------------------------------------------------- +-- Basic parsers +-- --------------------------------------------------------------------------- + +-- |Return the current position without consuming the input +position :: Parser a s Position +position = Parser (Just p) Map.empty + where p success _ sp = success (span2Pos sp) sp + +spanPosition :: Symbol s => Parser a s Span +spanPosition = Parser (Just p) Map.empty + where p success _ sp s = success (setDistance sp (dist (startCol sp) s)) sp s + +-- |Always succeeding parser +succeed :: b -> Parser a s b +succeed x = Parser (Just p) Map.empty + where p success _ = success x + +-- |Always failing parser with a given message +failure :: String -> Parser a s b +failure msg = Parser (Just p) Map.empty + where p _ failp pos _ = failp pos msg + +-- |Create a parser accepting the given 'Symbol' +symbol :: s -> Parser a s s +symbol s = Parser Nothing (Map.singleton s p) + where p lexer success failp _ s' = lexer (success s') failp + +-- --------------------------------------------------------------------------- +-- Parser combinators +-- --------------------------------------------------------------------------- + +-- |Behave like the given parser, but use the given 'String' as the error +-- message if the parser fails +() :: Symbol s => Parser a s b -> String -> Parser a s b +p msg = p <|> failure msg + +-- |Deterministic choice between two parsers. +-- The appropriate parser is chosen based on the next 'Symbol' +(<|>) :: Symbol s => Parser a s b -> Parser a s b -> Parser a s b +Parser e1 ps1 <|> Parser e2 ps2 + | isJust e1 && isJust e2 = failure "Ambiguous parser for empty word" + | not (Set.null common) = failure $ "Ambiguous parser for " ++ show common + | otherwise = Parser (e1 `mplus` e2) (Map.union ps1 ps2) + where common = Map.keysSet ps1 `Set.intersection` Map.keysSet ps2 + +-- |Non-deterministic choice between two parsers. +-- +-- The other parsing combinators require that the grammar being parsed +-- is LL(1). In some cases it may be difficult or even +-- impossible to transform a grammar into LL(1) form. As a remedy, we +-- include a non-deterministic version of the choice combinator in +-- addition to the deterministic combinator adapted from the paper. For +-- every symbol from the intersection of the parser's first sets, the +-- combinator '(<|?>)' applies both parsing functions to the input +-- stream and uses that one which processes the longer prefix of the +-- input stream irrespective of whether it succeeds or fails. If both +-- functions recognize the same prefix, we choose the one that succeeds +-- and report an ambiguous parse error if both succeed. +(<|?>) :: Symbol s => Parser a s b -> Parser a s b -> Parser a s b +Parser e1 ps1 <|?> Parser e2 ps2 + | isJust e1 && isJust e2 = failure "Ambiguous parser for empty word" + | otherwise = Parser (e1 `mplus` e2) (Map.union ps1' ps2) + where + ps1' = Map.fromList [ (s, maybe p (try p) (Map.lookup s ps2)) + | (s, p) <- Map.toList ps1 + ] + try p1 p2 lexer success failp pos s = + closeP1 p2s `thenP` \p2s' -> + closeP1 p2f `thenP` \p2f' -> + parse' p1 (retry p2s') (retry p2f') + where p2s r1 = parse' p2 (select True r1) (select False r1) + p2f r1 = parse' p2 (flip (select False) r1) (select False r1) + parse' p psucc pfail = + p lexer (successK psucc) (failK pfail) pos s + successK k x pos' s' = k (pos', success x pos' s') + failK k pos' msg = k (pos', failp pos' msg) + retry k (pos',p) = closeP0 p `thenP` curry k pos' + select suc (pos1, p1) (pos2, p2) = case pos1 `compare` pos2 of + GT -> p1 + EQ | suc -> failP pos1 $ "Ambiguous parse before " ++ showPosition (span2Pos pos1) + | otherwise -> p1 + LT -> p2 + +seqEE :: ParseFun a s (b -> c) -> ParseFun a s b -> ParseFun a s c +seqEE p1 p2 success failp = p1 (\f -> p2 (success . f) failp) failp + +seqEP :: ParseFun a s (b -> c) -> (Lexer s a -> ParseFun a s b) + -> Lexer s a -> ParseFun a s c +seqEP p1 p2 lexer success failp = p1 (\f -> p2 lexer (success . f) failp) failp + +seqPP :: Symbol s => (Lexer s a -> ParseFun a s (b -> c)) -> Parser a s b + -> Lexer s a -> ParseFun a s c +seqPP p1 p2 lexer success failp = + p1 lexer (\f -> choose p2 lexer (success . f) failp) failp + +-- --------------------------------------------------------------------------- +-- The combinators \verb|<\\>| and \verb|<\>| can be used to restrict +-- the first set of a parser. This is useful for combining two parsers +-- with an overlapping first set with the deterministic combinator <|>. +-- --------------------------------------------------------------------------- + +-- |Restrict the first parser by the first 'Symbol's of the second +(<\>) :: Symbol s => Parser a s b -> Parser a s c -> Parser a s b +p <\> Parser _ ps = p <\\> Map.keys ps + +-- |Restrict a parser by a list of first 'Symbol's +(<\\>) :: Symbol s => Parser a s b -> [s] -> Parser a s b +Parser e ps <\\> xs = Parser e (foldr Map.delete ps xs) + +-- --------------------------------------------------------------------------- +-- Other combinators +-- Note that some of these combinators have not been published in the +-- paper, but were taken from the implementation found on the web. +-- --------------------------------------------------------------------------- + +-- |Replace the result of the parser with the first argument +(<$->) :: Symbol s => a -> Parser b s c -> Parser b s a +f <$-> p = f <$ p + +-- |Apply two parsers in sequence, but return only the result of the first +-- parser +(<*->) :: Symbol s => Parser a s b -> Parser a s c -> Parser a s b +p <*-> q = const <$> p <*> q + +-- |Apply two parsers in sequence, but return only the result of the second +-- parser +(<-*>) :: Symbol s => Parser a s b -> Parser a s c -> Parser a s c +p <-*> q = id <$ p <*> q + +-- |Apply the parsers in sequence and apply the result function of the second +-- parse to the result of the first +(<**>) :: Symbol s => Parser a s b -> Parser a s (b -> c) -> Parser a s c +p <**> q = flip ($) <$> p <*> q + +-- |Same as (<**>), but only applies the function if the second parser +-- succeeded. +() :: Symbol s => Parser a s b -> Parser a s (b -> b) -> Parser a s b +p q = p <**> (q `opt` id) + +-- |Flipped function composition on parsers +(<.>) :: Symbol s => Parser a s (b -> c) -> Parser a s (c -> d) + -> Parser a s (b -> d) +p1 <.> p2 = p1 <**> ((.) <$> p2) + +-- |Try the first parser, but return the second argument if it didn't succeed +opt :: Symbol s => Parser a s b -> b -> Parser a s b +p `opt` x = p <|> succeed x + +-- |Choose the first succeeding parser from a non-empty list of parsers +choice :: Symbol s => [Parser a s b] -> Parser a s b +choice = foldr1 (<|>) + +-- |Try to apply a given parser and return a boolean value if the parser +-- succeeded. +flag :: Symbol s => Parser a s b -> Parser a s Bool +flag p = True <$-> p `opt` False + +-- |Try to apply a parser but forget if it succeeded +optional :: Symbol s => Parser a s b -> Parser a s () +optional p = void p `opt` () + +-- |Try to apply a parser and return its result in a 'Maybe' type +option :: Symbol s => Parser a s b -> Parser a s (Maybe b) +option p = Just <$> p `opt` Nothing + +-- |Repeatedly apply a parser for 0 or more occurences +many :: Symbol s => Parser a s b -> Parser a s [b] +many p = many1 p `opt` [] + +-- |Repeatedly apply a parser for 1 or more occurences +many1 :: Symbol s => Parser a s b -> Parser a s [b] +many1 p = (:) <$> p <*> many p + +-- |Parse a list with is separated by a seperator +sepBy :: Symbol s => Parser a s b -> Parser a s c -> Parser a s [b] +p `sepBy` q = p `sepBy1` q `opt` [] + +-- |Parse a non-empty list with is separated by a seperator +sepBy1 :: Symbol s => Parser a s b -> Parser a s c -> Parser a s [b] +p `sepBy1` q = (:) <$> p <*> many (q <-*> p) + +-- |Parse a list with is separated by a seperator +sepBySp :: Symbol s => Parser a s b -> Parser a s c -> Parser a s ([b], [Span]) +p `sepBySp` q = p `sepBy1Sp` q `opt` ([], []) + +sepBy1Sp :: Symbol s => Parser a s b -> Parser a s c -> Parser a s ([b], [Span]) +p `sepBy1Sp` q = comb <$> p <*> many ((,) <$> spanPosition <*-> q <*> p) + where comb x xs = let (ss, ys) = unzip xs + in (x:ys,ss) + +-- |@chainr p op x@ parses zero or more occurrences of @p@, separated by @op@. +-- Returns a value produced by a *right* associative application of all +-- functions returned by op. If there are no occurrences of @p@, @x@ is +-- returned. +chainr :: Symbol s + => Parser a s b -> Parser a s (b -> b -> b) -> b -> Parser a s b +chainr p op x = chainr1 p op `opt` x + +-- |Like 'chainr', but parses one or more occurrences of p. +chainr1 :: Symbol s => Parser a s b -> Parser a s (b -> b -> b) -> Parser a s b +chainr1 p op = r where r = p <**> (flip <$> op <*> r `opt` id) + +-- |@chainr p op x@ parses zero or more occurrences of @p@, separated by @op@. +-- Returns a value produced by a *left* associative application of all +-- functions returned by op. If there are no occurrences of @p@, @x@ is +-- returned. +chainl :: Symbol s + => Parser a s b -> Parser a s (b -> b -> b) -> b -> Parser a s b +chainl p op x = chainl1 p op `opt` x + +-- |Like 'chainl', but parses one or more occurrences of p. +chainl1 :: Symbol s => Parser a s b -> Parser a s (b -> b -> b) -> Parser a s b +chainl1 p op = foldF <$> p <*> many (flip <$> op <*> p) + where foldF x [] = x + foldF x (f:fs) = foldF (f x) fs + +-- |Parse an expression between an opening and a closing part. +between :: Symbol s => Parser a s b -> Parser a s c -> Parser a s b + -> Parser a s c +between open p close = open <-*> p <*-> close + +-- |Parse one of the given operators +ops :: Symbol s => [(s, b)] -> Parser a s b +ops [] = failure "Curry.Base.LLParseComb.ops: empty list" +ops [(s, x)] = x <$-> symbol s +ops ((s, x) : rest) = x <$-> symbol s <|> ops rest + +-- --------------------------------------------------------------------------- +-- Layout combinators +-- Note that the layout functions grab the next token (and its position). +-- After modifying the layout context, the continuation is called with +-- the same token and an undefined result. +-- --------------------------------------------------------------------------- + +-- |Disable layout-awareness for the following +layoutOff :: Symbol s => Parser a s b +layoutOff = Parser (Just off) Map.empty + where off success _ pos = pushContext (-1) . success undefined pos + +-- |Add a new scope for layout +layoutOn :: Symbol s => Parser a s b +layoutOn = Parser (Just on) Map.empty + where on success _ pos = pushContext (column (span2Pos pos)) . success undefined pos + +-- |End the current layout scope (or re-enable layout-awareness if it is +-- currently disabled +layoutEnd :: Symbol s => Parser a s b +layoutEnd = Parser (Just end) Map.empty + where end success _ pos = popContext . success undefined pos diff --git a/src/Curry/Base/LexComb.hs b/src/Curry/Base/LexComb.hs new file mode 100644 index 0000000000000000000000000000000000000000..63052e0699a4c5a0cbb6e8c7dc28310b413e2212 --- /dev/null +++ b/src/Curry/Base/LexComb.hs @@ -0,0 +1,179 @@ +{- | + Module : $Header$ + Description : Lexer combinators + Copyright : (c) 1999 - 2004, Wolfgang Lux + 2012 - 2013, Björn Peemöller + 2016 , Jan Tikovsky + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This module provides the basic types and combinators to implement the + lexers. The combinators use continuation passing code in a monadic style. + + The first argument of the continuation function is the current span, + and the second is the string to be parsed. The third argument is a flag + which signals the lexer that it is lexing the beginning of a line and + therefore has to check for layout tokens. The fourth argument is a stack + of indentations that is used to handle nested layout groups. +-} +module Curry.Base.LexComb + ( -- * Types + Symbol (..), Indent, Context, P, CYM, SuccessP, FailP, Lexer + + -- * Monadic functions + , parse, applyLexer, returnP, thenP, thenP_, failP, warnP + , liftP, closeP0, closeP1 + + -- * Combinators for layout handling + , pushContext, popContext + + -- * Conversion of numbers + , convertSignedIntegral, convertSignedFloating + , convertIntegral, convertFloating + ) where + +import Data.Char (digitToInt) + +import Curry.Base.Monad (CYM, failMessageAt, warnMessageAt) +import Curry.Base.Span ( Distance, Span (..), startCol, fstSpan + , setDistance) + + +infixl 1 `thenP`, `thenP_` + +-- |Type class for symbols +class (Ord s, Show s) => Symbol s where + -- |Does the 'Symbol' represent the end of the input? + isEOF :: s -> Bool + -- |Compute the distance of a 'Symbol' + dist :: Int -> s -> Distance + +-- |Type for indentations, necessary for the layout rule +type Indent = Int + +-- |Type of context for representing layout grouping +type Context = [Indent] + +-- |Basic lexer function +type P a = Span -- ^ Current source code span + -> String -- ^ 'String' to be parsed + -> Bool -- ^ Flag whether the beginning of a line should be + -- parsed, which requires layout checking + -> Context -- ^ context as a stack of 'Indent's + -> CYM a + +-- |Apply a lexer on a 'String' to lex the content. The second parameter +-- requires a 'FilePath' to use in the 'Span' +parse :: P a -> FilePath -> String -> CYM a +parse p fn s = p (fstSpan fn) s True [] + +-- --------------------------------------------------------------------------- +-- CPS lexer +-- --------------------------------------------------------------------------- + +-- |success continuation +type SuccessP s a = Span -> s -> P a + +-- |failure continuation +type FailP a = Span -> String -> P a + +-- |A CPS lexer +type Lexer s a = SuccessP s a -> FailP a -> P a + +-- |Apply a lexer +applyLexer :: Symbol s => Lexer s [(Span, s)] -> P [(Span, s)] +applyLexer lexer = lexer successP failP + where successP sp t | isEOF t = returnP [(sp', t)] + | otherwise = ((sp', t) :) `liftP` lexer successP failP + where sp' = setDistance sp (dist (startCol sp) t) + +-- --------------------------------------------------------------------------- +-- Monadic functions for the lexer. +-- --------------------------------------------------------------------------- + +-- |Lift a value into the lexer type +returnP :: a -> P a +returnP x _ _ _ _ = return x + +-- |Apply the first lexer and then apply the second one, based on the result +-- of the first lexer. +thenP :: P a -> (a -> P b) -> P b +thenP lexer k sp s bol ctxt + = lexer sp s bol ctxt >>= \x -> k x sp s bol ctxt + +-- |Apply the first lexer and then apply the second one, ignoring the first +-- result. +thenP_ :: P a -> P b -> P b +p1 `thenP_` p2 = p1 `thenP` const p2 + +-- |Fail to lex on a 'Span', given an error message +failP :: Span -> String -> P a +failP sp msg _ _ _ _ = failMessageAt sp msg + +-- |Warn on a 'Span', given a warning message +warnP :: Span -> String -> P a -> P a +warnP warnSpan msg lexer sp s bol ctxt + = warnMessageAt warnSpan msg >> lexer sp s bol ctxt + +-- |Apply a pure function to the lexers result +liftP :: (a -> b) -> P a -> P b +liftP f p = p `thenP` returnP . f + +-- |Lift a lexer into the 'P' monad, returning the lexer when evaluated. +closeP0 :: P a -> P (P a) +closeP0 lexer sp s bol ctxt = return (\_ _ _ _ -> lexer sp s bol ctxt) + +-- |Lift a lexer-generating function into the 'P' monad, returning the +-- function when evaluated. +closeP1 :: (a -> P b) -> P (a -> P b) +closeP1 f sp s bol ctxt = return (\x _ _ _ _ -> f x sp s bol ctxt) + +-- --------------------------------------------------------------------------- +-- Combinators for handling layout. +-- --------------------------------------------------------------------------- + +-- |Push an 'Indent' to the context, increasing the levels of indentation +pushContext :: Indent -> P a -> P a +pushContext col cont sp s bol ctxt = cont sp s bol (col : ctxt) + +-- |Pop an 'Indent' from the context, decreasing the levels of indentation +popContext :: P a -> P a +popContext cont sp s bol (_ : ctxt) = cont sp s bol ctxt +popContext _ sp _ _ [] = failMessageAt sp $ + "Parse error: popping layout from empty context stack. " ++ + "Perhaps you have inserted too many '}'?" + +-- --------------------------------------------------------------------------- +-- Conversions from 'String's into numbers. +-- --------------------------------------------------------------------------- + +-- |Convert a String into a signed intergral using a given base +convertSignedIntegral :: Num a => a -> String -> a +convertSignedIntegral b ('+':s) = convertIntegral b s +convertSignedIntegral b ('-':s) = - convertIntegral b s +convertSignedIntegral b s = convertIntegral b s + +-- |Convert a String into an unsigned intergral using a given base +convertIntegral :: Num a => a -> String -> a +convertIntegral b = foldl op 0 + where m `op` n = b * m + fromIntegral (digitToInt n) + +-- |Convert a mantissa, a fraction part and an exponent into a signed +-- floating value +convertSignedFloating :: Fractional a => String -> String -> Int -> a +convertSignedFloating ('+':m) f e = convertFloating m f e +convertSignedFloating ('-':m) f e = - convertFloating m f e +convertSignedFloating m f e = convertFloating m f e + +-- |Convert a mantissa, a fraction part and an exponent into an unsigned +-- floating value +convertFloating :: Fractional a => String -> String -> Int -> a +convertFloating m f e + | e' == 0 = m' + | e' > 0 = m' * 10 ^ e' + | otherwise = m' / 10 ^ (- e') + where m' = convertIntegral 10 (m ++ f) + e' = e - length f diff --git a/src/Curry/Base/Message.hs b/src/Curry/Base/Message.hs new file mode 100644 index 0000000000000000000000000000000000000000..6dac26ecf3994c65cb1fdc09df5de28fbe884cc7 --- /dev/null +++ b/src/Curry/Base/Message.hs @@ -0,0 +1,114 @@ +{- | + Module : $Header$ + Description : Monads for message handling + Copyright : 2009 Holger Siegel + 2012 - 2015 Björn Peemöller + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + The type message represents a compiler message with an optional source + code position. +-} +{-# LANGUAGE CPP #-} +module Curry.Base.Message + ( Message (..), message, posMessage, spanMessage, spanInfoMessage + , showWarning, showError + , ppMessage, ppWarning, ppError, ppMessages, ppMessagesWithPreviews + ) where + +#if __GLASGOW_HASKELL__ >= 804 +import Prelude hiding ((<>)) +#endif + +import Curry.Base.Position +import Curry.Base.Pretty +import Curry.Base.Span +import Curry.Base.SpanInfo + +-- --------------------------------------------------------------------------- +-- Message +-- --------------------------------------------------------------------------- + +-- |Compiler message +data Message = Message + { msgSpanInfo :: SpanInfo -- ^ span in the source code + , msgTxt :: Doc -- ^ the message itself + } + +instance Eq Message where + Message s1 t1 == Message s2 t2 = (s1, show t1) == (s2, show t2) + +instance Ord Message where + Message s1 t1 `compare` Message s2 t2 = compare (s1, show t1) (s2, show t2) + +instance Show Message where + showsPrec _ = shows . ppMessage + +instance HasPosition Message where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasSpanInfo Message where + getSpanInfo = msgSpanInfo + setSpanInfo spi m = m { msgSpanInfo = spi } + +instance Pretty Message where + pPrint = ppMessage + +-- |Construct a 'Message' without a 'SpanInfo' +message :: Doc -> Message +message = Message NoSpanInfo + +-- |Construct a message from a position. +posMessage :: HasPosition p => p -> Doc -> Message +posMessage p = spanMessage $ pos2Span $ getPosition p + +-- |Construct a message from a span and a text +spanMessage :: Span -> Doc -> Message +spanMessage s = spanInfoMessage $ fromSrcSpan s + +-- |Construct a message from an entity with a 'SpanInfo' and a text +spanInfoMessage :: HasSpanInfo s => s -> Doc -> Message +spanInfoMessage s msg = Message (getSpanInfo s) msg + +-- |Show a 'Message' as a warning +showWarning :: Message -> String +showWarning = show . ppWarning + +-- |Show a 'Message' as an error +showError :: Message -> String +showError = show . ppError + +-- |Pretty print a 'Message' +ppMessage :: Message -> Doc +ppMessage = ppAs "" + +-- |Pretty print a 'Message' as a warning +ppWarning :: Message -> Doc +ppWarning = ppAs "Warning" + +-- |Pretty print a 'Message' as an error +ppError :: Message -> Doc +ppError = ppAs "Error" + +-- |Pretty print a 'Message' with a given key +ppAs :: String -> Message -> Doc +ppAs key (Message mbSpanInfo txt) = (hsep $ filter (not . isEmpty) [spanPP, keyPP]) $$ nest 4 txt + where + spanPP = ppCompactSpan $ getSrcSpan $ mbSpanInfo + keyPP = if null key then empty else text key <> colon + +-- |Pretty print a list of 'Message's by vertical concatenation +ppMessages :: (Message -> Doc) -> [Message] -> Doc +ppMessages ppFun = foldr (\m ms -> text "" $+$ m $+$ ms) empty . map ppFun + +-- |Pretty print a list of 'Message's with previews by vertical concatenation +ppMessagesWithPreviews :: (Message -> Doc) -> [Message] -> IO Doc +ppMessagesWithPreviews ppFun = (fmap $ foldr (\m ms -> text "" $+$ m $+$ ms) empty) . mapM ppFunWithPreview + where ppFunWithPreview m = do preview <- case m of + Message (SpanInfo sp _) _ -> ppSpanPreview sp + _ -> return empty + return $ ppFun m $+$ preview diff --git a/src/Curry/Base/Monad.hs b/src/Curry/Base/Monad.hs new file mode 100644 index 0000000000000000000000000000000000000000..ca316cdeda6929e9780d9cd759cf6a919053ea92 --- /dev/null +++ b/src/Curry/Base/Monad.hs @@ -0,0 +1,95 @@ +{- | + Module : $Header$ + Description : Monads for message handling + Copyright : 2014 - 2016 Björn Peemöller + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + + The monads defined in this module provide a common way to stop execution + when some errors occur. They are used to integrate different compiler passes + smoothly. +-} + +module Curry.Base.Monad + ( CYIO, CYM, CYT, failMessages, failMessageAt, warnMessages, warnMessageAt + , ok, runCYIO, runCYM, runCYIOIgnWarn, runCYMIgnWarn, liftCYM, silent + ) where + +import Control.Monad.Identity +import Control.Monad.Trans.Except (ExceptT, mapExceptT, runExceptT, throwE) +import Control.Monad.Writer + +import Curry.Base.Message (Message, spanMessage) +import Curry.Base.Span (Span) +import Curry.Base.Pretty (text) + +-- |Curry compiler monad transformer +type CYT m a = WriterT [Message] (ExceptT [Message] m) a + +-- |Curry compiler monad based on the `IO` monad +type CYIO a = CYT IO a + +-- |Pure Curry compiler monad +type CYM a = CYT Identity a + +-- |Run an `IO`-based Curry compiler action in the `IO` monad, +-- yielding either a list of errors or a result in case of success +-- consisting of the actual result and a (possibly empty) list of warnings +runCYIO :: CYIO a -> IO (Either [Message] (a, [Message])) +runCYIO = runExceptT . runWriterT + +-- |Run an pure Curry compiler action, +-- yielding either a list of errors or a result in case of success +-- consisting of the actual result and a (possibly empty) list of warnings +runCYM :: CYM a -> Either [Message] (a, [Message]) +runCYM = runIdentity . runExceptT . runWriterT + +-- |Run an `IO`-based Curry compiler action in the `IO` monad, +-- yielding either a list of errors or a result in case of success. +runCYIOIgnWarn :: CYIO a -> IO (Either [Message] a) +runCYIOIgnWarn = runExceptT . (liftM fst) . runWriterT + +-- |Run an pure Curry compiler action, +-- yielding either a list of errors or a result in case of success. +runCYMIgnWarn :: CYM a -> Either [Message] a +runCYMIgnWarn = runIdentity . runExceptT . (liftM fst) . runWriterT + +-- |Failing action with a message describing the cause of failure. +failMessage :: Monad m => Message -> CYT m a +failMessage msg = failMessages [msg] + +-- |Failing action with a list of messages describing the cause(s) of failure. +failMessages :: Monad m => [Message] -> CYT m a +failMessages = lift . throwE + +-- |Failing action with a source code span and a `String` indicating +-- the cause of failure. +failMessageAt :: Monad m => Span -> String -> CYT m a +failMessageAt sp s = failMessage $ spanMessage sp $ text s + +-- |Warning with a message describing the cause of the warning. +warnMessage :: Monad m => Message -> CYT m () +warnMessage msg = warnMessages [msg] + +-- |Warning with a list of messages describing the cause(s) of the warnings. +warnMessages :: Monad m => [Message] -> CYT m () +warnMessages msgs = tell msgs + +-- |Execute a monadic action, but ignore any warnings it issues +silent :: Monad m => CYT m a -> CYT m a +silent act = censor (const []) act + +-- |Warning with a source code position and a `String` indicating +-- the cause of the warning. +warnMessageAt :: Monad m => Span -> String -> CYT m () +warnMessageAt sp s = warnMessage $ spanMessage sp $ text s + +-- |Lift a value into the `CYT m` monad, same as `return`. +ok :: Monad m => a -> CYT m a +ok = return + +-- |Lift a pure action into an action based on another monad. +liftCYM :: Monad m => CYM a -> CYT m a +liftCYM = mapWriterT (mapExceptT (return . runIdentity)) diff --git a/src/Curry/Base/Position.hs b/src/Curry/Base/Position.hs new file mode 100644 index 0000000000000000000000000000000000000000..f54a1f390587699e5ed1e75da124d08f680884e6 --- /dev/null +++ b/src/Curry/Base/Position.hs @@ -0,0 +1,128 @@ +{- | + Module : $Header$ + Description : Positions in a source file + Copyright : (c) Wolfgang Lux + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This module implements a data type for positions in a source file and + respective functions to operate on them. A source file position consists + of a filename, a line number, and a column number. A tab stop is assumed + at every eighth column. +-} +module Curry.Base.Position + ( -- * Source code position + HasPosition (..), Position (..), (@>) + , showPosition, ppPosition, ppCompactLine, ppLine, showLine + , first, next, incr, tab, tabWidth, nl + ) where + +import Prelude hiding ((<>)) +import Data.Binary +import Control.Monad +import System.FilePath + +import Curry.Base.Pretty + +-- |Type class for entities which have a source code 'Position' +class HasPosition a where + -- |Get the 'Position' + getPosition :: a -> Position + getPosition _ = NoPos + + -- |Set the 'Position' + setPosition :: Position -> a -> a + setPosition _ = id + +-- | @x \@> y@ returns @x@ with the position obtained from @y@ +(@>) :: (HasPosition a, HasPosition b) => a -> b -> a +x @> y = setPosition (getPosition y) x + +-- |Source code positions +data Position + -- |Normal source code position + = Position + { file :: FilePath -- ^ 'FilePath' of the source file + , line :: Int -- ^ line number, beginning at 1 + , column :: Int -- ^ column number, beginning at 1 + } + -- |no position + | NoPos + deriving (Eq, Ord, Read, Show) + +instance HasPosition Position where + getPosition = id + setPosition = const + +instance Pretty Position where + pPrint = ppPosition + +instance Binary Position where + put (Position _ l c) = putWord8 0 >> put l >> put c + put NoPos = putWord8 1 + + get = do + x <- getWord8 + case x of + 0 -> liftM2 (Position "") get get + 1 -> return NoPos + _ -> fail "Not a valid encoding for a Position" + +-- |Show a 'Position' as a 'String' +showPosition :: Position -> String +showPosition = show . ppPosition + +-- |Pretty print a 'Position' +ppPosition :: Position -> Doc +ppPosition p@(Position f _ _) + | null f = lineCol + | otherwise = text (normalise f) <> comma <+> lineCol + where lineCol = ppLine p +ppPosition _ = empty + +-- |Pretty print a compact representation of a 'Position''s line/column +ppCompactLine :: Position -> Doc +ppCompactLine (Position _ l c) = text (show l) + <> if c == 0 then empty else (colon <> text (show c)) +ppCompactLine _ = empty + +-- |Pretty print the line and column of a 'Position' +ppLine :: Position -> Doc +ppLine (Position _ l c) = text "line" <+> text (show l) + <> if c == 0 then empty else text ('.' : show c) +ppLine _ = empty + +-- |Show the line and column of a 'Position' +showLine :: Position -> String +showLine = show . ppLine + +-- | Absolute first position of a file +first :: FilePath -> Position +first fn = Position fn 1 1 + +-- |Next position to the right +next :: Position -> Position +next = flip incr 1 + +-- |Increment a position by a number of columns +incr :: Position -> Int -> Position +incr p@Position { column = c } n = p { column = c + n } +incr p _ = p + +-- |Number of spaces for a tabulator +tabWidth :: Int +tabWidth = 8 + +-- |First position after the next tabulator +tab :: Position -> Position +tab p@Position { column = c } + = p { column = c + tabWidth - (c - 1) `mod` tabWidth } +tab p = p + +-- |First position of the next line +nl :: Position -> Position +nl p@Position { line = l } = p { line = l + 1, column = 1 } +nl p = p diff --git a/src/Curry/Base/Pretty.hs b/src/Curry/Base/Pretty.hs new file mode 100644 index 0000000000000000000000000000000000000000..cefb553b82dd8c5a204d476c8e43adf2f932eedb --- /dev/null +++ b/src/Curry/Base/Pretty.hs @@ -0,0 +1,209 @@ +{- | + Module : $Header$ + Description : Pretty printing + Copyright : (c) 2013 - 2014 Björn Peemöller + 2016 Finn Teegen + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : stable + Portability : portable + + This module re-exports the well known pretty printing combinators + from Hughes and Peyton-Jones. In addition, it re-exports the type class + 'Pretty' for pretty printing arbitrary types. +-} +{-# LANGUAGE CPP #-} +module Curry.Base.Pretty + ( module Curry.Base.Pretty + , module Text.PrettyPrint + ) where + +import Prelude hiding ((<>)) + +import Text.PrettyPrint + +-- | Pretty printing class. +-- The precedence level is used in a similar way as in the 'Show' class. +-- Minimal complete definition is either 'pPrintPrec' or 'pPrint'. +class Pretty a where + -- | Pretty-print something in isolation. + pPrint :: a -> Doc + pPrint = pPrintPrec 0 + + -- | Pretty-print something in a precedence context. + pPrintPrec :: Int -> a -> Doc + pPrintPrec _ = pPrint + + -- |Pretty-print a list. + pPrintList :: [a] -> Doc + pPrintList = brackets . fsep . punctuate comma . map (pPrintPrec 0) + +#if __GLASGOW_HASKELL__ >= 707 + {-# MINIMAL pPrintPrec | pPrint #-} +#endif + +-- | Pretty print a value to a 'String'. +prettyShow :: Pretty a => a -> String +prettyShow = render . pPrint + +-- | Parenthesize an value if the boolean is true. +parenIf :: Bool -> Doc -> Doc +parenIf False = id +parenIf True = parens + +-- | Pretty print a value if the boolean is true +ppIf :: Bool -> Doc -> Doc +ppIf True = id +ppIf False = const empty + +-- | Pretty print a 'Maybe' value for the 'Just' constructor only +maybePP :: (a -> Doc) -> Maybe a -> Doc +maybePP = maybe empty + +-- | A blank line. +blankLine :: Doc +blankLine = text "" + +-- |Above with a blank line in between. If one of the documents is empty, +-- then the other document is returned. +($++$) :: Doc -> Doc -> Doc +d1 $++$ d2 | isEmpty d1 = d2 + | isEmpty d2 = d1 + | otherwise = d1 $+$ blankLine $+$ d2 + +-- |Above with overlapping, but with a space in between. If one of the +-- documents is empty, then the other document is returned. +($-$) :: Doc -> Doc -> Doc +d1 $-$ d2 | isEmpty d1 = d2 + | isEmpty d2 = d1 + | otherwise = d1 $$ space $$ d2 + +-- | Seperate a list of 'Doc's by a 'blankLine'. +sepByBlankLine :: [Doc] -> Doc +sepByBlankLine = foldr ($++$) empty + +-- |A '.' character. +dot :: Doc +dot = char '.' + +-- |Precedence of function application +appPrec :: Int +appPrec = 10 + +-- |A left arrow @<-@. +larrow :: Doc +larrow = text "<-" + +-- |A right arrow @->@. +rarrow :: Doc +rarrow = text "->" + +-- |A double arrow @=>@. +darrow :: Doc +darrow = text "=>" + +-- |A back quote @`@. +backQuote :: Doc +backQuote = char '`' + +-- |A backslash @\@. +backsl :: Doc +backsl = char '\\' + +-- |A vertical bar @|@. +vbar :: Doc +vbar = char '|' + +-- |Set a document in backquotes. +bquotes :: Doc -> Doc +bquotes doc = backQuote <> doc <> backQuote + +-- |Set a document in backquotes if the condition is @True@. +bquotesIf :: Bool -> Doc -> Doc +bquotesIf b doc = if b then bquotes doc else doc + +-- |Seperate a list of documents by commas +list :: [Doc] -> Doc +list = fsep . punctuate comma . filter (not . isEmpty) + +-- | Instance for 'Int' +instance Pretty Int where pPrint = int + +-- | Instance for 'Integer' +instance Pretty Integer where pPrint = integer + +-- | Instance for 'Float' +instance Pretty Float where pPrint = float + +-- | Instance for 'Double' +instance Pretty Double where pPrint = double + +-- | Instance for '()' +instance Pretty () where pPrint _ = text "()" + +-- | Instance for 'Bool' +instance Pretty Bool where pPrint = text . show + +-- | Instance for 'Ordering' +instance Pretty Ordering where pPrint = text . show + +-- | Instance for 'Char' +instance Pretty Char where + pPrint = char + pPrintList = text . show + +-- | Instance for 'Maybe' +instance (Pretty a) => Pretty (Maybe a) where + pPrintPrec _ Nothing = text "Nothing" + pPrintPrec p (Just x) = parenIf (p > appPrec) + $ text "Just" <+> pPrintPrec (appPrec + 1) x + +-- | Instance for 'Either' +instance (Pretty a, Pretty b) => Pretty (Either a b) where + pPrintPrec p (Left x) = parenIf (p > appPrec) + $ text "Left" <+> pPrintPrec (appPrec + 1) x + pPrintPrec p (Right x) = parenIf (p > appPrec) + $ text "Right" <+> pPrintPrec (appPrec + 1) x + +-- | Instance for '[]' +instance (Pretty a) => Pretty [a] where + pPrintPrec _ = pPrintList + +-- | Instance for '(,)' +instance (Pretty a, Pretty b) => Pretty (a, b) where + pPrintPrec _ (a, b) = parens $ fsep $ punctuate comma [pPrint a, pPrint b] + +-- | Instance for '(,,)' +instance (Pretty a, Pretty b, Pretty c) => Pretty (a, b, c) where + pPrintPrec _ (a, b, c) = parens $ fsep $ punctuate comma + [pPrint a, pPrint b, pPrint c] + +-- | Instance for '(,,,)' +instance (Pretty a, Pretty b, Pretty c, Pretty d) => Pretty (a, b, c, d) where + pPrintPrec _ (a, b, c, d) = parens $ fsep $ punctuate comma + [pPrint a, pPrint b, pPrint c, pPrint d] + +-- | Instance for '(,,,,)' +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e) + => Pretty (a, b, c, d, e) where + pPrintPrec _ (a, b, c, d, e) = parens $ fsep $ punctuate comma + [pPrint a, pPrint b, pPrint c, pPrint d, pPrint e] + +-- | Instance for '(,,,,,)' +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f) + => Pretty (a, b, c, d, e, f) where + pPrintPrec _ (a, b, c, d, e, f) = parens $ fsep $ punctuate comma + [pPrint a, pPrint b, pPrint c, pPrint d, pPrint e, pPrint f] + +-- | Instance for '(,,,,,,)' +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g) + => Pretty (a, b, c, d, e, f, g) where + pPrintPrec _ (a, b, c, d, e, f, g) = parens $ fsep $ punctuate comma + [pPrint a, pPrint b, pPrint c, pPrint d, pPrint e, pPrint f, pPrint g] + +-- | Instance for '(,,,,,,,)' +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h) + => Pretty (a, b, c, d, e, f, g, h) where + pPrintPrec _ (a, b, c, d, e, f, g, h) = parens $ fsep $ punctuate comma + [pPrint a, pPrint b, pPrint c, pPrint d, pPrint e, pPrint f, pPrint g, pPrint h] diff --git a/src/Curry/Base/Span.hs b/src/Curry/Base/Span.hs new file mode 100644 index 0000000000000000000000000000000000000000..96acf5c720046f67eb97c6d7f5866aed83cd605c --- /dev/null +++ b/src/Curry/Base/Span.hs @@ -0,0 +1,181 @@ +{- | + Module : $Header$ + Description : Spans in a source file + Copyright : (c) 2016 Jan Tikovsky + 2016 Finn Teegen + License : BSD-3-clause + + Maintainer : jrt@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This module implements a data type for span information in a source file and + respective functions to operate on them. A source file span consists + of a filename, a start position and an end position. + + In addition, the type 'SrcRef' identifies the path to an expression in + the abstract syntax tree by argument positions, which is used for + debugging purposes. +-} +module Curry.Base.Span where + +import Prelude hiding ((<>)) + +import Data.Binary +import Data.List (transpose) +import Control.Monad +import System.FilePath + +import Curry.Base.Position hiding (file) +import Curry.Base.Pretty + +data Span + -- |Normal source code span + = Span + { file :: FilePath -- ^ 'FilePath' of the source file + , start :: Position -- ^ start position + , end :: Position -- ^ end position + } + -- |no span + | NoSpan + deriving (Eq, Ord, Read, Show) + +instance Pretty Span where + pPrint = ppSpan + +instance HasPosition Span where + setPosition p NoSpan = Span "" p NoPos + setPosition p (Span f _ e) = Span f p e + + getPosition NoSpan = NoPos + getPosition (Span _ p _) = p + +instance Binary Span where + put (Span _ s e) = putWord8 0 >> put s >> put e + put NoSpan = putWord8 1 + + get = do + x <- getWord8 + case x of + 0 -> liftM2 (Span "") get get + 1 -> return NoSpan + _ -> fail "Not a valid encoding for a Span" + +-- |Show a 'Span' as a 'String' +showSpan :: Span -> String +showSpan = show . ppSpan + +-- |Pretty print a 'Span' +ppSpan :: Span -> Doc +ppSpan s@(Span f _ _) + | null f = startEnd + | otherwise = text (normalise f) <> comma <+> startEnd + where startEnd = ppPositions s +ppSpan _ = empty + +-- |Pretty print a span with it's file path and position compactly. +ppCompactSpan :: Span -> Doc +ppCompactSpan s@(Span f _ _) + | null f = ppCompactPositions s + | otherwise = text (normalise f) <> colon <> ppCompactPositions s +ppCompactSpan _ = empty + +-- |Pretty print a source preview of a span +ppSpanPreview :: Span -> IO Doc +ppSpanPreview (Span f (Position _ sl sc) (Position _ el ec)) + | null f = return empty + | otherwise = do + fileContents <- readFile f + + let lnContents = take lnCount $ drop (sl - 1) $ lines fileContents + lnNumsRaw = (\i -> if (i - sl) `mod` lnInterval == 0 then show i else "") <$> [sl..el] + lnNums = text <$> lPadStr lnNumWidth <$> (vPad ++ lnNumsRaw ++ vPad) + gutter = text <$> replicate (lnCount + 2 * vPadCount) "|" + highlight = replicate (minC - 1) ' ' ++ replicate (1 + maxC - minC) '^' + previews = text <$> (vPad ++ lnContents ++ [highlight] ++ replicate (vPadCount - 1) "") + + return $ vcat $ map hsep $ transpose [lnNums, gutter, previews] + where vPadCount = 1 -- Number of padding lines at the top and bottom + lnInterval = 1 -- Number of lines between displayed line numbers + lnCount = 1 + el - sl + minC = min sc ec + maxC = max sc ec + numWidth n = 1 + floor (logBase 10 $ (fromIntegral n) :: Double) + lnNumWidth = 1 + numWidth el + vPad = replicate vPadCount "" + lPadStr n s = replicate (n - length s) ' ' ++ s +ppSpanPreview _ = return empty + +-- |Pretty print the positions compactly. +ppCompactPositions :: Span -> Doc +ppCompactPositions (Span _ s e) | s == e = ppCompactLine s + | otherwise = ppCompactLine s <> text "-" <> ppCompactLine e +ppCompactPositions _ = empty + +-- |Pretty print the start and end position of a 'Span' +ppPositions :: Span -> Doc +ppPositions (Span _ s e) = text "startPos:" <+> ppLine s <> comma + <+> text "endPos:" <+> ppLine e +ppPositions _ = empty + +fstSpan :: FilePath -> Span +fstSpan fn = Span fn (first fn) (first fn) + +-- |Compute the column of the start position of a 'Span' +startCol :: Span -> Int +startCol (Span _ p _) = column p +startCol _ = 0 + +nextSpan :: Span -> Span +nextSpan sp = incrSpan sp 1 + +incrSpan :: Span -> Int -> Span +incrSpan (Span fn s e) n = Span fn (incr s n) (incr e n) +incrSpan sp _ = sp + +-- TODO: Rename to tab and nl as soon as positions are completely replaced by spans + +-- |Convert a position to a single character span. +pos2Span :: Position -> Span +pos2Span p@(Position f _ _) = Span f p p +pos2Span _ = NoSpan + +-- |Convert a span to a (start) position +-- TODO: This function should be removed as soon as positions are completely replaced by spans +-- in the frontend +span2Pos :: Span -> Position +span2Pos (Span _ p _) = p +span2Pos NoSpan = NoPos + +combineSpans :: Span -> Span -> Span +combineSpans sp1 sp2 = Span f s e + where s = start sp1 + e = end sp2 + f = file sp1 + +-- |First position after the next tabulator +tabSpan :: Span -> Span +tabSpan (Span fn s e) = Span fn (tab s) (tab e) +tabSpan sp = sp + +-- |First position of the next line +nlSpan :: Span -> Span +nlSpan (Span fn s e) = Span fn (nl s) (nl e) +nlSpan sp = sp + +addSpan :: Span -> (a, [Span]) -> (a, [Span]) +addSpan sp (a, ss) = (a, sp:ss) + +-- |Distance of a span, i.e. the line and column distance between start +-- and end position +type Distance = (Int, Int) + +-- |Set the distance of a span, i.e. update its end position +setDistance :: Span -> Distance -> Span +setDistance (Span fn p _) d = Span fn p (p `moveBy` d) +setDistance s _ = s + +-- |Move position by given distance +moveBy :: Position -> Distance -> Position +moveBy (Position fn l c) (ld, cd) = Position fn (l + ld) (c + cd) +moveBy p _ = p diff --git a/src/Curry/Base/SpanInfo.hs b/src/Curry/Base/SpanInfo.hs new file mode 100644 index 0000000000000000000000000000000000000000..704b4c42ff9ac68b27e77af15b48d5ae33774538 --- /dev/null +++ b/src/Curry/Base/SpanInfo.hs @@ -0,0 +1,139 @@ +{- | + Module : $Header$ + Description : SpansInfo for entities + Copyright : (c) 2017 Kai-Oliver Prott + License : BSD-3-clause + + Maintainer : fte@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This module implements a data type for span information for entities from a + source file and function to operate on them. A span info consists of the + span of the entity and a list of sub-spans whith additional information + about location of keywords, e.g. +-} +module Curry.Base.SpanInfo + ( SpanInfo(..), spanInfo, LayoutInfo(..), HasSpanInfo(..) + , fromSrcSpan, fromSrcSpanBoth, getSrcSpan, setSrcSpan, spanInfoLike + , fromSrcInfoPoints, getSrcInfoPoints, setSrcInfoPoints + , getStartPosition, getSrcSpanEnd, setStartPosition, setEndPosition + , spanInfo2Pos + ) where + +import Data.Binary +import Control.Monad + +import Curry.Base.Position +import Curry.Base.Span + +data SpanInfo = SpanInfo + { srcSpan :: Span + , srcInfoPoints :: [Span] + } + | NoSpanInfo + deriving (Eq, Ord, Read, Show) + +spanInfo :: Span -> [Span] -> SpanInfo +spanInfo sp sps = SpanInfo sp sps + +data LayoutInfo = ExplicitLayout [Span] + | WhitespaceLayout + deriving (Eq, Read, Show) + +class HasPosition a => HasSpanInfo a where + + getSpanInfo :: a -> SpanInfo + + setSpanInfo :: SpanInfo -> a -> a + + updateEndPos :: a -> a + updateEndPos = id + + getLayoutInfo :: a -> LayoutInfo + getLayoutInfo = const WhitespaceLayout + +instance HasSpanInfo SpanInfo where + getSpanInfo = id + setSpanInfo = const + +instance HasPosition SpanInfo where + getPosition = getStartPosition + setPosition = setStartPosition + +instance Binary SpanInfo where + put (SpanInfo sp ss) = putWord8 0 >> put sp >> put ss + put NoSpanInfo = putWord8 1 + + get = do + x <- getWord8 + case x of + 0 -> liftM2 SpanInfo get get + 1 -> return NoSpanInfo + _ -> fail "Not a valid encoding for a SpanInfo" + +instance Binary LayoutInfo where + put (ExplicitLayout ss) = putWord8 0 >> put ss + put WhitespaceLayout = putWord8 1 + + get = do + x <- getWord8 + case x of + 0 -> fmap ExplicitLayout get + 1 -> return WhitespaceLayout + _ -> fail "Not a valid encoding for a LayoutInfo" + +fromSrcSpan :: Span -> SpanInfo +fromSrcSpan sp = SpanInfo sp [] + +fromSrcSpanBoth :: Span -> SpanInfo +fromSrcSpanBoth sp = SpanInfo sp [sp] + +getSrcSpan :: HasSpanInfo a => a -> Span +getSrcSpan a = case getSpanInfo a of + NoSpanInfo -> NoSpan + SpanInfo s _ -> s + +setSrcSpan :: HasSpanInfo a => Span -> a -> a +setSrcSpan s a = case getSpanInfo a of + NoSpanInfo -> setSpanInfo (SpanInfo s [] ) a + SpanInfo _ inf -> setSpanInfo (SpanInfo s inf) a + +fromSrcInfoPoints :: [Span] -> SpanInfo +fromSrcInfoPoints = SpanInfo NoSpan + +getSrcInfoPoints :: HasSpanInfo a => a -> [Span] +getSrcInfoPoints a = case getSpanInfo a of + NoSpanInfo -> [] + SpanInfo _ xs -> xs + +setSrcInfoPoints :: HasSpanInfo a => [Span] -> a -> a +setSrcInfoPoints inf a = case getSpanInfo a of + NoSpanInfo -> setSpanInfo (SpanInfo NoSpan inf) a + SpanInfo s _ -> setSpanInfo (SpanInfo s inf) a + +getStartPosition :: HasSpanInfo a => a -> Position +getStartPosition a = case getSrcSpan a of + NoSpan -> NoPos + Span _ s _ -> s + +getSrcSpanEnd :: HasSpanInfo a => a -> Position +getSrcSpanEnd a = case getSpanInfo a of + NoSpanInfo -> NoPos + SpanInfo s _ -> end s + +setStartPosition :: HasSpanInfo a => Position -> a -> a +setStartPosition p a = case getSrcSpan a of + NoSpan -> setSrcSpan (Span "" p NoPos) a + Span f _ e -> setSrcSpan (Span f p e) a + +setEndPosition :: HasSpanInfo a => Position -> a -> a +setEndPosition e a = case getSrcSpan a of + NoSpan -> setSrcSpan (Span "" NoPos e) a + Span f p _ -> setSrcSpan (Span f p e) a + +spanInfo2Pos :: HasSpanInfo a => a -> Position +spanInfo2Pos = getStartPosition + +spanInfoLike :: (HasSpanInfo a, HasSpanInfo b) => a -> b -> a +spanInfoLike a b = setSpanInfo (getSpanInfo b) a diff --git a/src/Curry/CondCompile/Parser.hs b/src/Curry/CondCompile/Parser.hs new file mode 100644 index 0000000000000000000000000000000000000000..7c6aecd7cfc7fc2bb0df4f18ace114e476ecd75b --- /dev/null +++ b/src/Curry/CondCompile/Parser.hs @@ -0,0 +1,90 @@ +{- | + Module : $Header$ + Description : Parser for conditional compiling + Copyright : (c) 2017 Kai-Oliver Prott + 2017 Finn Teegen + License : BSD-3-clause + + Maintainer : fte@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + TODO +-} +{-# LANGUAGE CPP #-} +module Curry.CondCompile.Parser where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>), (<*>), (*>), (<*)) +#endif + +import Text.Parsec + +import Curry.CondCompile.Type + +type Parser a = Parsec String () a + +program :: Parser Program +program = statement `sepBy` eol <* eof + +statement :: Parser Stmt +statement = ifElse "if" condition If + <|> ifElse "ifdef" identifier IfDef + <|> ifElse "ifndef" identifier IfNDef + <|> define + <|> undef + <|> line + +ifElse :: String -> Parser a -> (a -> [Stmt] -> [Elif] -> Else -> Stmt) + -> Parser Stmt +ifElse k p c = c <$> (try (many sp *> keyword k *> many1 sp) *> p <* many sp <* eol) + <*> many (statement <* eol) + <*> many (Elif <$> ((,) <$> (try (many sp *> keyword "elif" *> many1 sp) *> condition <* many sp <* eol) + <*> many (statement <* eol))) + <*> (Else <$> optionMaybe + (try (many sp *> keyword "else" *> many sp) *> eol *> many (statement <* eol))) + <* try (many sp <* keyword "endif" <* many sp) + +define :: Parser Stmt +define = Define <$> (try (many sp *> keyword "define" *> many1 sp) *> identifier <* many1 sp) + <*> value <* many sp + +undef :: Parser Stmt +undef = Undef <$> (try (many sp *> keyword "undef" *> many1 sp) *> identifier <* many sp) + +line :: Parser Stmt +line = do + sps <- many sp + try $ ((char '#' "") *> fail "unknown directive") + <|> ((Line . (sps ++)) <$> manyTill anyChar (try (lookAhead (eol <|> eof)))) + +keyword :: String -> Parser String +keyword = string . ('#' :) + +condition :: Parser Cond +condition = (Defined <$> (try (string "defined(") *> many sp *> identifier <* many sp <* char ')')) + <|> (NDefined <$> (try (string "!defined(") *> many sp *> identifier <* many sp <* char ')')) + <|> (Comp <$> (identifier <* many sp) <*> operator <*> (many sp *> value) "condition") + +identifier :: Parser String +identifier = (:) <$> firstChar <*> many (firstChar <|> digit) "identifier" + where firstChar = letter <|> char '_' + +operator :: Parser Op +operator = choice [ Leq <$ try (string "<=") + , Lt <$ try (string "<") + , Geq <$ try (string ">=") + , Gt <$ try (string ">") + , Neq <$ try (string "!=") + , Eq <$ string "==" + ] "operator" + +value :: Parser Int +value = fmap read (many1 digit) + +eol :: Parser () +eol = endOfLine *> return () + +sp :: Parser Char +sp = try $ lookAhead (eol *> unexpected "end of line" "") + <|> space diff --git a/src/Curry/CondCompile/Transform.hs b/src/Curry/CondCompile/Transform.hs new file mode 100644 index 0000000000000000000000000000000000000000..72cceb5a01b358b713b8996c54348e2b29d9108b --- /dev/null +++ b/src/Curry/CondCompile/Transform.hs @@ -0,0 +1,116 @@ +{- | + Module : $Header$ + Description : Conditional compiling transformation + Copyright : (c) 2017 Kai-Oliver Prott + 2017 Finn Teegen + License : BSD-3-clause + + Maintainer : fte@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + TODO +-} +module Curry.CondCompile.Transform (condTransform) where + +import Control.Monad.State +import Control.Monad.Extra (concatMapM) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Text.Parsec hiding (State) +import Text.Parsec.Error () + +import Curry.Base.Message +import Curry.Base.Position +import Curry.Base.Pretty + +import Curry.CondCompile.Parser +import Curry.CondCompile.Type + +type CCState = Map.Map String Int + +type CCM = State CCState + +condTransform :: CCState -> FilePath -> String -> Either Message String +condTransform s fn p = either (Left . convertError) + (Right . transformWith s) + (parse program fn p) + +transformWith :: CCState -> Program -> String +transformWith s p = show $ pPrint $ evalState (transform p) s + +convertError :: ParseError -> Message +convertError err = posMessage pos $ + foldr ($+$) empty $ map text $ tail $ lines $ show err + where pos = Position (sourceName src) (sourceLine src) (sourceColumn src) + src = errorPos err + +class CCTransform a where + transform :: a -> CCM [Stmt] + +instance CCTransform Stmt where + transform (Line s) = return [Line s] + transform (If c stmts is e) = do + s <- get + if checkCond c s + then do stmts' <- transform stmts + return (blank : stmts' ++ fill is ++ fill e ++ [blank]) + else case is of + [] -> do + stmts' <- transform e + return (blank : fill stmts ++ stmts' ++ [blank]) + (Elif (c', stmts') : is') -> do + stmts'' <- transform (If c' stmts' is' e) + return (blank : fill stmts ++ stmts'') + transform (IfDef v stmts is e) = transform (If (Defined v) stmts is e) + transform (IfNDef v stmts is e) = transform (If (NDefined v) stmts is e) + transform (Define v i) = modify (Map.insert v i) >> return [blank] + transform (Undef v ) = modify (Map.delete v) >> return [blank] + +instance CCTransform a => CCTransform [a] where + transform = concatMapM transform + +instance CCTransform Else where + transform (Else (Just p)) = (blank :) <$> transform p + transform (Else Nothing ) = return [] + +checkCond :: Cond -> CCState -> Bool +checkCond (Comp v op i) = flip (compareOp op) i . fromMaybe 0 . Map.lookup v +checkCond (Defined v) = Map.member v +checkCond (NDefined v) = Map.notMember v + +compareOp :: Ord a => Op -> a -> a -> Bool +compareOp Eq = (==) +compareOp Neq = (/=) +compareOp Lt = (<) +compareOp Leq = (<=) +compareOp Gt = (>) +compareOp Geq = (>=) + +class FillLength a where + fillLength :: a -> Int + +instance FillLength Stmt where + fillLength (Line _ ) = 1 + fillLength (Define _ _ ) = 1 + fillLength (Undef _ ) = 1 + fillLength (If _ stmts is e) = + 3 + fillLength stmts + fillLength e + fillLength is + fillLength (IfDef v stmts is e) = fillLength (If (Defined v) stmts is e) + fillLength (IfNDef v stmts is e) = fillLength (If (NDefined v) stmts is e) + +instance FillLength a => FillLength [a] where + fillLength = foldr ((+) . fillLength) 0 + +instance FillLength Else where + fillLength (Else (Just stmts)) = 1 + fillLength stmts + fillLength (Else Nothing ) = 0 + +instance FillLength Elif where + fillLength (Elif (_, stmts)) = 1 + fillLength stmts + +fill :: FillLength a => a -> [Stmt] +fill p = replicate (fillLength p) blank + +blank :: Stmt +blank = Line "" diff --git a/src/Curry/CondCompile/Type.hs b/src/Curry/CondCompile/Type.hs new file mode 100644 index 0000000000000000000000000000000000000000..0a72b0fbb00a2a86cadef60d18b644d4a3f089d7 --- /dev/null +++ b/src/Curry/CondCompile/Type.hs @@ -0,0 +1,88 @@ +{- | + Module : $Header$ + Description : Abstract syntax for conditional compiling + Copyright : (c) 2017 Kai-Oliver Prott + 2017 Finn Teegen + License : BSD-3-clause + + Maintainer : fte@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + TODO +-} +{-# LANGUAGE CPP #-} +module Curry.CondCompile.Type + ( Program, Stmt (..), Else (..), Elif (..), Cond (..), Op (..) + ) where + +#if __GLASGOW_HASKELL__ >= 804 +import Prelude hiding ((<>)) +#endif + +import Curry.Base.Pretty + +type Program = [Stmt] + +data Stmt = If Cond [Stmt] [Elif] Else + | IfDef String [Stmt] [Elif] Else + | IfNDef String [Stmt] [Elif] Else + | Define String Int + | Undef String + | Line String + deriving Show + +newtype Else = Else (Maybe [Stmt]) + deriving Show + +newtype Elif = Elif (Cond, [Stmt]) + deriving Show + +data Cond = Comp String Op Int + | Defined String + | NDefined String + deriving Show + +data Op = Eq + | Neq + | Lt + | Leq + | Gt + | Geq + deriving Show + +instance Pretty Stmt where + pPrint (If c stmts is e) = prettyIf "#if" (pPrint c) stmts is e + pPrint (IfDef v stmts is e) = prettyIf "#ifdef" (text v) stmts is e + pPrint (IfNDef v stmts is e) = prettyIf "#ifndef" (text v) stmts is e + pPrint (Define v i ) = text "#define" <+> text v <+> int i + pPrint (Undef v ) = text "#undef" <+> text v + pPrint (Line s ) = text s + + pPrintList = foldr (($+$) . pPrint) empty + +instance Pretty Elif where + pPrint (Elif (c, stmts)) = text "#elif" <+> pPrint c $+$ pPrint stmts + + pPrintList = foldr (($+$) . pPrint) empty + +instance Pretty Else where + pPrint (Else (Just stmts)) = text "#else" $+$ pPrint stmts + pPrint (Else Nothing) = empty + +prettyIf :: String -> Doc -> [Stmt] -> [Elif] -> Else -> Doc +prettyIf k doc stmts is e = foldr ($+$) empty + [text k <+> doc, pPrint stmts, pPrint is, pPrint e, text "#endif"] + +instance Pretty Cond where + pPrint (Comp v op i) = text v <+> pPrint op <+> int i + pPrint (Defined v ) = text "defined(" <> text v <> char ')' + pPrint (NDefined v ) = text "!defined(" <> text v <> char ')' + +instance Pretty Op where + pPrint Eq = text "==" + pPrint Neq = text "/=" + pPrint Lt = text "<" + pPrint Leq = text "<=" + pPrint Gt = text ">" + pPrint Geq = text ">=" diff --git a/src/Curry/Files/Filenames.hs b/src/Curry/Files/Filenames.hs new file mode 100644 index 0000000000000000000000000000000000000000..d801d6f3ef65748b18a49b84869ea87c018fbe7c --- /dev/null +++ b/src/Curry/Files/Filenames.hs @@ -0,0 +1,255 @@ +{- | + 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 diff --git a/src/Curry/Files/PathUtils.hs b/src/Curry/Files/PathUtils.hs new file mode 100644 index 0000000000000000000000000000000000000000..162039a96e262938c87eb819c59b7674e3af62c5 --- /dev/null +++ b/src/Curry/Files/PathUtils.hs @@ -0,0 +1,206 @@ +{- | + Module : $Header$ + Description : Utility functions for reading and writing files + Copyright : (c) 1999 - 2003, Wolfgang Lux + 2011 - 2014, Björn Peemöller (bjp@informatik.uni-kiel.de) + 2017 , Finn Teegen (fte@informatik.uni-kiel.de) + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable +-} + +{-# LANGUAGE CPP #-} + +module Curry.Files.PathUtils + ( -- * Retrieving curry files + lookupCurryFile + , lookupCurryModule + , lookupCurryInterface + , lookupFile + + -- * Reading and writing modules from files + , getModuleModTime + , writeModule + , readModule + , writeBinaryModule + , addVersion + , checkVersion + ) where + +import qualified Control.Exception as C (IOException, handle) +import Control.Monad (liftM) +import Data.List (isPrefixOf, isSuffixOf) +import qualified Data.ByteString.Lazy as B (ByteString, writeFile) +import System.FilePath +import System.Directory +import System.IO + +#if MIN_VERSION_directory(1,2,0) +import Data.Time (UTCTime) +#else +import System.Time (ClockTime) +#endif + +import Curry.Base.Ident +import Curry.Files.Filenames + +-- --------------------------------------------------------------------------- +-- Searching for files +-- --------------------------------------------------------------------------- + +-- |Search in the given list of paths for the given 'FilePath' and eventually +-- return the file name of the found file. +-- +-- - If the file name already contains a directory, then the paths to search +-- in are ignored. +-- - If the file name has no extension, then a source file extension is +-- assumed. +lookupCurryFile :: [FilePath] -> FilePath -> IO (Maybe FilePath) +lookupCurryFile paths fn = lookupFile paths exts fn + where + exts | null fnExt = sourceExts + | otherwise = [fnExt] + fnExt = takeExtension fn + +-- |Search for a given curry module in the given source file and +-- library paths. Note that the current directory is always searched first. +-- Returns the path of the found file. +lookupCurryModule :: [FilePath] -- ^ list of paths to source files + -> [FilePath] -- ^ list of paths to library files + -> ModuleIdent -- ^ module identifier + -> IO (Maybe FilePath) +lookupCurryModule paths libPaths m = + lookupFile (paths ++ libPaths) moduleExts (moduleNameToFile m) + +-- |Search for an interface file in the import search path using the +-- interface extension 'icurryExt'. Note that the current directory is +-- always searched first. +lookupCurryInterface :: [FilePath] -- ^ list of paths to search in + -> ModuleIdent -- ^ module identifier + -> IO (Maybe FilePath) -- ^ the file path if found +lookupCurryInterface paths m = lookupFile paths [icurryExt] (moduleNameToFile m) + +-- |Search in the given directories for the file with the specified file +-- extensions and eventually return the 'FilePath' of the file. +lookupFile :: [FilePath] -- ^ Directories to search in + -> [String] -- ^ Accepted file extensions + -> FilePath -- ^ Initial file name + -> IO (Maybe FilePath) -- ^ 'FilePath' of the file if found +lookupFile paths exts file = lookup' files + where + files = [ normalise (p f) | p <- paths, f <- baseNames ] + baseNames = map (replaceExtension file) exts + + lookup' [] = return Nothing + lookup' (f : fs) = do + exists <- doesFileExist f + if exists then return (Just f) else lookup' fs + +-- --------------------------------------------------------------------------- +-- Reading and writing files +-- --------------------------------------------------------------------------- + +-- | Write the content to a file in the given directory. +writeModule :: FilePath -- ^ original path + -> String -- ^ file content + -> IO () +writeModule fn contents = do + createDirectoryIfMissing True $ takeDirectory fn + tryWriteFile fn contents + +-- | Write the content in binary to a file in the given directory. +writeBinaryModule :: FilePath -- ^ original path + -> B.ByteString -- ^ file content + -> IO () +writeBinaryModule fn contents = do + createDirectoryIfMissing True $ takeDirectory fn + tryWriteBinaryFile (fn ++ "-bin") contents + +-- | Read the specified module and returns either 'Just String' if +-- reading was successful or 'Nothing' otherwise. +readModule :: FilePath -> IO (Maybe String) +readModule = tryOnExistingFile readFileUTF8 + where + readFileUTF8 :: FilePath -> IO String + readFileUTF8 fn = do + hdl <- openFile fn ReadMode + hSetEncoding hdl utf8 + hGetContents hdl + +-- | Get the modification time of a file, if existent +#if MIN_VERSION_directory(1,2,0) +getModuleModTime :: FilePath -> IO (Maybe UTCTime) +#else +getModuleModTime :: FilePath -> IO (Maybe ClockTime) +#endif +getModuleModTime = tryOnExistingFile getModificationTime + +-- |Add the given version string to the file content +addVersion :: String -> String -> String +addVersion v content = "{- " ++ v ++ " -}\n" ++ content + +-- |Check a source file for the given version string +checkVersion :: String -> String -> Either String String +checkVersion expected src = case lines src of + [] -> Left "empty file" + (l:ls) -> case getVersion l of + Just v | v == expected -> Right (unlines ls) + | otherwise -> Left $ "Expected version `" ++ expected + ++ "', but found version `" ++ v ++ "'" + _ -> Left $ "No version found" + + where + getVersion s | "{- " `isPrefixOf` s && " -}" `isSuffixOf` s + = Just (reverse $ drop 3 $ reverse $ drop 3 s) + | otherwise + = Nothing + +-- --------------------------------------------------------------------------- +-- Helper functions +-- --------------------------------------------------------------------------- + +tryOnExistingFile :: (FilePath -> IO a) -> FilePath -> IO (Maybe a) +tryOnExistingFile action fn = C.handle ignoreIOException $ do + exists <- doesFileExist fn + if exists then Just `liftM` action fn + else return Nothing + +ignoreIOException :: C.IOException -> IO (Maybe a) +ignoreIOException _ = return Nothing + +-- | Try to write a file. If it already exists and is not writable, +-- a warning is issued. This solves some file dependency problems +-- in global installations. +tryWriteFile :: FilePath -- ^ original path + -> String -- ^ file content + -> IO () +tryWriteFile fn contents = do + exists <- doesFileExist fn + if exists then C.handle issueWarning (writeFileUTF8 fn contents) + else writeFileUTF8 fn contents + where + issueWarning :: C.IOException -> IO () + issueWarning _ = do + putStrLn $ "*** Warning: cannot update file `" ++ fn ++ "' (update ignored)" + return () + writeFileUTF8 :: FilePath -> String -> IO () + writeFileUTF8 fn' str = + withFile fn' WriteMode (\hdl -> hSetEncoding hdl utf8 >> hPutStr hdl str) + +-- | Try to write a file. If it already exists and is not writable, +-- a warning is issued. This solves some file dependency problems +-- in global installations. +tryWriteBinaryFile :: FilePath -- ^ original path + -> B.ByteString -- ^ file content + -> IO () +tryWriteBinaryFile fn contents = do + exists <- doesFileExist fn + if exists then C.handle issueWarning (B.writeFile fn contents) + else B.writeFile fn contents + where + issueWarning :: C.IOException -> IO () + issueWarning _ = do + putStrLn $ "*** Warning: cannot update file `" ++ fn ++ "' (update ignored)" + return () diff --git a/src/Curry/Files/Unlit.hs b/src/Curry/Files/Unlit.hs new file mode 100644 index 0000000000000000000000000000000000000000..ebfaad4612bfa5f58463f1348fc34cb195b50193 --- /dev/null +++ b/src/Curry/Files/Unlit.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE ViewPatterns #-} +{- | + Module : $Header$ + Description : Handling of literate Curry files + Copyright : (c) 2009 Holger Siegel + 2012 - 2014 Björn Peemöller + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + Since version 0.7 of the language report, Curry accepts literate + source programs. In a literate source, all program lines must begin + with a greater sign in the first column. All other lines are assumed + to be documentation. In order to avoid some common errors with + literate programs, Curry requires at least one program line to be + present in the file. In addition, every block of program code must be + preceded by a blank line and followed by a blank line. + + It is also possible to use "\begin{code}" and "\end{code}" + to mark code segments. Both styles can be used in mixed fashion. +-} + +module Curry.Files.Unlit (isLiterate, unlit) where + +import Control.Monad (when, unless, zipWithM) +import Data.Char (isSpace) +import Data.List (stripPrefix) + +import Curry.Base.Monad (CYM, failMessageAt) +import Curry.Base.Span (pos2Span) +import Curry.Base.Position (Position (..), first) +import Curry.Files.Filenames (lcurryExt, takeExtension) + +-- |Check whether a 'FilePath' represents a literate Curry module +isLiterate :: FilePath -> Bool +isLiterate = (== lcurryExt) . takeExtension + +-- |Data type representing different kind of lines in a literate source +data Line + = ProgramStart !Int -- ^ \begin{code} + | ProgramEnd !Int -- ^ \end{code} + | Program !Int String -- ^ program line with a line number and content + | Comment !Int String -- ^ comment line + | Blank !Int -- ^ blank line + +-- |Process a curry program into error messages (if any) and the +-- corresponding non-literate program. +unlit :: FilePath -> String -> CYM String +unlit fn cy + | isLiterate fn = do + let cyl = lines cy + ls <- progLines fn =<< + normalize fn (length cyl) False (zipWith classify [1 .. ] cyl) + when (all null ls) $ failMessageAt (pos2Span $ first fn) "No code in literate script" + return (unlines ls) + | otherwise = return cy + +-- |Classification of a single program line +classify :: Int -> String -> Line +classify l s@('>' : _) = Program l s +classify l s@(stripPrefix "\\begin{code}" -> Just cs) + | all isSpace cs = ProgramStart l + | otherwise = Comment l s +classify l s@(stripPrefix "\\end{code}" -> Just cs) + | all isSpace cs = ProgramEnd l + | otherwise = Comment l s +classify l s + | all isSpace s = Blank l + | otherwise = Comment l s + +-- |Check that ProgramStart and ProgramEnd match and desugar them. +normalize :: FilePath -> Int -> Bool -> [Line] -> CYM [Line] +normalize _ _ False [] = return [] +normalize fn n True [] = reportMissingEnd fn n +normalize fn n b (ProgramStart l : rest) = do + when b $ reportSpurious fn l "\\begin{code}" + norm <- normalize fn n True rest + return (Blank l : norm) +normalize fn n b (ProgramEnd l : rest) = do + unless b $ reportSpurious fn l "\\end{code}" + norm <- normalize fn n False rest + return (Blank l : norm) +normalize fn n b (Comment l s : rest) = do + let cons = if b then Program l s else Comment l s + norm <- normalize fn n b rest + return (cons : norm) +normalize fn n b (Program l s : rest) = do + let cons = if b then Program l s else Program l (drop 1 s) + norm <- normalize fn n b rest + return (cons : norm) +normalize fn n b (Blank l : rest) = do + let cons = if b then Program l "" else Blank l + norm <- normalize fn n b rest + return (cons : norm) + +-- |Check that each program line is not adjacent to a comment line. +progLines :: FilePath -> [Line] -> CYM [String] +progLines fn cs = zipWithM checkAdjacency (Blank 0 : cs) cs where + checkAdjacency (Program p _) (Comment _ _) = reportBlank fn p "followed" + checkAdjacency (Comment _ _) (Program p _) = reportBlank fn p "preceded" + checkAdjacency _ (Program _ s) = return s + checkAdjacency _ _ = return "" + +-- |Compute an appropiate error message +reportBlank :: FilePath -> Int -> String -> CYM a +reportBlank f l cause = failMessageAt (pos2Span $ Position f l 1) msg + where msg = concat [ "When reading literate source: " + , "Program line is " ++ cause ++ " by comment line." + ] + +reportMissingEnd :: FilePath -> Int -> CYM a +reportMissingEnd f l = failMessageAt (pos2Span $ Position f (l+1) 1) msg + where msg = concat [ "When reading literate source: " + , "Missing '\\end{code}' at the end of file." + ] + + +reportSpurious :: FilePath -> Int -> String -> CYM a +reportSpurious f l cause = failMessageAt (pos2Span $ Position f l 1) msg + where msg = concat [ "When reading literate source: " + , "Spurious '" ++ cause ++ "'." + ] diff --git a/src/Curry/FlatCurry.hs b/src/Curry/FlatCurry.hs new file mode 100644 index 0000000000000000000000000000000000000000..0918fb56ceb378959a54fab5cd350366cd44f794 --- /dev/null +++ b/src/Curry/FlatCurry.hs @@ -0,0 +1,19 @@ +{- | + Module : $Header$ + Description : Interface for reading and manipulating FlatCurry source code + Copyright : (c) 2014 Björn Peemöller + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable +-} +module Curry.FlatCurry + ( module Curry.FlatCurry.Type + , module Curry.FlatCurry.Pretty + , module Curry.FlatCurry.Files + ) where + +import Curry.FlatCurry.Files +import Curry.FlatCurry.Pretty +import Curry.FlatCurry.Type diff --git a/src/Curry/FlatCurry/Annotated/Goodies.hs b/src/Curry/FlatCurry/Annotated/Goodies.hs new file mode 100644 index 0000000000000000000000000000000000000000..d3cd9b455fb8994c8c7d63440e98986b3012dc62 --- /dev/null +++ b/src/Curry/FlatCurry/Annotated/Goodies.hs @@ -0,0 +1,685 @@ +{- | + Module : $Header$ + Description : Utility functions for working with annotated FlatCurry. + Copyright : (c) 2016 - 2017 Finn Teegen + License : BSD-3-clause + + Maintainer : fte@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This library provides selector functions, test and update operations + as well as some useful auxiliary functions for AnnotatedFlatCurry data terms. + Most of the provided functions are based on general transformation + functions that replace constructors with user-defined + functions. For recursive datatypes the transformations are defined + inductively over the term structure. This is quite usual for + transformations on AnnotatedFlatCurry terms, + so the provided functions can be used to implement specific transformations + without having to explicitly state the recursion. Essentially, the tedious + part of such transformations - descend in fairly complex term structures - + is abstracted away, which hopefully makes the code more clear and brief. +-} + +module Curry.FlatCurry.Annotated.Goodies + ( module Curry.FlatCurry.Annotated.Goodies + , module Curry.FlatCurry.Goodies + ) where + +import Curry.FlatCurry.Goodies ( Update + , trType, typeName, typeVisibility, typeParams + , typeConsDecls, typeSyn, isTypeSyn + , isDataTypeDecl, isExternalType, isPublicType + , updType, updTypeName, updTypeVisibility + , updTypeParams, updTypeConsDecls, updTypeSynonym + , updQNamesInType + , trCons, consName, consArity, consVisibility + , isPublicCons, consArgs, updCons, updConsName + , updConsArity, updConsVisibility, updConsArgs + , updQNamesInConsDecl + , trNewCons, newConsName, newConsVisibility + , isPublicNewCons, newConsArg + , updNewCons, updNewConsName + , updNewConsVisibility, updNewConsArg + , updQNamesInNewConsDecl + , tVarIndex, domain, range, tConsName, tConsArgs + , trTypeExpr, isTVar, isTCons, isFuncType + , updTVars, updTCons, updFuncTypes, argTypes + , typeArity, resultType, allVarsInTypeExpr + , allTypeCons, rnmAllVarsInTypeExpr + , updQNamesInTypeExpr + , trOp, opName, opFixity, opPrecedence, updOp + , updOpName, updOpFixity, updOpPrecedence + , trCombType, isCombTypeFuncCall + , isCombTypeFuncPartCall, isCombTypeConsCall + , isCombTypeConsPartCall + , isPublic + ) + +import Curry.FlatCurry.Annotated.Type + +-- AProg ---------------------------------------------------------------------- + +-- |transform program +trAProg :: (String -> [String] -> [TypeDecl] -> [AFuncDecl a] -> [OpDecl] -> b) + -> AProg a -> b +trAProg prog (AProg name imps types funcs ops) = prog name imps types funcs ops + +-- Selectors + +-- |get name from program +aProgName :: AProg a -> String +aProgName = trAProg (\name _ _ _ _ -> name) + +-- |get imports from program +aProgImports :: AProg a -> [String] +aProgImports = trAProg (\_ imps _ _ _ -> imps) + +-- |get type declarations from program +aProgTypes :: AProg a -> [TypeDecl] +aProgTypes = trAProg (\_ _ types _ _ -> types) + +-- |get functions from program +aProgAFuncs :: AProg a -> [AFuncDecl a] +aProgAFuncs = trAProg (\_ _ _ funcs _ -> funcs) + +-- |get infix operators from program +aProgOps :: AProg a -> [OpDecl] +aProgOps = trAProg (\_ _ _ _ ops -> ops) + +-- Update Operations + +-- |update program +updAProg :: (String -> String) -> + ([String] -> [String]) -> + ([TypeDecl] -> [TypeDecl]) -> + ([AFuncDecl a] -> [AFuncDecl a]) -> + ([OpDecl] -> [OpDecl]) -> AProg a -> AProg a +updAProg fn fi ft ff fo = trAProg prog + where + prog name imps types funcs ops + = AProg (fn name) (fi imps) (ft types) (ff funcs) (fo ops) + +-- |update name of program +updAProgName :: Update (AProg a) String +updAProgName f = updAProg f id id id id + +-- |update imports of program +updAProgImports :: Update (AProg a) [String] +updAProgImports f = updAProg id f id id id + +-- |update type declarations of program +updAProgTypes :: Update (AProg a) [TypeDecl] +updAProgTypes f = updAProg id id f id id + +-- |update functions of program +updAProgAFuncs :: Update (AProg a) [AFuncDecl a] +updAProgAFuncs f = updAProg id id id f id + +-- |update infix operators of program +updAProgOps :: Update (AProg a) [OpDecl] +updAProgOps = updAProg id id id id + +-- Auxiliary Functions + +-- |get all program variables (also from patterns) +allVarsInAProg :: AProg a -> [(VarIndex, a)] +allVarsInAProg = concatMap allVarsInAFunc . aProgAFuncs + +-- |lift transformation on expressions to program +updAProgAExps :: Update (AProg a) (AExpr a) +updAProgAExps = updAProgAFuncs . map . updAFuncBody + +-- |rename programs variables +rnmAllVarsInAProg :: Update (AProg a) VarIndex +rnmAllVarsInAProg = updAProgAFuncs . map . rnmAllVarsInAFunc + +-- |update all qualified names in program +updQNamesInAProg :: Update (AProg a) QName +updQNamesInAProg f = updAProg id id + (map (updQNamesInType f)) (map (updQNamesInAFunc f)) (map (updOpName f)) + +-- |rename program (update name of and all qualified names in program) +rnmAProg :: String -> AProg a -> AProg a +rnmAProg name p = updAProgName (const name) (updQNamesInAProg rnm p) + where + rnm (m, n) | m == aProgName p = (name, n) + | otherwise = (m, n) + +-- AFuncDecl ------------------------------------------------------------------ + +-- |transform function +trAFunc :: (QName -> Int -> Visibility -> TypeExpr -> ARule a -> b) -> AFuncDecl a -> b +trAFunc func (AFunc name arity vis t rule) = func name arity vis t rule + +-- Selectors + +-- |get name of function +aFuncName :: AFuncDecl a -> QName +aFuncName = trAFunc (\name _ _ _ _ -> name) + +-- |get arity of function +aFuncArity :: AFuncDecl a -> Int +aFuncArity = trAFunc (\_ arity _ _ _ -> arity) + +-- |get visibility of function +aFuncVisibility :: AFuncDecl a -> Visibility +aFuncVisibility = trAFunc (\_ _ vis _ _ -> vis) + +-- |get type of function +aFuncType :: AFuncDecl a -> TypeExpr +aFuncType = trAFunc (\_ _ _ t _ -> t) + +-- |get rule of function +aFuncARule :: AFuncDecl a -> ARule a +aFuncARule = trAFunc (\_ _ _ _ rule -> rule) + +-- Update Operations + +-- |update function +updAFunc :: (QName -> QName) -> + (Int -> Int) -> + (Visibility -> Visibility) -> + (TypeExpr -> TypeExpr) -> + (ARule a -> ARule a) -> AFuncDecl a -> AFuncDecl a +updAFunc fn fa fv ft fr = trAFunc func + where + func name arity vis t rule + = AFunc (fn name) (fa arity) (fv vis) (ft t) (fr rule) + +-- |update name of function +updAFuncName :: Update (AFuncDecl a) QName +updAFuncName f = updAFunc f id id id id + +-- |update arity of function +updAFuncArity :: Update (AFuncDecl a) Int +updAFuncArity f = updAFunc id f id id id + +-- |update visibility of function +updAFuncVisibility :: Update (AFuncDecl a) Visibility +updAFuncVisibility f = updAFunc id id f id id + +-- |update type of function +updFuncType :: Update (AFuncDecl a) TypeExpr +updFuncType f = updAFunc id id id f id + +-- |update rule of function +updAFuncARule :: Update (AFuncDecl a) (ARule a) +updAFuncARule = updAFunc id id id id + +-- Auxiliary Functions + +-- |is function public? +isPublicAFunc :: AFuncDecl a -> Bool +isPublicAFunc = isPublic . aFuncVisibility + +-- |is function externally defined? +isExternal :: AFuncDecl a -> Bool +isExternal = isARuleExternal . aFuncARule + +-- |get variable names in a function declaration +allVarsInAFunc :: AFuncDecl a -> [(VarIndex, a)] +allVarsInAFunc = allVarsInARule . aFuncARule + +-- |get arguments of function, if not externally defined +aFuncArgs :: AFuncDecl a -> [(VarIndex, a)] +aFuncArgs = aRuleArgs . aFuncARule + +-- |get body of function, if not externally defined +aFuncBody :: AFuncDecl a -> AExpr a +aFuncBody = aRuleBody . aFuncARule + +-- |get the right-hand-sides of a 'FuncDecl' +aFuncRHS :: AFuncDecl a -> [AExpr a] +aFuncRHS f | not (isExternal f) = orCase (aFuncBody f) + | otherwise = [] + where + orCase e + | isAOr e = concatMap orCase (orExps e) + | isACase e = concatMap orCase (map aBranchAExpr (caseBranches e)) + | otherwise = [e] + +-- |rename all variables in function +rnmAllVarsInAFunc :: Update (AFuncDecl a) VarIndex +rnmAllVarsInAFunc = updAFunc id id id id . rnmAllVarsInARule + +-- |update all qualified names in function +updQNamesInAFunc :: Update (AFuncDecl a) QName +updQNamesInAFunc f = updAFunc f id id (updQNamesInTypeExpr f) (updQNamesInARule f) + +-- |update arguments of function, if not externally defined +updAFuncArgs :: Update (AFuncDecl a) [(VarIndex, a)] +updAFuncArgs = updAFuncARule . updARuleArgs + +-- |update body of function, if not externally defined +updAFuncBody :: Update (AFuncDecl a) (AExpr a) +updAFuncBody = updAFuncARule . updARuleBody + +-- ARule ---------------------------------------------------------------------- + +-- |transform rule +trARule :: (a -> [(VarIndex, a)] -> AExpr a -> b) -> (a -> String -> b) -> ARule a -> b +trARule rule _ (ARule a args e) = rule a args e +trARule _ ext (AExternal a s) = ext a s + +-- Selectors + +-- |get rules annotation +aRuleAnnot :: ARule a -> a +aRuleAnnot = trARule (\a _ _ -> a) (\a _ -> a) + +-- |get rules arguments if it's not external +aRuleArgs :: ARule a -> [(VarIndex, a)] +aRuleArgs = trARule (\_ args _ -> args) undefined + +-- |get rules body if it's not external +aRuleBody :: ARule a -> AExpr a +aRuleBody = trARule (\_ _ e -> e) undefined + +-- |get rules external declaration +aRuleExtDecl :: ARule a -> String +aRuleExtDecl = trARule undefined (\_ s -> s) + +-- Test Operations + +-- |is rule external? +isARuleExternal :: ARule a -> Bool +isARuleExternal = trARule (\_ _ _ -> False) (\_ _ -> True) + +-- Update Operations + +-- |update rule +updARule :: (a -> b) -> + ([(VarIndex, a)] -> [(VarIndex, b)]) -> + (AExpr a -> AExpr b) -> + (String -> String) -> ARule a -> ARule b +updARule fannot fa fe fs = trARule rule ext + where + rule a args e = ARule (fannot a) (fa args) (fe e) + ext a s = AExternal (fannot a) (fs s) + +-- |update rules annotation +updARuleAnnot :: Update (ARule a) a +updARuleAnnot f = updARule f id id id + +-- |update rules arguments +updARuleArgs :: Update (ARule a) [(VarIndex, a)] +updARuleArgs f = updARule id f id id + +-- |update rules body +updARuleBody :: Update (ARule a) (AExpr a) +updARuleBody f = updARule id id f id + +-- |update rules external declaration +updARuleExtDecl :: Update (ARule a) String +updARuleExtDecl f = updARule id id id f + +-- Auxiliary Functions + +-- |get variable names in a functions rule +allVarsInARule :: ARule a -> [(VarIndex, a)] +allVarsInARule = trARule (\_ args body -> args ++ allVars body) (\_ _ -> []) + +-- |rename all variables in rule +rnmAllVarsInARule :: Update (ARule a) VarIndex +rnmAllVarsInARule f = updARule id (map (\(a, b) -> (f a, b))) (rnmAllVars f) id + +-- |update all qualified names in rule +updQNamesInARule :: Update (ARule a) QName +updQNamesInARule = updARuleBody . updQNames + +-- AExpr ---------------------------------------------------------------------- + +-- Selectors + +-- |get annoation of an expression +annot :: AExpr a -> a +annot (AVar a _ ) = a +annot (ALit a _ ) = a +annot (AComb a _ _ _) = a +annot (ALet a _ _ ) = a +annot (AFree a _ _ ) = a +annot (AOr a _ _ ) = a +annot (ACase a _ _ _) = a +annot (ATyped a _ _ ) = a + +-- |get internal number of variable +varNr :: AExpr a -> VarIndex +varNr (AVar _ n) = n +varNr _ = error "Curry.FlatCurry.Annotated.Goodies.varNr: no variable" + +-- |get literal if expression is literal expression +literal :: AExpr a -> Literal +literal (ALit _ l) = l +literal _ = error "Curry.FlatCurry.Annotated.Goodies.literal: no literal" + +-- |get combination type of a combined expression +combType :: AExpr a -> CombType +combType (AComb _ ct _ _) = ct +combType _ = error $ "Curry.FlatCurry.Annotated.Goodies.combType: " ++ + "no combined expression" + +-- |get name of a combined expression +combName :: AExpr a -> (QName, a) +combName (AComb _ _ name _) = name +combName _ = error $ "Curry.FlatCurry.Annotated.Goodies.combName: " ++ + "no combined expression" + +-- |get arguments of a combined expression +combArgs :: AExpr a -> [AExpr a] +combArgs (AComb _ _ _ args) = args +combArgs _ = error $ "Curry.FlatCurry.Annotated.Goodies.combArgs: " ++ + "no combined expression" + +-- |get number of missing arguments if expression is combined +missingCombArgs :: AExpr a -> Int +missingCombArgs = missingArgs . combType + where + missingArgs :: CombType -> Int + missingArgs = trCombType 0 id 0 id + +-- |get indices of varoables in let declaration +letBinds :: AExpr a -> [((VarIndex, a), AExpr a)] +letBinds (ALet _ vs _) = vs +letBinds _ = error $ "Curry.FlatCurry.Annotated.Goodies.letBinds: " ++ + "no let expression" + +-- |get body of let declaration +letBody :: AExpr a -> AExpr a +letBody (ALet _ _ e) = e +letBody _ = error $ "Curry.FlatCurry.Annotated.Goodies.letBody: " ++ + "no let expression" + +-- |get variable indices from declaration of free variables +freeVars :: AExpr a -> [(VarIndex, a)] +freeVars (AFree _ vs _) = vs +freeVars _ = error $ "Curry.FlatCurry.Annotated.Goodies.freeVars: " ++ + "no declaration of free variables" + +-- |get expression from declaration of free variables +freeExpr :: AExpr a -> AExpr a +freeExpr (AFree _ _ e) = e +freeExpr _ = error $ "Curry.FlatCurry.Annotated.Goodies.freeExpr: " ++ + "no declaration of free variables" + +-- |get expressions from or-expression +orExps :: AExpr a -> [AExpr a] +orExps (AOr _ e1 e2) = [e1, e2] +orExps _ = error $ "Curry.FlatCurry.Annotated.Goodies.orExps: " ++ + "no or expression" + +-- |get case-type of case expression +caseType :: AExpr a -> CaseType +caseType (ACase _ ct _ _) = ct +caseType _ = error $ "Curry.FlatCurry.Annotated.Goodies.caseType: " ++ + "no case expression" + +-- |get scrutinee of case expression +caseExpr :: AExpr a -> AExpr a +caseExpr (ACase _ _ e _) = e +caseExpr _ = error $ "Curry.FlatCurry.Annotated.Goodies.caseExpr: " ++ + "no case expression" + + +-- |get branch expressions from case expression +caseBranches :: AExpr a -> [ABranchExpr a] +caseBranches (ACase _ _ _ bs) = bs +caseBranches _ = error + "Curry.FlatCurry.Annotated.Goodies.caseBranches: no case expression" + +-- Test Operations + +-- |is expression a variable? +isAVar :: AExpr a -> Bool +isAVar e = case e of + AVar _ _ -> True + _ -> False + +-- |is expression a literal expression? +isALit :: AExpr a -> Bool +isALit e = case e of + ALit _ _ -> True + _ -> False + +-- |is expression combined? +isAComb :: AExpr a -> Bool +isAComb e = case e of + AComb _ _ _ _ -> True + _ -> False + +-- |is expression a let expression? +isALet :: AExpr a -> Bool +isALet e = case e of + ALet _ _ _ -> True + _ -> False + +-- |is expression a declaration of free variables? +isAFree :: AExpr a -> Bool +isAFree e = case e of + AFree _ _ _ -> True + _ -> False + +-- |is expression an or-expression? +isAOr :: AExpr a -> Bool +isAOr e = case e of + AOr _ _ _ -> True + _ -> False + +-- |is expression a case expression? +isACase :: AExpr a -> Bool +isACase e = case e of + ACase _ _ _ _ -> True + _ -> False + +-- |transform expression +trAExpr :: (a -> VarIndex -> b) + -> (a -> Literal -> b) + -> (a -> CombType -> (QName, a) -> [b] -> b) + -> (a -> [((VarIndex, a), b)] -> b -> b) + -> (a -> [(VarIndex, a)] -> b -> b) + -> (a -> b -> b -> b) + -> (a -> CaseType -> b -> [c] -> b) + -> (APattern a -> b -> c) + -> (a -> b -> TypeExpr -> b) + -> AExpr a + -> b +trAExpr var lit comb lt fr oR cas branch typed expr = case expr of + AVar a n -> var a n + ALit a l -> lit a l + AComb a ct name args -> comb a ct name (map f args) + ALet a bs e -> lt a (map (\(v, x) -> (v, f x)) bs) (f e) + AFree a vs e -> fr a vs (f e) + AOr a e1 e2 -> oR a (f e1) (f e2) + ACase a ct e bs -> cas a ct (f e) (map (\ (ABranch p e') -> branch p (f e')) bs) + ATyped a e ty -> typed a (f e) ty + where + f = trAExpr var lit comb lt fr oR cas branch typed + +-- |update all variables in given expression +updVars :: (a -> VarIndex -> AExpr a) -> AExpr a -> AExpr a +updVars var = trAExpr var ALit AComb ALet AFree AOr ACase ABranch ATyped + +-- |update all literals in given expression +updLiterals :: (a -> Literal -> AExpr a) -> AExpr a -> AExpr a +updLiterals lit = trAExpr AVar lit AComb ALet AFree AOr ACase ABranch ATyped + +-- |update all combined expressions in given expression +updCombs :: (a -> CombType -> (QName, a) -> [AExpr a] -> AExpr a) -> AExpr a -> AExpr a +updCombs comb = trAExpr AVar ALit comb ALet AFree AOr ACase ABranch ATyped + +-- |update all let expressions in given expression +updLets :: (a -> [((VarIndex, a), AExpr a)] -> AExpr a -> AExpr a) -> AExpr a -> AExpr a +updLets lt = trAExpr AVar ALit AComb lt AFree AOr ACase ABranch ATyped + +-- |update all free declarations in given expression +updFrees :: (a -> [(VarIndex, a)] -> AExpr a -> AExpr a) -> AExpr a -> AExpr a +updFrees fr = trAExpr AVar ALit AComb ALet fr AOr ACase ABranch ATyped + +-- |update all or expressions in given expression +updOrs :: (a -> AExpr a -> AExpr a -> AExpr a) -> AExpr a -> AExpr a +updOrs oR = trAExpr AVar ALit AComb ALet AFree oR ACase ABranch ATyped + +-- |update all case expressions in given expression +updCases :: (a -> CaseType -> AExpr a -> [ABranchExpr a] -> AExpr a) -> AExpr a -> AExpr a +updCases cas = trAExpr AVar ALit AComb ALet AFree AOr cas ABranch ATyped + +-- |update all case branches in given expression +updBranches :: (APattern a -> AExpr a -> ABranchExpr a) -> AExpr a -> AExpr a +updBranches branch = trAExpr AVar ALit AComb ALet AFree AOr ACase branch ATyped + +-- |update all typed expressions in given expression +updTypeds :: (a -> AExpr a -> TypeExpr -> AExpr a) -> AExpr a -> AExpr a +updTypeds = trAExpr AVar ALit AComb ALet AFree AOr ACase ABranch + +-- Auxiliary Functions + +-- |is expression a call of a function where all arguments are provided? +isFuncCall :: AExpr a -> Bool +isFuncCall e = isAComb e && isCombTypeFuncCall (combType e) + +-- |is expression a partial function call? +isFuncPartCall :: AExpr a -> Bool +isFuncPartCall e = isAComb e && isCombTypeFuncPartCall (combType e) + +-- |is expression a call of a constructor? +isConsCall :: AExpr a -> Bool +isConsCall e = isAComb e && isCombTypeConsCall (combType e) + +-- |is expression a partial constructor call? +isConsPartCall :: AExpr a -> Bool +isConsPartCall e = isAComb e && isCombTypeConsPartCall (combType e) + +-- |is expression fully evaluated? +isGround :: AExpr a -> Bool +isGround e + = case e of + AComb _ ConsCall _ args -> all isGround args + _ -> isALit e + +-- |get all variables (also pattern variables) in expression +allVars :: AExpr a -> [(VarIndex, a)] +allVars e = trAExpr var lit comb lt fr (const (.)) cas branch typ e [] + where + var a v = (:) (v, a) + lit = const (const id) + comb _ _ _ = foldr (.) id + lt _ bs e' = e' . foldr (.) id (map (\(n,ns) -> (n:) . ns) bs) + fr _ vs e' = (vs++) . e' + cas _ _ e' bs = e' . foldr (.) id bs + branch pat e' = ((args pat)++) . e' + typ _ = const + args pat | isConsPattern pat = aPatArgs pat + | otherwise = [] + +-- |rename all variables (also in patterns) in expression +rnmAllVars :: Update (AExpr a) VarIndex +rnmAllVars f = trAExpr var ALit AComb lt fr AOr ACase branch ATyped + where + var a = AVar a . f + lt a = ALet a . map (\((n, b), e) -> ((f n, b), e)) + fr a = AFree a . map (\(b, c) -> (f b, c)) + branch = ABranch . updAPatArgs (map (\(a, b) -> (f a, b))) + +-- |update all qualified names in expression +updQNames :: Update (AExpr a) QName +updQNames f = trAExpr AVar ALit comb ALet AFree AOr ACase branch ATyped + where + comb a ct (name, a') args = AComb a ct (f name, a') args + branch = ABranch . updAPatCons (\(q, a) -> (f q, a)) + +-- ABranchExpr ---------------------------------------------------------------- + +-- |transform branch expression +trABranch :: (APattern a -> AExpr a -> b) -> ABranchExpr a -> b +trABranch branch (ABranch pat e) = branch pat e + +-- Selectors + +-- |get pattern from branch expression +aBranchAPattern :: ABranchExpr a -> APattern a +aBranchAPattern = trABranch (\pat _ -> pat) + +-- |get expression from branch expression +aBranchAExpr :: ABranchExpr a -> AExpr a +aBranchAExpr = trABranch (\_ e -> e) + +-- Update Operations + +-- |update branch expression +updABranch :: (APattern a -> APattern a) -> (AExpr a -> AExpr a) -> ABranchExpr a -> ABranchExpr a +updABranch fp fe = trABranch branch + where + branch pat e = ABranch (fp pat) (fe e) + +-- |update pattern of branch expression +updABranchAPattern :: Update (ABranchExpr a) (APattern a) +updABranchAPattern f = updABranch f id + +-- |update expression of branch expression +updABranchAExpr :: Update (ABranchExpr a) (AExpr a) +updABranchAExpr = updABranch id + +-- APattern ------------------------------------------------------------------- + +-- |transform pattern +trAPattern :: (a -> (QName, a) -> [(VarIndex, a)] -> b) -> (a -> Literal -> b) -> APattern a -> b +trAPattern pat _ (APattern a name args) = pat a name args +trAPattern _ lpat (ALPattern a l) = lpat a l + +-- Selectors + +-- |get annotation from pattern +aPatAnnot :: APattern a -> a +aPatAnnot = trAPattern (\a _ _ -> a) (\a _ -> a) + +-- |get name from constructor pattern +aPatCons :: APattern a -> (QName, a) +aPatCons = trAPattern (\_ name _ -> name) undefined + +-- |get arguments from constructor pattern +aPatArgs :: APattern a -> [(VarIndex, a)] +aPatArgs = trAPattern (\_ _ args -> args) undefined + +-- |get literal from literal pattern +aPatLiteral :: APattern a -> Literal +aPatLiteral = trAPattern undefined (const id) + +-- Test Operations + +-- |is pattern a constructor pattern? +isConsPattern :: APattern a -> Bool +isConsPattern = trAPattern (\_ _ _ -> True) (\_ _ -> False) + +-- Update Operations + +-- |update pattern +updAPattern :: (a -> a) -> + ((QName, a) -> (QName, a)) -> + ([(VarIndex, a)] -> [(VarIndex, a)]) -> + (Literal -> Literal) -> APattern a -> APattern a +updAPattern fannot fn fa fl = trAPattern pat lpat + where + pat a name args = APattern (fannot a) (fn name) (fa args) + lpat a l = ALPattern (fannot a) (fl l) + +-- |update annotation of pattern +updAPatAnnot :: (a -> a) -> APattern a -> APattern a +updAPatAnnot f = updAPattern f id id id + +-- |update constructors name of pattern +updAPatCons :: ((QName, a) -> (QName, a)) -> APattern a -> APattern a +updAPatCons f = updAPattern id f id id + +-- |update arguments of constructor pattern +updAPatArgs :: ([(VarIndex, a)] -> [(VarIndex, a)]) -> APattern a -> APattern a +updAPatArgs f = updAPattern id id f id + +-- |update literal of pattern +updAPatLiteral :: (Literal -> Literal) -> APattern a -> APattern a +updAPatLiteral f = updAPattern id id id f + +-- Auxiliary Functions + +-- |build expression from pattern +aPatExpr :: APattern a -> AExpr a +aPatExpr = trAPattern (\a name -> AComb a ConsCall name . map (uncurry (flip AVar))) ALit diff --git a/src/Curry/FlatCurry/Annotated/Type.hs b/src/Curry/FlatCurry/Annotated/Type.hs new file mode 100644 index 0000000000000000000000000000000000000000..3b76477936b4dc0af540400c6f8a615192e2c703 --- /dev/null +++ b/src/Curry/FlatCurry/Annotated/Type.hs @@ -0,0 +1,132 @@ +{- | + Module : $Header$ + Description : Representation of annotated FlatCurry. + Copyright : (c) 2016 - 2017 Finn Teegen + License : BSD-3-clause + + Maintainer : fte@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + TODO +-} + +module Curry.FlatCurry.Annotated.Type + ( module Curry.FlatCurry.Annotated.Type + , module Curry.FlatCurry.Typeable + , module Curry.FlatCurry.Type + ) where + +import Data.Binary +import Control.Monad + +import Curry.FlatCurry.Typeable +import Curry.FlatCurry.Type ( QName, VarIndex, Visibility (..), TVarIndex + , TypeDecl (..), Kind (..), OpDecl (..), Fixity (..) + , TypeExpr (..), ConsDecl (..), NewConsDecl (..) + , Literal (..), CombType (..), CaseType (..) + ) + +data AProg a = AProg String [String] [TypeDecl] [AFuncDecl a] [OpDecl] + deriving (Eq, Read, Show) + +data AFuncDecl a = AFunc QName Int Visibility TypeExpr (ARule a) + deriving (Eq, Read, Show) + +data ARule a + = ARule a [(VarIndex, a)] (AExpr a) + | AExternal a String + deriving (Eq, Read, Show) + +data AExpr a + = AVar a VarIndex + | ALit a Literal + | AComb a CombType (QName, a) [AExpr a] + | ALet a [((VarIndex, a), AExpr a)] (AExpr a) + | AFree a [(VarIndex, a)] (AExpr a) + | AOr a (AExpr a) (AExpr a) + | ACase a CaseType (AExpr a) [ABranchExpr a] + | ATyped a (AExpr a) TypeExpr + deriving (Eq, Read, Show) + +data ABranchExpr a = ABranch (APattern a) (AExpr a) + deriving (Eq, Read, Show) + +data APattern a + = APattern a (QName, a) [(VarIndex, a)] + | ALPattern a Literal + deriving (Eq, Read, Show) + +instance Typeable a => Typeable (AExpr a) where + typeOf (AVar a _) = typeOf a + typeOf (ALit a _) = typeOf a + typeOf (AComb a _ _ _) = typeOf a + typeOf (ALet a _ _) = typeOf a + typeOf (AFree a _ _) = typeOf a + typeOf (AOr a _ _) = typeOf a + typeOf (ACase a _ _ _) = typeOf a + typeOf (ATyped a _ _) = typeOf a + +instance Typeable a => Typeable (APattern a) where + typeOf (APattern a _ _) = typeOf a + typeOf (ALPattern a _) = typeOf a + +instance Binary a => Binary (AProg a) where + put (AProg mid im tys fus ops) = + put mid >> put im >> put tys >> put fus >> put ops + get = AProg <$> get <*> get <*> get <*> get <*> get + +instance Binary a => Binary (AFuncDecl a) where + put (AFunc qid arity vis ty r) = + put qid >> put arity >> put vis >> put ty >> put r + get = AFunc <$> get <*> get <*> get <*> get <*> get + +instance Binary a => Binary (ARule a) where + put (ARule a alts e) = putWord8 0 >> put a >> put alts >> put e + put (AExternal ty n ) = putWord8 1 >> put ty >> put n + + get = do + x <- getWord8 + case x of + 0 -> liftM3 ARule get get get + 1 -> liftM2 AExternal get get + _ -> fail "Invalid encoding for TRule" + +instance Binary a => Binary (AExpr a) where + put (AVar a v) = putWord8 0 >> put a >> put v + put (ALit a l) = putWord8 1 >> put a >> put l + put (AComb a cty qid es) = + putWord8 2 >> put a >> put cty >> put qid >> put es + put (ALet a bs e ) = putWord8 3 >> put a >> put bs >> put e + put (AFree a vs e ) = putWord8 4 >> put a >> put vs >> put e + put (AOr a e1 e2) = putWord8 5 >> put a >> put e1 >> put e2 + put (ACase a cty ty as) = putWord8 6 >> put a >> put cty >> put ty >> put as + put (ATyped a e ty) = putWord8 7 >> put a >> put e >> put ty + + get = do + x <- getWord8 + case x of + 0 -> liftM2 AVar get get + 1 -> liftM2 ALit get get + 2 -> liftM4 AComb get get get get + 3 -> liftM3 ALet get get get + 4 -> liftM3 AFree get get get + 5 -> liftM3 AOr get get get + 6 -> liftM4 ACase get get get get + 7 -> liftM3 ATyped get get get + _ -> fail "Invalid encoding for TExpr" + +instance Binary a => Binary (ABranchExpr a) where + put (ABranch p e) = put p >> put e + get = liftM2 ABranch get get + +instance Binary a => Binary (APattern a) where + put (APattern a qid vs) = putWord8 0 >> put a >> put qid >> put vs + put (ALPattern a l ) = putWord8 1 >> put a >> put l + + get = do + x <- getWord8 + case x of + 0 -> liftM3 APattern get get get + 1 -> liftM2 ALPattern get get + _ -> fail "Invalid encoding for TPattern" diff --git a/src/Curry/FlatCurry/Files.hs b/src/Curry/FlatCurry/Files.hs new file mode 100644 index 0000000000000000000000000000000000000000..e03234a6554a554c3cacdd4a31457be9dfcee6a9 --- /dev/null +++ b/src/Curry/FlatCurry/Files.hs @@ -0,0 +1,68 @@ +{- | + Module : $Header$ + Description : Functions for reading and writing FlatCurry files + Copyright : (c) 2014 Björn Peemöller + 2017 Finn Teegen + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This module contains functions for reading and writing FlatCurry files. +-} + +module Curry.FlatCurry.Files + ( readTypedFlatCurry, readFlatCurry, readFlatInterface + , writeFlatCurry, writeBinaryFlatCurry + ) where + +import Data.Binary (Binary, encode) +import Data.Char (isSpace) + +import Curry.Files.Filenames (typedFlatName, flatName, flatIntName) +import Curry.Files.PathUtils (writeModule, writeBinaryModule, readModule) + +import Curry.FlatCurry.Type (Prog) +import Curry.FlatCurry.Annotated.Type (AProg, TypeExpr) + + +-- --------------------------------------------------------------------------- +-- Functions for reading and writing FlatCurry terms +-- --------------------------------------------------------------------------- + +-- |Reads an typed FlatCurry file (extension ".tfcy") and eventually +-- returns the corresponding FlatCurry program term (type 'AProg'). +readTypedFlatCurry :: FilePath -> IO (Maybe (AProg TypeExpr)) +readTypedFlatCurry = readFlat . typedFlatName + +-- |Reads a FlatCurry file (extension ".fcy") and eventually returns the +-- corresponding FlatCurry program term (type 'Prog'). +readFlatCurry :: FilePath -> IO (Maybe Prog) +readFlatCurry = readFlat . flatName + +-- |Reads a FlatInterface file (extension @.fint@) and returns the +-- corresponding term (type 'Prog') as a value of type 'Maybe'. +readFlatInterface :: FilePath -> IO (Maybe Prog) +readFlatInterface = readFlat . flatIntName + +-- |Reads a Flat file and returns the corresponding term (type 'Prog' or +-- 'AProg') as a value of type 'Maybe'. +-- Due to compatibility with PAKCS it is allowed to have a commentary +-- at the beginning of the file enclosed in {- ... -}. +readFlat :: Read a => FilePath -> IO (Maybe a) +readFlat = fmap (fmap (read . skipComment)) . readModule where + skipComment s = case dropWhile isSpace s of + '{' : '-' : s' -> dropComment s' + s' -> s' + dropComment ('-' : '}' : xs) = xs + dropComment (_ : xs) = dropComment xs + dropComment [] = [] + +-- |Writes a FlatCurry program term into a file. +writeFlatCurry :: Show a => FilePath -> a -> IO () +writeFlatCurry fn = writeModule fn . show + +-- |Writes a FlatCurry program term into a normal and a binary file. +writeBinaryFlatCurry :: Binary a => FilePath -> a -> IO () +writeBinaryFlatCurry fn = writeBinaryModule fn . encode diff --git a/src/Curry/FlatCurry/Goodies.hs b/src/Curry/FlatCurry/Goodies.hs new file mode 100644 index 0000000000000000000000000000000000000000..edd98ee44670a1641a4abab16a06260ba1b6b751 --- /dev/null +++ b/src/Curry/FlatCurry/Goodies.hs @@ -0,0 +1,1037 @@ +{- | + Module : $Header$ + Description : Utility functions for working with FlatCurry. + Copyright : (c) Sebastian Fischer 2006 + Björn Peemöller 2011 + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This library provides selector functions, test and update operations + as well as some useful auxiliary functions for FlatCurry data terms. + Most of the provided functions are based on general transformation + functions that replace constructors with user-defined functions. For + recursive datatypes the transformations are defined inductively over the + term structure. This is quite usual for transformations on FlatCurry + terms, so the provided functions can be used to implement specific + transformations without having to explicitly state the recursion. + Essentially, the tedious part of such transformations - descend in fairly + complex term structures - is abstracted away, which hopefully makes the + code more clear and brief. +-} + +module Curry.FlatCurry.Goodies where + +import Curry.FlatCurry.Type + +-- |Update of a type's component +type Update a b = (b -> b) -> a -> a + +-- Prog ---------------------------------------------------------------------- + +-- |transform program +trProg :: (String -> [String] -> [TypeDecl] -> [FuncDecl] -> [OpDecl] -> a) + -> Prog -> a +trProg prog (Prog name imps types funcs ops) = prog name imps types funcs ops + +-- Selectors + +-- |get name from program +progName :: Prog -> String +progName = trProg (\name _ _ _ _ -> name) + +-- |get imports from program +progImports :: Prog -> [String] +progImports = trProg (\_ imps _ _ _ -> imps) + +-- |get type declarations from program +progTypes :: Prog -> [TypeDecl] +progTypes = trProg (\_ _ types _ _ -> types) + +-- |get functions from program +progFuncs :: Prog -> [FuncDecl] +progFuncs = trProg (\_ _ _ funcs _ -> funcs) + +-- |get infix operators from program +progOps :: Prog -> [OpDecl] +progOps = trProg (\_ _ _ _ ops -> ops) + +-- Update Operations + +-- |update program +updProg :: (String -> String) -> + ([String] -> [String]) -> + ([TypeDecl] -> [TypeDecl]) -> + ([FuncDecl] -> [FuncDecl]) -> + ([OpDecl] -> [OpDecl]) -> Prog -> Prog +updProg fn fi ft ff fo = trProg prog + where + prog name imps types funcs ops + = Prog (fn name) (fi imps) (ft types) (ff funcs) (fo ops) + +-- |update name of program +updProgName :: Update Prog String +updProgName f = updProg f id id id id + +-- |update imports of program +updProgImports :: Update Prog [String] +updProgImports f = updProg id f id id id + +-- |update type declarations of program +updProgTypes :: Update Prog [TypeDecl] +updProgTypes f = updProg id id f id id + +-- |update functions of program +updProgFuncs :: Update Prog [FuncDecl] +updProgFuncs f = updProg id id id f id + +-- |update infix operators of program +updProgOps :: Update Prog [OpDecl] +updProgOps = updProg id id id id + +-- Auxiliary Functions + +-- |get all program variables (also from patterns) +allVarsInProg :: Prog -> [VarIndex] +allVarsInProg = concatMap allVarsInFunc . progFuncs + +-- |lift transformation on expressions to program +updProgExps :: Update Prog Expr +updProgExps = updProgFuncs . map . updFuncBody + +-- |rename programs variables +rnmAllVarsInProg :: Update Prog VarIndex +rnmAllVarsInProg = updProgFuncs . map . rnmAllVarsInFunc + +-- |update all qualified names in program +updQNamesInProg :: Update Prog QName +updQNamesInProg f = updProg id id + (map (updQNamesInType f)) (map (updQNamesInFunc f)) (map (updOpName f)) + +-- |rename program (update name of and all qualified names in program) +rnmProg :: String -> Prog -> Prog +rnmProg name p = updProgName (const name) (updQNamesInProg rnm p) + where + rnm (m,n) | m==progName p = (name,n) + | otherwise = (m,n) + +-- TypeDecl ------------------------------------------------------------------ + +-- Selectors + +-- |transform type declaration +trType :: (QName -> Visibility -> [TVarWithKind] -> [ConsDecl] -> a) -> + (QName -> Visibility -> [TVarWithKind] -> TypeExpr -> a) -> + (QName -> Visibility -> [TVarWithKind] -> NewConsDecl -> a) -> TypeDecl -> a +trType typ _ _ (Type name vis params cs) = typ name vis params cs +trType _ typesyn _ (TypeSyn name vis params syn) = typesyn name vis params syn +trType _ _ newtyp (TypeNew name vis params nc) = newtyp name vis params nc + +-- |get name of type declaration +typeName :: TypeDecl -> QName +typeName = trType (\name _ _ _ -> name) (\name _ _ _ -> name) (\name _ _ _ -> name) + +-- |get visibility of type declaration +typeVisibility :: TypeDecl -> Visibility +typeVisibility = trType (\_ vis _ _ -> vis) (\_ vis _ _ -> vis) (\_ vis _ _ -> vis) + +-- |get type parameters of type declaration +typeParams :: TypeDecl -> [TVarWithKind] +typeParams = trType (\_ _ params _ -> params) (\_ _ params _ -> params) (\_ _ params _ -> params) + +-- |get constructor declarations from type declaration +typeConsDecls :: TypeDecl -> [ConsDecl] +typeConsDecls = trType (\_ _ _ cs -> cs) + (error "Curry.FlatCurry.Goodies: type synonym") + (error "Curry.FlatCurry.Goodies: newtype") + +-- |get synonym of type declaration +typeSyn :: TypeDecl -> TypeExpr +typeSyn = trType undefined (\_ _ _ syn -> syn) undefined + +-- |is type declaration a type synonym? +isTypeSyn :: TypeDecl -> Bool +isTypeSyn = trType (\_ _ _ _ -> False) (\_ _ _ _ -> True) (\_ _ _ _ -> False) + +-- | is type declaration declaring a regular type? +isDataTypeDecl :: TypeDecl -> Bool +isDataTypeDecl = trType (\_ _ _ cs -> not (null cs)) (\_ _ _ _ -> False) (\_ _ _ _ -> False) + +-- | is type declaration declaring an external type? +isExternalType :: TypeDecl -> Bool +isExternalType = trType (\_ _ _ cs -> null cs) (\_ _ _ _ -> False) (\_ _ _ _ -> False) + +-- |is type declaration a newtype? +isNewtype :: TypeDecl -> Bool +isNewtype = trType (\_ _ _ _ -> False) (\_ _ _ _ -> False) (\_ _ _ _ -> False) + +-- |Is the 'TypeDecl' public? +isPublicType :: TypeDecl -> Bool +isPublicType = (== Public) . typeVisibility + +-- Update Operations + +-- |update type declaration +updType :: (QName -> QName) -> + (Visibility -> Visibility) -> + ([TVarWithKind] -> [TVarWithKind]) -> + ([ConsDecl] -> [ConsDecl]) -> + (NewConsDecl -> NewConsDecl) -> + (TypeExpr -> TypeExpr) -> TypeDecl -> TypeDecl +updType fn fv fp fc fnc fs = trType typ typesyn newtyp + where + typ name vis params cs = Type (fn name) (fv vis) (fp params) (fc cs) + newtyp name vis params nc = TypeNew (fn name) (fv vis) (fp params) (fnc nc) + typesyn name vis params syn = TypeSyn (fn name) (fv vis) (fp params) (fs syn) + +-- |update name of type declaration +updTypeName :: Update TypeDecl QName +updTypeName f = updType f id id id id id + +-- |update visibility of type declaration +updTypeVisibility :: Update TypeDecl Visibility +updTypeVisibility f = updType id f id id id id + +-- |update type parameters of type declaration +updTypeParams :: Update TypeDecl [TVarWithKind] +updTypeParams f = updType id id f id id id + +-- |update constructor declarations of type declaration +updTypeConsDecls :: Update TypeDecl [ConsDecl] +updTypeConsDecls f = updType id id id f id id + +-- |update constructor declarations of newtype declaration +updTypeNewConsDecls :: Update TypeDecl NewConsDecl +updTypeNewConsDecls f = updType id id id id f id + +-- |update synonym of type declaration +updTypeSynonym :: Update TypeDecl TypeExpr +updTypeSynonym = updType id id id id id + +-- Auxiliary Functions + +-- |update all qualified names in type declaration +updQNamesInType :: Update TypeDecl QName +updQNamesInType f + = updType f id id (map (updQNamesInConsDecl f)) (updQNamesInNewConsDecl f) + (updQNamesInTypeExpr f) + +-- ConsDecl ------------------------------------------------------------------ + +-- Selectors + +-- |transform constructor declaration +trCons :: (QName -> Int -> Visibility -> [TypeExpr] -> a) -> ConsDecl -> a +trCons cons (Cons name arity vis args) = cons name arity vis args + +-- |get name of constructor declaration +consName :: ConsDecl -> QName +consName = trCons (\name _ _ _ -> name) + +-- |get arity of constructor declaration +consArity :: ConsDecl -> Int +consArity = trCons (\_ arity _ _ -> arity) + +-- |get visibility of constructor declaration +consVisibility :: ConsDecl -> Visibility +consVisibility = trCons (\_ _ vis _ -> vis) + +-- |Is the constructor declaration public? +isPublicCons :: ConsDecl -> Bool +isPublicCons = isPublic . consVisibility + +-- |get arguments of constructor declaration +consArgs :: ConsDecl -> [TypeExpr] +consArgs = trCons (\_ _ _ args -> args) + +-- Update Operations + +-- |update constructor declaration +updCons :: (QName -> QName) -> + (Int -> Int) -> + (Visibility -> Visibility) -> + ([TypeExpr] -> [TypeExpr]) -> ConsDecl -> ConsDecl +updCons fn fa fv fas = trCons cons + where + cons name arity vis args = Cons (fn name) (fa arity) (fv vis) (fas args) + +-- |update name of constructor declaration +updConsName :: Update ConsDecl QName +updConsName f = updCons f id id id + +-- |update arity of constructor declaration +updConsArity :: Update ConsDecl Int +updConsArity f = updCons id f id id + +-- |update visibility of constructor declaration +updConsVisibility :: Update ConsDecl Visibility +updConsVisibility f = updCons id id f id + +-- |update arguments of constructor declaration +updConsArgs :: Update ConsDecl [TypeExpr] +updConsArgs = updCons id id id + +-- Auxiliary Functions + +-- |update all qualified names in constructor declaration +updQNamesInConsDecl :: Update ConsDecl QName +updQNamesInConsDecl f = updCons f id id (map (updQNamesInTypeExpr f)) + + +-- NewConsDecl ------------------------------------------------------------------ + +-- Selectors + +-- |transform newtype constructor declaration +trNewCons :: (QName -> Visibility -> TypeExpr -> a) -> NewConsDecl -> a +trNewCons cons (NewCons name vis arg) = cons name vis arg + +-- |get name of new constructor declaration +newConsName :: NewConsDecl -> QName +newConsName = trNewCons (\name _ _ -> name) + +-- |get visibility of new constructor declaration +newConsVisibility :: NewConsDecl -> Visibility +newConsVisibility = trNewCons (\_ vis _ -> vis) + +-- |Is the new constructor declaration public? +isPublicNewCons :: ConsDecl -> Bool +isPublicNewCons = isPublic . consVisibility + +-- |get argument of new constructor declaration +newConsArg :: NewConsDecl -> TypeExpr +newConsArg = trNewCons (\_ _ arg -> arg) + +-- Update Operations + +-- |update new constructor declaration +updNewCons :: (QName -> QName) -> + (Visibility -> Visibility) -> + (TypeExpr -> TypeExpr) -> NewConsDecl -> NewConsDecl +updNewCons fn fv fas = trNewCons cons + where + cons name vis args = NewCons (fn name) (fv vis) (fas args) + +-- |update name of new constructor declaration +updNewConsName :: Update NewConsDecl QName +updNewConsName f = updNewCons f id id + +-- |update visibility of new constructor declaration +updNewConsVisibility :: Update NewConsDecl Visibility +updNewConsVisibility f = updNewCons id f id + +-- |update argument of new constructor declaration +updNewConsArg :: Update NewConsDecl TypeExpr +updNewConsArg = updNewCons id id + +-- Auxiliary Functions + +-- |update all qualified names in new constructor declaration +updQNamesInNewConsDecl :: Update NewConsDecl QName +updQNamesInNewConsDecl f = updNewCons f id (updQNamesInTypeExpr f) + +-- TypeExpr ------------------------------------------------------------------ + +-- Selectors + +-- |get index from type variable +tVarIndex :: TypeExpr -> TVarIndex +tVarIndex (TVar n) = n +tVarIndex _ = error $ "Curry.FlatCurry.Goodies.tvarIndex: " ++ + "no type variable" + +-- |get domain from functional type +domain :: TypeExpr -> TypeExpr +domain (FuncType dom _) = dom +domain _ = error $ "Curry.FlatCurry.Goodies.domain: " ++ + "no function type" + +-- |get range from functional type +range :: TypeExpr -> TypeExpr +range (FuncType _ ran) = ran +range _ = error $ "Curry.FlatCurry.Goodies.range: " ++ + "no function type" + +-- |get name from constructed type +tConsName :: TypeExpr -> QName +tConsName (TCons name _) = name +tConsName _ = error $ "Curry.FlatCurry.Goodies.tConsName: " ++ + "no constructor type" + +-- |get arguments from constructed type +tConsArgs :: TypeExpr -> [TypeExpr] +tConsArgs (TCons _ args) = args +tConsArgs _ = error $ "Curry.FlatCurry.Goodies.tConsArgs: " ++ + "no constructor type" + +-- |transform type expression +trTypeExpr :: (TVarIndex -> a) -> + (QName -> [a] -> a) -> + (a -> a -> a) -> + ([TVarWithKind] -> a -> a) -> TypeExpr -> a +trTypeExpr tvar _ _ _ (TVar t) = tvar t +trTypeExpr tvar tcons functype foralltype (TCons name args) + = tcons name (map (trTypeExpr tvar tcons functype foralltype) args) +trTypeExpr tvar tcons functype foralltype (FuncType from to) + = functype (f from) (f to) + where + f = trTypeExpr tvar tcons functype foralltype +trTypeExpr tvar tcons functype foralltype (ForallType ns t) + = foralltype ns (trTypeExpr tvar tcons functype foralltype t) + +-- Test Operations + +-- |is type expression a type variable? +isTVar :: TypeExpr -> Bool +isTVar = trTypeExpr (\_ -> True) (\_ _ -> False) (\_ _ -> False) (\_ _ -> False) + +-- |is type declaration a constructed type? +isTCons :: TypeExpr -> Bool +isTCons + = trTypeExpr (\_ -> False) (\_ _ -> True) (\_ _ -> False) (\_ _ -> False) + +-- |is type declaration a functional type? +isFuncType :: TypeExpr -> Bool +isFuncType + = trTypeExpr (\_ -> False) (\_ _ -> False) (\_ _ -> True) (\_ _ -> False) + +-- |is type declaration a forall type? +isForallType :: TypeExpr -> Bool +isForallType + = trTypeExpr (\_ -> False) (\_ _ -> False) (\_ _ -> False) (\_ _ -> True) + +-- Update Operations + +-- |update all type variables +updTVars :: (TVarIndex -> TypeExpr) -> TypeExpr -> TypeExpr +updTVars tvar = trTypeExpr tvar TCons FuncType ForallType + +-- |update all type constructors +updTCons :: (QName -> [TypeExpr] -> TypeExpr) -> TypeExpr -> TypeExpr +updTCons tcons = trTypeExpr TVar tcons FuncType ForallType + +-- |update all functional types +updFuncTypes :: (TypeExpr -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr +updFuncTypes functype = trTypeExpr TVar TCons functype ForallType + +-- |update all forall types +updForallTypes :: ([TVarWithKind] -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr +updForallTypes = trTypeExpr TVar TCons FuncType + +-- Auxiliary Functions + +-- |get argument types from functional type +argTypes :: TypeExpr -> [TypeExpr] +argTypes (TVar _) = [] +argTypes (TCons _ _) = [] +argTypes (FuncType dom ran) = dom : argTypes ran +argTypes (ForallType _ _) = [] + +-- |Compute the arity of a 'TypeExpr' +typeArity :: TypeExpr -> Int +typeArity = length . argTypes + +-- |get result type from (nested) functional type +resultType :: TypeExpr -> TypeExpr +resultType (TVar n) = TVar n +resultType (TCons name args) = TCons name args +resultType (FuncType _ ran) = resultType ran +resultType (ForallType ns t) = ForallType ns t + +-- |get indexes of all type variables +allVarsInTypeExpr :: TypeExpr -> [TVarIndex] +allVarsInTypeExpr = trTypeExpr pure (const concat) (++) ((++) . map fst) + +-- |yield the list of all contained type constructors +allTypeCons :: TypeExpr -> [QName] +allTypeCons (TVar _) = [] +allTypeCons (TCons name args) = name : concatMap allTypeCons args +allTypeCons (FuncType t1 t2) = allTypeCons t1 ++ allTypeCons t2 +allTypeCons (ForallType _ t) = allTypeCons t + +-- |rename variables in type expression +rnmAllVarsInTypeExpr :: (TVarIndex -> TVarIndex) -> TypeExpr -> TypeExpr +rnmAllVarsInTypeExpr f = updTVars (TVar . f) + +-- |update all qualified names in type expression +updQNamesInTypeExpr :: (QName -> QName) -> TypeExpr -> TypeExpr +updQNamesInTypeExpr f = updTCons (\name args -> TCons (f name) args) + +-- OpDecl -------------------------------------------------------------------- + +-- |transform operator declaration +trOp :: (QName -> Fixity -> Integer -> a) -> OpDecl -> a +trOp op (Op name fix prec) = op name fix prec + +-- Selectors + +-- |get name from operator declaration +opName :: OpDecl -> QName +opName = trOp (\name _ _ -> name) + +-- |get fixity of operator declaration +opFixity :: OpDecl -> Fixity +opFixity = trOp (\_ fix _ -> fix) + +-- |get precedence of operator declaration +opPrecedence :: OpDecl -> Integer +opPrecedence = trOp (\_ _ prec -> prec) + +-- Update Operations + +-- |update operator declaration +updOp :: (QName -> QName) -> + (Fixity -> Fixity) -> + (Integer -> Integer) -> OpDecl -> OpDecl +updOp fn ff fp = trOp op + where op name fix prec = Op (fn name) (ff fix) (fp prec) + +-- |update name of operator declaration +updOpName :: Update OpDecl QName +updOpName f = updOp f id id + +-- |update fixity of operator declaration +updOpFixity :: Update OpDecl Fixity +updOpFixity f = updOp id f id + +-- |update precedence of operator declaration +updOpPrecedence :: Update OpDecl Integer +updOpPrecedence = updOp id id + +-- FuncDecl ------------------------------------------------------------------ + +-- |transform function +trFunc :: (QName -> Int -> Visibility -> TypeExpr -> Rule -> a) -> FuncDecl -> a +trFunc func (Func name arity vis t rule) = func name arity vis t rule + +-- Selectors + +-- |get name of function +funcName :: FuncDecl -> QName +funcName = trFunc (\name _ _ _ _ -> name) + +-- |get arity of function +funcArity :: FuncDecl -> Int +funcArity = trFunc (\_ arity _ _ _ -> arity) + +-- |get visibility of function +funcVisibility :: FuncDecl -> Visibility +funcVisibility = trFunc (\_ _ vis _ _ -> vis) + +-- |get type of function +funcType :: FuncDecl -> TypeExpr +funcType = trFunc (\_ _ _ t _ -> t) + +-- |get rule of function +funcRule :: FuncDecl -> Rule +funcRule = trFunc (\_ _ _ _ rule -> rule) + +-- Update Operations + +-- |update function +updFunc :: (QName -> QName) -> + (Int -> Int) -> + (Visibility -> Visibility) -> + (TypeExpr -> TypeExpr) -> + (Rule -> Rule) -> FuncDecl -> FuncDecl +updFunc fn fa fv ft fr = trFunc func + where + func name arity vis t rule + = Func (fn name) (fa arity) (fv vis) (ft t) (fr rule) + +-- |update name of function +updFuncName :: Update FuncDecl QName +updFuncName f = updFunc f id id id id + +-- |update arity of function +updFuncArity :: Update FuncDecl Int +updFuncArity f = updFunc id f id id id + +-- |update visibility of function +updFuncVisibility :: Update FuncDecl Visibility +updFuncVisibility f = updFunc id id f id id + +-- |update type of function +updFuncType :: Update FuncDecl TypeExpr +updFuncType f = updFunc id id id f id + +-- |update rule of function +updFuncRule :: Update FuncDecl Rule +updFuncRule = updFunc id id id id + +-- Auxiliary Functions + +-- |is function public? +isPublicFunc :: FuncDecl -> Bool +isPublicFunc = isPublic . funcVisibility + +-- |is function externally defined? +isExternal :: FuncDecl -> Bool +isExternal = isRuleExternal . funcRule + +-- |get variable names in a function declaration +allVarsInFunc :: FuncDecl -> [VarIndex] +allVarsInFunc = allVarsInRule . funcRule + +-- |get arguments of function, if not externally defined +funcArgs :: FuncDecl -> [VarIndex] +funcArgs = ruleArgs . funcRule + +-- |get body of function, if not externally defined +funcBody :: FuncDecl -> Expr +funcBody = ruleBody . funcRule + +-- |get the right-hand-sides of a 'FuncDecl' +funcRHS :: FuncDecl -> [Expr] +funcRHS f | not (isExternal f) = orCase (funcBody f) + | otherwise = [] + where + orCase e + | isOr e = concatMap orCase (orExps e) + | isCase e = concatMap orCase (map branchExpr (caseBranches e)) + | otherwise = [e] + +-- |rename all variables in function +rnmAllVarsInFunc :: Update FuncDecl VarIndex +rnmAllVarsInFunc = updFunc id id id id . rnmAllVarsInRule + +-- |update all qualified names in function +updQNamesInFunc :: Update FuncDecl QName +updQNamesInFunc f = updFunc f id id (updQNamesInTypeExpr f) (updQNamesInRule f) + +-- |update arguments of function, if not externally defined +updFuncArgs :: Update FuncDecl [VarIndex] +updFuncArgs = updFuncRule . updRuleArgs + +-- |update body of function, if not externally defined +updFuncBody :: Update FuncDecl Expr +updFuncBody = updFuncRule . updRuleBody + +-- Rule ---------------------------------------------------------------------- + +-- |transform rule +trRule :: ([VarIndex] -> Expr -> a) -> (String -> a) -> Rule -> a +trRule rule _ (Rule args e) = rule args e +trRule _ ext (External s) = ext s + +-- Selectors + +-- |get rules arguments if it's not external +ruleArgs :: Rule -> [VarIndex] +ruleArgs = trRule (\args _ -> args) undefined + +-- |get rules body if it's not external +ruleBody :: Rule -> Expr +ruleBody = trRule (\_ e -> e) undefined + +-- |get rules external declaration +ruleExtDecl :: Rule -> String +ruleExtDecl = trRule undefined id + +-- Test Operations + +-- |is rule external? +isRuleExternal :: Rule -> Bool +isRuleExternal = trRule (\_ _ -> False) (\_ -> True) + +-- Update Operations + +-- |update rule +updRule :: ([VarIndex] -> [VarIndex]) -> + (Expr -> Expr) -> + (String -> String) -> Rule -> Rule +updRule fa fe fs = trRule rule ext + where + rule args e = Rule (fa args) (fe e) + ext s = External (fs s) + +-- |update rules arguments +updRuleArgs :: Update Rule [VarIndex] +updRuleArgs f = updRule f id id + +-- |update rules body +updRuleBody :: Update Rule Expr +updRuleBody f = updRule id f id + +-- |update rules external declaration +updRuleExtDecl :: Update Rule String +updRuleExtDecl f = updRule id id f + +-- Auxiliary Functions + +-- |get variable names in a functions rule +allVarsInRule :: Rule -> [VarIndex] +allVarsInRule = trRule (\args body -> args ++ allVars body) (\_ -> []) + +-- |rename all variables in rule +rnmAllVarsInRule :: Update Rule VarIndex +rnmAllVarsInRule f = updRule (map f) (rnmAllVars f) id + +-- |update all qualified names in rule +updQNamesInRule :: Update Rule QName +updQNamesInRule = updRuleBody . updQNames + +-- CombType ------------------------------------------------------------------ + +-- |transform combination type +trCombType :: a -> (Int -> a) -> a -> (Int -> a) -> CombType -> a +trCombType fc _ _ _ FuncCall = fc +trCombType _ fpc _ _ (FuncPartCall n) = fpc n +trCombType _ _ cc _ ConsCall = cc +trCombType _ _ _ cpc (ConsPartCall n) = cpc n + +-- Test Operations + +-- |is type of combination FuncCall? +isCombTypeFuncCall :: CombType -> Bool +isCombTypeFuncCall = trCombType True (\_ -> False) False (\_ -> False) + +-- |is type of combination FuncPartCall? +isCombTypeFuncPartCall :: CombType -> Bool +isCombTypeFuncPartCall = trCombType False (\_ -> True) False (\_ -> False) + +-- |is type of combination ConsCall? +isCombTypeConsCall :: CombType -> Bool +isCombTypeConsCall = trCombType False (\_ -> False) True (\_ -> False) + +-- |is type of combination ConsPartCall? +isCombTypeConsPartCall :: CombType -> Bool +isCombTypeConsPartCall = trCombType False (\_ -> False) False (\_ -> True) + +-- Expr ---------------------------------------------------------------------- + +-- Selectors + +-- |get internal number of variable +varNr :: Expr -> VarIndex +varNr (Var n) = n +varNr _ = error "Curry.FlatCurry.Goodies.varNr: no variable" + +-- |get literal if expression is literal expression +literal :: Expr -> Literal +literal (Lit l) = l +literal _ = error "Curry.FlatCurry.Goodies.literal: no literal" + +-- |get combination type of a combined expression +combType :: Expr -> CombType +combType (Comb ct _ _) = ct +combType _ = error $ "Curry.FlatCurry.Goodies.combType: " ++ + "no combined expression" + +-- |get name of a combined expression +combName :: Expr -> QName +combName (Comb _ name _) = name +combName _ = error $ "Curry.FlatCurry.Goodies.combName: " ++ + "no combined expression" + +-- |get arguments of a combined expression +combArgs :: Expr -> [Expr] +combArgs (Comb _ _ args) = args +combArgs _ = error $ "Curry.FlatCurry.Goodies.combArgs: " ++ + "no combined expression" + +-- |get number of missing arguments if expression is combined +missingCombArgs :: Expr -> Int +missingCombArgs = missingArgs . combType + where + missingArgs :: CombType -> Int + missingArgs = trCombType 0 id 0 id + +-- |get indices of varoables in let declaration +letBinds :: Expr -> [(VarIndex,Expr)] +letBinds (Let vs _) = vs +letBinds _ = error $ "Curry.FlatCurry.Goodies.letBinds: " ++ + "no let expression" + +-- |get body of let declaration +letBody :: Expr -> Expr +letBody (Let _ e) = e +letBody _ = error $ "Curry.FlatCurry.Goodies.letBody: " ++ + "no let expression" + +-- |get variable indices from declaration of free variables +freeVars :: Expr -> [VarIndex] +freeVars (Free vs _) = vs +freeVars _ = error $ "Curry.FlatCurry.Goodies.freeVars: " ++ + "no declaration of free variables" + +-- |get expression from declaration of free variables +freeExpr :: Expr -> Expr +freeExpr (Free _ e) = e +freeExpr _ = error $ "Curry.FlatCurry.Goodies.freeExpr: " ++ + "no declaration of free variables" + +-- |get expressions from or-expression +orExps :: Expr -> [Expr] +orExps (Or e1 e2) = [e1,e2] +orExps _ = error $ "Curry.FlatCurry.Goodies.orExps: " ++ + "no or expression" + +-- |get case-type of case expression +caseType :: Expr -> CaseType +caseType (Case ct _ _) = ct +caseType _ = error $ "Curry.FlatCurry.Goodies.caseType: " ++ + "no case expression" + +-- |get scrutinee of case expression +caseExpr :: Expr -> Expr +caseExpr (Case _ e _) = e +caseExpr _ = error $ "Curry.FlatCurry.Goodies.caseExpr: " ++ + "no case expression" + + +-- |get branch expressions from case expression +caseBranches :: Expr -> [BranchExpr] +caseBranches (Case _ _ bs) = bs +caseBranches _ = error + "Curry.FlatCurry.Goodies.caseBranches: no case expression" + +-- Test Operations + +-- |is expression a variable? +isVar :: Expr -> Bool +isVar e = case e of + Var _ -> True + _ -> False + +-- |is expression a literal expression? +isLit :: Expr -> Bool +isLit e = case e of + Lit _ -> True + _ -> False + +-- |is expression combined? +isComb :: Expr -> Bool +isComb e = case e of + Comb _ _ _ -> True + _ -> False + +-- |is expression a let expression? +isLet :: Expr -> Bool +isLet e = case e of + Let _ _ -> True + _ -> False + +-- |is expression a declaration of free variables? +isFree :: Expr -> Bool +isFree e = case e of + Free _ _ -> True + _ -> False + +-- |is expression an or-expression? +isOr :: Expr -> Bool +isOr e = case e of + Or _ _ -> True + _ -> False + +-- |is expression a case expression? +isCase :: Expr -> Bool +isCase e = case e of + Case _ _ _ -> True + _ -> False + +-- |transform expression +trExpr :: (VarIndex -> a) + -> (Literal -> a) + -> (CombType -> QName -> [a] -> a) + -> ([(VarIndex, a)] -> a -> a) + -> ([VarIndex] -> a -> a) + -> (a -> a -> a) + -> (CaseType -> a -> [b] -> a) + -> (Pattern -> a -> b) + -> (a -> TypeExpr -> a) + -> Expr + -> a +trExpr var lit comb lt fr oR cas branch typed expr = case expr of + Var n -> var n + Lit l -> lit l + Comb ct name args -> comb ct name (map f args) + Let bs e -> lt (map (\(v, x) -> (v, f x)) bs) (f e) + Free vs e -> fr vs (f e) + Or e1 e2 -> oR (f e1) (f e2) + Case ct e bs -> cas ct (f e) (map (\ (Branch p e') -> branch p (f e')) bs) + Typed e ty -> typed (f e) ty + where + f = trExpr var lit comb lt fr oR cas branch typed + +-- Update Operations + +-- |update all variables in given expression +updVars :: (VarIndex -> Expr) -> Expr -> Expr +updVars var = trExpr var Lit Comb Let Free Or Case Branch Typed + +-- |update all literals in given expression +updLiterals :: (Literal -> Expr) -> Expr -> Expr +updLiterals lit = trExpr Var lit Comb Let Free Or Case Branch Typed + +-- |update all combined expressions in given expression +updCombs :: (CombType -> QName -> [Expr] -> Expr) -> Expr -> Expr +updCombs comb = trExpr Var Lit comb Let Free Or Case Branch Typed + +-- |update all let expressions in given expression +updLets :: ([(VarIndex,Expr)] -> Expr -> Expr) -> Expr -> Expr +updLets lt = trExpr Var Lit Comb lt Free Or Case Branch Typed + +-- |update all free declarations in given expression +updFrees :: ([VarIndex] -> Expr -> Expr) -> Expr -> Expr +updFrees fr = trExpr Var Lit Comb Let fr Or Case Branch Typed + +-- |update all or expressions in given expression +updOrs :: (Expr -> Expr -> Expr) -> Expr -> Expr +updOrs oR = trExpr Var Lit Comb Let Free oR Case Branch Typed + +-- |update all case expressions in given expression +updCases :: (CaseType -> Expr -> [BranchExpr] -> Expr) -> Expr -> Expr +updCases cas = trExpr Var Lit Comb Let Free Or cas Branch Typed + +-- |update all case branches in given expression +updBranches :: (Pattern -> Expr -> BranchExpr) -> Expr -> Expr +updBranches branch = trExpr Var Lit Comb Let Free Or Case branch Typed + +-- |update all typed expressions in given expression +updTypeds :: (Expr -> TypeExpr -> Expr) -> Expr -> Expr +updTypeds = trExpr Var Lit Comb Let Free Or Case Branch + +-- Auxiliary Functions + +-- |is expression a call of a function where all arguments are provided? +isFuncCall :: Expr -> Bool +isFuncCall e = isComb e && isCombTypeFuncCall (combType e) + +-- |is expression a partial function call? +isFuncPartCall :: Expr -> Bool +isFuncPartCall e = isComb e && isCombTypeFuncPartCall (combType e) + +-- |is expression a call of a constructor? +isConsCall :: Expr -> Bool +isConsCall e = isComb e && isCombTypeConsCall (combType e) + +-- |is expression a partial constructor call? +isConsPartCall :: Expr -> Bool +isConsPartCall e = isComb e && isCombTypeConsPartCall (combType e) + +-- |is expression fully evaluated? +isGround :: Expr -> Bool +isGround e + = case e of + Comb ConsCall _ args -> all isGround args + _ -> isLit e + +-- |get all variables (also pattern variables) in expression +allVars :: Expr -> [VarIndex] +allVars e = trExpr (:) (const id) comb lt fr (.) cas branch const e [] + where + comb _ _ = foldr (.) id + lt bs e' = e' . foldr (.) id (map (\ (n,ns) -> (n:) . ns) bs) + fr vs e' = (vs++) . e' + cas _ e' bs = e' . foldr (.) id bs + branch pat e' = ((args pat)++) . e' + args pat | isConsPattern pat = patArgs pat + | otherwise = [] + +-- |rename all variables (also in patterns) in expression +rnmAllVars :: Update Expr VarIndex +rnmAllVars f = trExpr (Var . f) Lit Comb lt (Free . map f) Or Case branch Typed + where + lt = Let . map (\ (n,e) -> (f n,e)) + branch = Branch . updPatArgs (map f) + +-- |update all qualified names in expression +updQNames :: Update Expr QName +updQNames f = trExpr Var Lit comb Let Free Or Case (Branch . updPatCons f) Typed + where + comb ct name args = Comb ct (f name) args + +-- BranchExpr ---------------------------------------------------------------- + +-- |transform branch expression +trBranch :: (Pattern -> Expr -> a) -> BranchExpr -> a +trBranch branch (Branch pat e) = branch pat e + +-- Selectors + +-- |get pattern from branch expression +branchPattern :: BranchExpr -> Pattern +branchPattern = trBranch (\pat _ -> pat) + +-- |get expression from branch expression +branchExpr :: BranchExpr -> Expr +branchExpr = trBranch (\_ e -> e) + +-- Update Operations + +-- |update branch expression +updBranch :: (Pattern -> Pattern) -> (Expr -> Expr) -> BranchExpr -> BranchExpr +updBranch fp fe = trBranch branch + where + branch pat e = Branch (fp pat) (fe e) + +-- |update pattern of branch expression +updBranchPattern :: Update BranchExpr Pattern +updBranchPattern f = updBranch f id + +-- |update expression of branch expression +updBranchExpr :: Update BranchExpr Expr +updBranchExpr = updBranch id + +-- Pattern ------------------------------------------------------------------- + +-- |transform pattern +trPattern :: (QName -> [VarIndex] -> a) -> (Literal -> a) -> Pattern -> a +trPattern pattern _ (Pattern name args) = pattern name args +trPattern _ lpattern (LPattern l) = lpattern l + +-- Selectors + +-- |get name from constructor pattern +patCons :: Pattern -> QName +patCons = trPattern (\name _ -> name) undefined + +-- |get arguments from constructor pattern +patArgs :: Pattern -> [VarIndex] +patArgs = trPattern (\_ args -> args) undefined + +-- |get literal from literal pattern +patLiteral :: Pattern -> Literal +patLiteral = trPattern undefined id + +-- Test Operations + +-- |is pattern a constructor pattern? +isConsPattern :: Pattern -> Bool +isConsPattern = trPattern (\_ _ -> True) (\_ -> False) + +-- Update Operations + +-- |update pattern +updPattern :: (QName -> QName) -> + ([VarIndex] -> [VarIndex]) -> + (Literal -> Literal) -> Pattern -> Pattern +updPattern fn fa fl = trPattern pattern lpattern + where + pattern name args = Pattern (fn name) (fa args) + lpattern l = LPattern (fl l) + +-- |update constructors name of pattern +updPatCons :: (QName -> QName) -> Pattern -> Pattern +updPatCons f = updPattern f id id + +-- |update arguments of constructor pattern +updPatArgs :: ([VarIndex] -> [VarIndex]) -> Pattern -> Pattern +updPatArgs f = updPattern id f id + +-- |update literal of pattern +updPatLiteral :: (Literal -> Literal) -> Pattern -> Pattern +updPatLiteral f = updPattern id id f + +-- Auxiliary Functions + +-- |build expression from pattern +patExpr :: Pattern -> Expr +patExpr = trPattern (\ name -> Comb ConsCall name . map Var) Lit + +-- |Is this a public 'Visibility'? +isPublic :: Visibility -> Bool +isPublic = (== Public) diff --git a/src/Curry/FlatCurry/InterfaceEquivalence.hs b/src/Curry/FlatCurry/InterfaceEquivalence.hs new file mode 100644 index 0000000000000000000000000000000000000000..c876b4512fe895816d673a9fb746d3989b622edc --- /dev/null +++ b/src/Curry/FlatCurry/InterfaceEquivalence.hs @@ -0,0 +1,58 @@ +{- | + Module : $Header$ + Description : Check the equality of two FlatCurry interfaces + Copyright : (c) 2006 , Martin Engelke + 2011 - 2014, Björn Peemöller + 2014 , Jan Tikovsky + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable +-} + +module Curry.FlatCurry.InterfaceEquivalence (eqInterface) where + +import Data.List (deleteFirstsBy) + +import Curry.FlatCurry.Type + +infix 4 =~=, `eqvSet` + +-- |Check whether the interfaces of two FlatCurry programs are equivalent. +eqInterface :: Prog -> Prog -> Bool +eqInterface = (=~=) + +-- |Type class to express the equivalence of two values +class Equiv a where + (=~=) :: a -> a -> Bool + +instance Equiv a => Equiv [a] where + [] =~= [] = True + (x:xs) =~= (y:ys) = x =~= y && xs =~= ys + _ =~= _ = False + +instance Equiv Char where (=~=) = (==) + +-- |Equivalence of lists independent of the order. +eqvSet :: Equiv a => [a] -> [a] -> Bool +xs `eqvSet` ys = null (deleteFirstsBy (=~=) xs ys ++ deleteFirstsBy (=~=) ys xs) + +instance Equiv Prog where + Prog m1 is1 ts1 fs1 os1 =~= Prog m2 is2 ts2 fs2 os2 + = m1 == m2 && is1 `eqvSet` is2 && ts1 `eqvSet` ts2 + && fs1 `eqvSet` fs2 && os1 `eqvSet` os2 + +instance Equiv TypeDecl where (=~=) = (==) + +instance Equiv FuncDecl where + Func qn1 ar1 vis1 ty1 r1 =~= Func qn2 ar2 vis2 ty2 r2 + = qn1 == qn2 && ar1 == ar2 && vis1 == vis2 && ty1 == ty2 && r1 =~= r2 + +-- TODO: Check why arguments of rules are not checked for equivalence +instance Equiv Rule where + Rule _ _ =~= Rule _ _ = True + External _ =~= External _ = True + _ =~= _ = False + +instance Equiv OpDecl where (=~=) = (==) diff --git a/src/Curry/FlatCurry/Pretty.hs b/src/Curry/FlatCurry/Pretty.hs new file mode 100644 index 0000000000000000000000000000000000000000..acd0b20a8272a01a08f92bd65a43c3f49e1d2714 --- /dev/null +++ b/src/Curry/FlatCurry/Pretty.hs @@ -0,0 +1,217 @@ +{- | + Module : $Header$ + Description : A pretty printer for FlatCurry + Copyright : (c) 2015 Björn Peemöller + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This module implements a pretty printer for FlatCurry modules. +-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Curry.FlatCurry.Pretty (pPrint, pPrintPrec) where + +import Prelude hiding ((<>)) +import Data.Char (ord) + +import Curry.Base.Pretty +import Curry.FlatCurry.Type + +instance Pretty Prog where + pPrint (Prog m is ts fs os) = sepByBlankLine + [ ppHeader m ts fs + , vcat (map ppImport is) + , vcat (map pPrint os) + , sepByBlankLine (map pPrint ts) + , sepByBlankLine (map pPrint fs) + ] + +ppHeader :: String -> [TypeDecl] -> [FuncDecl] -> Doc +ppHeader m ts fs = sep + [text "module" <+> text m, ppExports ts fs, text "where"] + +-- |pretty-print the export list +ppExports :: [TypeDecl] -> [FuncDecl] -> Doc +ppExports ts fs = parens $ list (map ppTypeExport ts ++ ppFuncExports fs) + +ppTypeExport :: TypeDecl -> Doc +ppTypeExport (Type qn vis _ cs) + | vis == Private = empty + | all isPublicCons cs = ppPrefixOp qn <+> text "(..)" + | otherwise = ppPrefixOp qn <+> parens (list (ppConsExports cs)) + where isPublicCons (Cons _ _ v _) = v == Public +ppTypeExport (TypeNew qn vis _ nc) + | vis == Private = empty + | isPublicCons nc = ppPrefixOp qn <+> text "(..)" + | otherwise = ppPrefixOp qn <+> parens empty + where isPublicCons (NewCons _ v _) = v == Public +ppTypeExport (TypeSyn qn vis _ _ ) + | vis == Private = empty + | otherwise = ppPrefixOp qn + +-- |pretty-print the export list of constructors +ppConsExports :: [ConsDecl] -> [Doc] +ppConsExports cs = [ ppPrefixOp qn | Cons qn _ Public _ <- cs] + +-- |pretty-print the export list of functions +ppFuncExports :: [FuncDecl] -> [Doc] +ppFuncExports fs = [ ppPrefixOp qn | Func qn _ Public _ _ <- fs] + +-- |pretty-print an import statement +ppImport :: String -> Doc +ppImport m = text "import" <+> text m + +instance Pretty OpDecl where + pPrint(Op qn fix n) = pPrint fix <+> integer n <+> ppInfixOp qn + +instance Pretty Fixity where + pPrint InfixOp = text "infix" + pPrint InfixlOp = text "infixl" + pPrint InfixrOp = text "infixr" + +instance Pretty TypeDecl where + pPrint (Type qn _ vs cs) = text "data" <+> ppQName qn + <+> hsep (ppTVarIndex <$> fst <$> vs) $+$ ppConsDecls cs + pPrint (TypeSyn qn _ vs ty) = text "type" <+> ppQName qn + <+> hsep (ppTVarIndex <$> fst <$> vs) <+> equals <+> pPrintPrec 0 ty + pPrint (TypeNew qn _ vs nc) = text "newtype" <+> ppQName qn + <+> hsep (ppTVarIndex <$> fst <$> vs) <+> equals <+> pPrint nc + +-- |pretty-print the constructor declarations +ppConsDecls :: [ConsDecl] -> Doc +ppConsDecls cs = indent $ vcat $ + zipWith (<+>) (equals : repeat (char '|')) (map pPrint cs) + +instance Pretty ConsDecl where + pPrint (Cons qn _ _ tys) = fsep $ ppPrefixOp qn : map (pPrintPrec 2) tys + +instance Pretty NewConsDecl where + pPrint (NewCons qn _ ty) = fsep [pPrint qn, pPrintPrec 2 ty] + +instance Pretty TypeExpr where + pPrintPrec _ (TVar i) = ppTVarIndex i + pPrintPrec p (FuncType ty1 ty2) = parenIf (p > 0) $ fsep + [pPrintPrec 1 ty1, rarrow, pPrintPrec 0 ty2] + pPrintPrec p (TCons qn tys) = parenIf (p > 1 && not (null tys)) $ fsep + (ppPrefixOp qn : map (pPrintPrec 2) tys) + pPrintPrec p (ForallType vs ty) + | null vs = pPrintPrec p ty + | otherwise = parenIf (p > 0) $ ppQuantifiedVars vs <+> pPrintPrec 0 ty + +-- |pretty-print explicitly quantified type variables (without kinds) +ppQuantifiedVars :: [(TVarIndex, Kind)] -> Doc +ppQuantifiedVars vs + | null vs = empty + | otherwise = text "forall" <+> hsep (map ppTVar vs) <> char '.' + +ppTVar :: (TVarIndex, Kind) -> Doc +ppTVar (i, _) = ppTVarIndex i + +-- |pretty-print a type variable +ppTVarIndex :: TVarIndex -> Doc +ppTVarIndex i = text $ vars !! i + where vars = [ if n == 0 then [c] else c : show n + | n <- [0 :: Int ..], c <- ['a' .. 'z'] + ] + +instance Pretty FuncDecl where + pPrint (Func qn _ _ ty r) + = hsep [ppPrefixOp qn, text "::", pPrintPrec 0 ty] + $+$ ppPrefixOp qn <+> pPrint r + +instance Pretty Rule where + pPrint (Rule vs e) = + fsep (map ppVarIndex vs) <+> equals <+> indent (pPrintPrec 0 e) + pPrint (External _) = text "external" + +instance Pretty Expr where + pPrintPrec _ (Var v) = ppVarIndex v + pPrintPrec _ (Lit l) = pPrint l + pPrintPrec p (Comb _ qn es) = ppComb p qn es + pPrintPrec p (Free vs e) + | null vs = pPrintPrec p e + | otherwise = parenIf (p > 0) $ sep + [ text "let" <+> list (map ppVarIndex vs) + <+> text "free" + , text "in" <+> pPrintPrec 0 e + ] + pPrintPrec p (Let ds e) = parenIf (p > 0) $ + sep [text "let" <+> ppDecls ds, text "in" <+> pPrintPrec 0 e] + pPrintPrec p (Or e1 e2) = parenIf (p > 0) $ + pPrintPrec 1 e1 <+> text "?" <+> pPrintPrec 1 e2 + pPrintPrec p (Case ct e bs) = parenIf (p > 0) $ + pPrint ct <+> pPrintPrec 0 e <+> text "of" $$ indent (vcat (map pPrint bs)) + pPrintPrec p (Typed e ty) = parenIf (p > 0) $ + pPrintPrec 0 e <+> text "::" <+> pPrintPrec 0 ty + +-- |pretty-print a variable +ppVarIndex :: VarIndex -> Doc +ppVarIndex i = text $ 'v' : show i + +instance Pretty Literal where + pPrint (Intc i) = integer i + pPrint (Floatc f) = double f + pPrint (Charc c) = text (showEscape c) + +-- |Escape character literal +showEscape :: Char -> String +showEscape c + | o < 10 = "'\\00" ++ show o ++ "'" + | o < 32 = "'\\0" ++ show o ++ "'" + | o == 127 = "'\\127'" + | otherwise = show c + where o = ord c + +-- |Pretty print a constructor or function call +ppComb :: Int -> QName -> [Expr] -> Doc +ppComb _ qn [] = ppPrefixOp qn +ppComb p qn [e1,e2] + | isInfixOp qn = parenIf (p > 0) + $ hsep [pPrintPrec 1 e1, pPrint qn, pPrintPrec 1 e2] +ppComb p qn es = parenIf (p > 0) + $ hsep (ppPrefixOp qn : map (pPrintPrec 1) es) + +-- |pretty-print a list of declarations +ppDecls :: [(VarIndex, Expr)] -> Doc +ppDecls = vcat . map ppDecl + +-- |pretty-print a single declaration +ppDecl :: (VarIndex, Expr) -> Doc +ppDecl (v, e) = ppVarIndex v <+> equals <+> pPrintPrec 0 e + +instance Pretty CaseType where + pPrint Rigid = text "case" + pPrint Flex = text "fcase" + +instance Pretty BranchExpr where + pPrint (Branch p e) = pPrint p <+> rarrow <+> pPrintPrec 0 e + +instance Pretty Pattern where + pPrint (Pattern c [v1,v2]) + | isInfixOp c = ppVarIndex v1 <+> ppInfixOp c <+> ppVarIndex v2 + pPrint (Pattern c vs) = fsep (ppPrefixOp c : map ppVarIndex vs) + pPrint (LPattern l) = pPrint l + +-- Names + +-- |pretty-print a prefix operator +ppPrefixOp :: QName -> Doc +ppPrefixOp qn = parenIf (isInfixOp qn) (ppQName qn) + +-- |pretty-print a name in infix manner +ppInfixOp :: QName -> Doc +ppInfixOp qn = if isInfixOp qn then ppQName qn else bquotes (ppQName qn) + +-- |pretty-print a qualified name +ppQName :: QName -> Doc +ppQName (m, i) = text $ m ++ '.' : i + +-- |Check whether an operator is an infix operator +isInfixOp :: QName -> Bool +isInfixOp = all (`elem` "~!@#$%^&*+-=<>:?./|\\") . snd + +-- Indentation +indent :: Doc -> Doc +indent = nest 2 diff --git a/src/Curry/FlatCurry/Type.hs b/src/Curry/FlatCurry/Type.hs new file mode 100644 index 0000000000000000000000000000000000000000..8362bd4a811187502cf3ef5fa91ceb59146e4c2c --- /dev/null +++ b/src/Curry/FlatCurry/Type.hs @@ -0,0 +1,521 @@ +{- | + Module : $Header$ + Description : Representation of FlatCurry. + Copyright : (c) Michael Hanus 2003 + Martin Engelke 2004 + Bernd Brassel 2005 + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This module contains a definition for representing FlatCurry programs + in Haskell in type 'Prog'. +-} + +module Curry.FlatCurry.Type + ( -- * Representation of qualified names and (type) variables + QName, VarIndex, TVarIndex, TVarWithKind + -- * Data types for FlatCurry + , Visibility (..), Prog (..), TypeDecl (..), TypeExpr (..), Kind (..) + , ConsDecl (..), NewConsDecl(..), OpDecl (..), Fixity (..) + , FuncDecl (..), Rule (..), Expr (..), Literal (..) + , CombType (..), CaseType (..), BranchExpr (..), Pattern (..) + ) where + +import Data.Binary +import Control.Monad + +-- --------------------------------------------------------------------------- +-- Qualified names +-- --------------------------------------------------------------------------- + +-- |Qualified names. +-- +-- In FlatCurry all names are qualified to avoid name clashes. +-- The first component is the module name and the second component the +-- unqualified name as it occurs in the source program. +type QName = (String, String) + +-- --------------------------------------------------------------------------- +-- Variable representation +-- --------------------------------------------------------------------------- + +-- |Representation of variables. +type VarIndex = Int + +-- --------------------------------------------------------------------------- +-- FlatCurry representation +-- --------------------------------------------------------------------------- + +-- |Visibility of various entities. +data Visibility + = Public -- ^ public (exported) entity + | Private -- ^ private entity + deriving (Eq, Read, Show) + +-- |A FlatCurry module. +-- +-- A value of this data type has the form +-- +-- @Prog modname imports typedecls functions opdecls@ +-- +-- where +-- +-- [@modname@] Name of this module +-- [@imports@] List of modules names that are imported +-- [@typedecls@] Type declarations +-- [@funcdecls@] Function declarations +-- [@ opdecls@] Operator declarations +data Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl] + deriving (Eq, Read, Show) + +-- |Declaration of algebraic data type or type synonym. +-- +-- A data type declaration of the form +-- +-- @data t x1...xn = ...| c t1....tkc |...@ +-- +-- is represented by the FlatCurry term +-- +-- @Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...]@ +-- +-- where each @ij@ is the index of the type variable @xj@ +-- +-- /Note:/ The type variable indices are unique inside each type declaration +-- and are usually numbered from 0. +-- +-- Thus, a data type declaration consists of the name of the data type, +-- a list of type parameters and a list of constructor declarations. +data TypeDecl + = Type QName Visibility [TVarWithKind] [ConsDecl] + | TypeSyn QName Visibility [TVarWithKind] TypeExpr + | TypeNew QName Visibility [TVarWithKind] NewConsDecl + deriving (Eq, Read, Show) + +-- |Type variables are represented by @(TVar i)@ where @i@ is a +-- type variable index. +type TVarIndex = Int + +-- |Kinded type variables are represented by a tuple of type variable +-- index and kind. +type TVarWithKind = (TVarIndex, Kind) + +-- |A constructor declaration consists of the name and arity of the +-- constructor and a list of the argument types of the constructor. +data ConsDecl = Cons QName Int Visibility [TypeExpr] + deriving (Eq, Read, Show) + +-- |A constructor declaration for a newtype consists +-- of the name of the constructor +-- and the argument type of the constructor. +data NewConsDecl = NewCons QName Visibility TypeExpr + deriving (Eq, Read, Show) + +-- |Type expressions. +-- +-- A type expression is either a type variable, a function type, +-- or a type constructor application. +-- +-- /Note:/ the names of the predefined type constructors are +-- @Int@, @Float@, @Bool@, @Char@, @IO@, @Success@, +-- @()@ (unit type), @(,...,)@ (tuple types), @[]@ (list type) +data TypeExpr + = TVar TVarIndex -- ^ type variable + | FuncType TypeExpr TypeExpr -- ^ function type @t1 -> t2@ + | TCons QName [TypeExpr] -- ^ type constructor application + | ForallType [TVarWithKind] TypeExpr -- ^ forall type + deriving (Eq, Read, Show) + +-- |Kinds. +-- +-- A kind is either * or k_1 -> k_2 where k_1 and k_2 are kinds. +data Kind + = KStar -- ^ star kind + | KArrow Kind Kind -- ^ arrow kind + deriving (Eq, Ord, Read, Show) + +-- |Operator declarations. +-- +-- An operator declaration @fix p n@ in Curry corresponds to the +-- FlatCurry term @(Op n fix p)@. +-- +-- /Note:/ the constructor definition of 'Op' differs from the original +-- PAKCS definition using Haskell type 'Integer' instead of 'Int' +-- for representing the precedence. +data OpDecl = Op QName Fixity Integer + deriving (Eq, Read, Show) + +-- |Fixity of an operator. +data Fixity + = InfixOp -- ^ non-associative infix operator + | InfixlOp -- ^ left-associative infix operator + | InfixrOp -- ^ right-associative infix operator + deriving (Eq, Read, Show) + +-- |Data type for representing function declarations. +-- +-- A function declaration in FlatCurry is a term of the form +-- +-- @(Func name arity type (Rule [i_1,...,i_arity] e))@ +-- +-- and represents the function "name" with definition +-- +-- @ +-- name :: type +-- name x_1...x_arity = e +-- @ +-- +-- where each @i_j@ is the index of the variable @x_j@ +-- +-- /Note:/ The variable indices are unique inside each function declaration +-- and are usually numbered from 0. +-- +-- External functions are represented as +-- +-- @Func name arity type (External s)@ +-- +-- where s is the external name associated to this function. +-- +-- Thus, a function declaration consists of the name, arity, type, and rule. +data FuncDecl = Func QName Int Visibility TypeExpr Rule + deriving (Eq, Read, Show) + +-- |A rule is either a list of formal parameters together with an expression +-- or an 'External' tag. +data Rule + = Rule [VarIndex] Expr + | External String + deriving (Eq, Read, Show) + +-- |Data type for representing expressions. +-- +-- Remarks: +-- +-- 1.if-then-else expressions are represented as function calls: +-- +-- @(if e1 then e2 else e3)@ +-- +-- is represented as +-- +-- @(Comb FuncCall ("Prelude","ifThenElse") [e1,e2,e3])@ +-- +-- 2.Higher order applications are represented as calls to the (external) +-- function @apply@. For instance, the rule +-- +-- @app f x = f x@ +-- +-- is represented as +-- +-- @(Rule [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1]))@ +-- +-- 3.A conditional rule is represented as a call to an external function +-- @cond@ where the first argument is the condition (a constraint). +-- +-- For instance, the rule +-- +-- @equal2 x | x=:=2 = success@ +-- +-- is represented as +-- +-- @ +-- (Rule [0] +-- (Comb FuncCall ("Prelude","cond") +-- [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)], +-- Comb FuncCall ("Prelude","success") []])) +-- @ +-- +-- 4.Functions with evaluation annotation @choice@ are represented +-- by a rule whose right-hand side is enclosed in a call to the +-- external function @Prelude.commit@. +-- Furthermore, all rules of the original definition must be +-- represented by conditional expressions (i.e., (cond [c,e])) +-- after pattern matching. +-- +-- Example: +-- +-- @ +-- m eval choice +-- m [] y = y +-- m x [] = x +-- @ +-- +-- is translated into (note that the conditional branches can be also +-- wrapped with Free declarations in general): +-- +-- @ +-- Rule [0,1] +-- (Comb FuncCall ("Prelude","commit") +-- [Or (Case Rigid (Var 0) +-- [(Pattern ("Prelude","[]") [] +-- (Comb FuncCall ("Prelude","cond") +-- [Comb FuncCall ("Prelude","success") [], +-- Var 1]))] ) +-- (Case Rigid (Var 1) +-- [(Pattern ("Prelude","[]") [] +-- (Comb FuncCall ("Prelude","cond") +-- [Comb FuncCall ("Prelude","success") [], +-- Var 0]))] )]) +-- @ +-- +-- Operational meaning of @(Prelude.commit e)@: +-- evaluate @e@ with local search spaces and commit to the first +-- @(Comb FuncCall ("Prelude","cond") [c,ge])@ in @e@ whose constraint @c@ +-- is satisfied +data Expr + -- |Variable, represented by unique index + = Var VarIndex + -- |Literal (Integer/Float/Char constant) + | Lit Literal + -- |Application @(f e1 ... en)@ of function/constructor @f@ + -- with @n <= arity f@ + | Comb CombType QName [Expr] + -- |Introduction of free local variables for an expression + | Free [VarIndex] Expr + -- |Local let-declarations + | Let [(VarIndex, Expr)] Expr + -- |Disjunction of two expressions + -- (resulting from overlapping left-hand sides) + | Or Expr Expr + -- |case expression + | Case CaseType Expr [BranchExpr] + -- |typed expression + | Typed Expr TypeExpr + deriving (Eq, Read, Show) + +-- |Data type for representing literals. +-- +-- A literal is either an integer, a float, or a character constant. +-- +-- /Note:/ The constructor definition of 'Intc' differs from the original +-- PAKCS definition. It uses Haskell type 'Integer' instead of 'Int' +-- to provide an unlimited range of integer numbers. Furthermore, +-- float values are represented with Haskell type 'Double' instead of +-- 'Float'. +data Literal + = Intc Integer + | Floatc Double + | Charc Char + deriving (Eq, Read, Show) + +-- |Data type for classifying combinations +-- (i.e., a function/constructor applied to some arguments). +data CombType + -- |a call to a function where all arguments are provided + = FuncCall + -- |a call with a constructor at the top, all arguments are provided + | ConsCall + -- |a partial call to a function (i.e., not all arguments are provided) + -- where the parameter is the number of missing arguments + | FuncPartCall Int + -- |a partial call to a constructor along with number of missing arguments + | ConsPartCall Int + deriving (Eq, Read, Show) + +-- |Classification of case expressions, either flexible or rigid. +data CaseType + = Rigid + | Flex + deriving (Eq, Read, Show) + +-- |Branches in a case expression. +-- +-- Branches @(m.c x1...xn) -> e@ in case expressions are represented as +-- +-- @(Branch (Pattern (m,c) [i1,...,in]) e)@ +-- +-- where each @ij@ is the index of the pattern variable @xj@, or as +-- +-- @(Branch (LPattern (Intc i)) e)@ +-- +-- for integers as branch patterns (similarly for other literals +-- like float or character constants). +data BranchExpr = Branch Pattern Expr + deriving (Eq, Read, Show) + +-- |Patterns in case expressions. +data Pattern + = Pattern QName [VarIndex] + | LPattern Literal + deriving (Eq, Read, Show) + +instance Binary Visibility where + put Public = putWord8 0 + put Private = putWord8 1 + + get = do + x <- getWord8 + case x of + 0 -> return Public + 1 -> return Private + _ -> fail "Invalid encoding for Visibility" + +instance Binary Prog where + put (Prog mid im tys fus ops) = + put mid >> put im >> put tys >> put fus >> put ops + get = Prog <$> get <*> get <*> get <*> get <*> get + +instance Binary TypeDecl where + put (Type qid vis vs cs) = + putWord8 0 >> put qid >> put vis >> put vs >> put cs + put (TypeSyn qid vis vs ty) = + putWord8 1 >> put qid >> put vis >> put vs >> put ty + put (TypeNew qid vis vs c ) = + putWord8 2 >> put qid >> put vis >> put vs >> put c + + get = do + x <- getWord8 + case x of + 0 -> liftM4 Type get get get get + 1 -> liftM4 TypeSyn get get get get + 2 -> liftM4 TypeNew get get get get + _ -> fail "Invalid encoding for TypeDecl" + +instance Binary ConsDecl where + put (Cons qid arity vis tys) = put qid >> put arity >> put vis >> put tys + get = Cons <$> get <*> get <*> get <*> get + +instance Binary NewConsDecl where + put (NewCons qid vis ty) = put qid >> put vis >> put ty + get = NewCons <$> get <*> get <*> get + +instance Binary TypeExpr where + put (TVar tv) = + putWord8 0 >> put tv + put (FuncType ty1 ty2) = + putWord8 1 >> put ty1 >> put ty2 + put (TCons qid tys) = + putWord8 2 >> put qid >> put tys + put (ForallType vs ty) = + putWord8 3 >> put vs >> put ty + + get = do + x <- getWord8 + case x of + 0 -> fmap TVar get + 1 -> liftM2 FuncType get get + 2 -> liftM2 TCons get get + 3 -> liftM2 ForallType get get + _ -> fail "Invalid encoding for TypeExpr" + +instance Binary Kind where + put KStar = putWord8 0 + put (KArrow k1 k2) = putWord8 1 >> put k1 >> put k2 + get = do + x <- getWord8 + case x of + 0 -> return KStar + 1 -> liftM2 KArrow get get + _ -> fail "Invalid encoding for Kind" + +instance Binary OpDecl where + put (Op qid fix pr) = put qid >> put fix >> put pr + get = liftM3 Op get get get + +instance Binary Fixity where + put InfixOp = putWord8 0 + put InfixlOp = putWord8 1 + put InfixrOp = putWord8 2 + + get = do + x <- getWord8 + case x of + 0 -> return InfixOp + 1 -> return InfixlOp + 2 -> return InfixrOp + _ -> fail "Invalid encoding for Fixity" + +instance Binary FuncDecl where + put (Func qid arity vis ty r) = + put qid >> put arity >> put vis >> put ty >> put r + get = Func <$> get <*> get <*> get <*> get <*> get + +instance Binary Rule where + put (Rule alts e) = putWord8 0 >> put alts >> put e + put (External n ) = putWord8 1 >> put n + + get = do + x <- getWord8 + case x of + 0 -> liftM2 Rule get get + 1 -> fmap External get + _ -> fail "Invalid encoding for TRule" + +instance Binary Expr where + put (Var v) = putWord8 0 >> put v + put (Lit l) = putWord8 1 >> put l + put (Comb cty qid es) = + putWord8 2 >> put cty >> put qid >> put es + put (Let bs e) = putWord8 3 >> put bs >> put e + put (Free vs e) = putWord8 4 >> put vs >> put e + put (Or e1 e2) = putWord8 5 >> put e1 >> put e2 + put (Case cty ty as) = putWord8 6 >> put cty >> put ty >> put as + put (Typed e ty) = putWord8 7 >> put e >> put ty + + get = do + x <- getWord8 + case x of + 0 -> fmap Var get + 1 -> fmap Lit get + 2 -> liftM3 Comb get get get + 3 -> liftM2 Let get get + 4 -> liftM2 Free get get + 5 -> liftM2 Or get get + 6 -> liftM3 Case get get get + 7 -> liftM2 Typed get get + _ -> fail "Invalid encoding for TExpr" + +instance Binary BranchExpr where + put (Branch p e) = put p >> put e + get = liftM2 Branch get get + +instance Binary Pattern where + put (Pattern qid vs) = putWord8 0 >> put qid >> put vs + put (LPattern l ) = putWord8 1 >> put l + + get = do + x <- getWord8 + case x of + 0 -> liftM2 Pattern get get + 1 -> fmap LPattern get + _ -> fail "Invalid encoding for TPattern" + +instance Binary Literal where + put (Intc i) = putWord8 0 >> put i + put (Floatc f) = putWord8 1 >> put f + put (Charc c) = putWord8 2 >> put c + + get = do + x <- getWord8 + case x of + 0 -> fmap Intc get + 1 -> fmap Floatc get + 2 -> fmap Charc get + _ -> fail "Invalid encoding for Literal" + +instance Binary CombType where + put FuncCall = putWord8 0 + put ConsCall = putWord8 1 + put (FuncPartCall i) = putWord8 2 >> put i + put (ConsPartCall i) = putWord8 3 >> put i + + get = do + x <- getWord8 + case x of + 0 -> return FuncCall + 1 -> return ConsCall + 2 -> fmap FuncPartCall get + 3 -> fmap ConsPartCall get + _ -> fail "Invalid encoding for CombType" + +instance Binary CaseType where + put Rigid = putWord8 0 + put Flex = putWord8 1 + + get = do + x <- getWord8 + case x of + 0 -> return Rigid + 1 -> return Flex + _ -> fail "Invalid encoding for CaseType" diff --git a/src/Curry/FlatCurry/Typeable.hs b/src/Curry/FlatCurry/Typeable.hs new file mode 100644 index 0000000000000000000000000000000000000000..2bc60a63ee01f9533e2cb9787c98aa48e1363e90 --- /dev/null +++ b/src/Curry/FlatCurry/Typeable.hs @@ -0,0 +1,22 @@ +{- | + Module : $Header$ + Description : Typeclass of Typeable entities + Copyright : (c) 2018 Kai-Oliver Prott + License : BSD-3-clause + + Maintainer : fte@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This module defines a Typeclass for easy access to the type of entites +-} + +module Curry.FlatCurry.Typeable (Typeable(..)) where + +import Curry.FlatCurry.Type (TypeExpr) + +class Typeable a where + typeOf :: a -> TypeExpr + +instance Typeable TypeExpr where + typeOf = id diff --git a/src/Curry/FlatCurry/Typed/Goodies.hs b/src/Curry/FlatCurry/Typed/Goodies.hs new file mode 100644 index 0000000000000000000000000000000000000000..2513430743489a2c5f60e5a2a938e47ab87f2844 --- /dev/null +++ b/src/Curry/FlatCurry/Typed/Goodies.hs @@ -0,0 +1,666 @@ +{- | + Module : $Header$ + Description : Utility functions for working with TypedFlatCurry. + Copyright : (c) 2016 - 2017 Finn Teegen + 2018 Kai-Oliver Prott + License : BSD-3-clause + + Maintainer : fte@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This library provides selector functions, test and update operations + as well as some useful auxiliary functions for TypedFlatCurry data terms. + Most of the provided functions are based on general transformation + functions that replace constructors with user-defined + functions. For recursive datatypes the transformations are defined + inductively over the term structure. This is quite usual for + transformations on TypedFlatCurry terms, + so the provided functions can be used to implement specific transformations + without having to explicitly state the recursion. Essentially, the tedious + part of such transformations - descend in fairly complex term structures - + is abstracted away, which hopefully makes the code more clear and brief. +-} + +module Curry.FlatCurry.Typed.Goodies + ( module Curry.FlatCurry.Typed.Goodies + , module Curry.FlatCurry.Goodies + ) where + +import Curry.FlatCurry.Goodies ( Update + , trType, typeName, typeVisibility, typeParams + , typeConsDecls, typeSyn, isTypeSyn + , isDataTypeDecl, isExternalType, isPublicType + , updType, updTypeName, updTypeVisibility + , updTypeParams, updTypeConsDecls, updTypeSynonym + , updQNamesInType + , trCons, consName, consArity, consVisibility + , isPublicCons, consArgs, updCons, updConsName + , updConsArity, updConsVisibility, updConsArgs + , updQNamesInConsDecl + , trNewCons, newConsName, newConsVisibility + , isPublicNewCons, newConsArg + , updNewCons, updNewConsName + , updNewConsVisibility, updNewConsArg + , updQNamesInNewConsDecl + , tVarIndex, domain, range, tConsName, tConsArgs + , trTypeExpr, isTVar, isTCons, isFuncType + , updTVars, updTCons, updFuncTypes, argTypes + , typeArity, resultType, allVarsInTypeExpr + , allTypeCons, rnmAllVarsInTypeExpr + , updQNamesInTypeExpr + , trOp, opName, opFixity, opPrecedence, updOp + , updOpName, updOpFixity, updOpPrecedence + , trCombType, isCombTypeFuncCall + , isCombTypeFuncPartCall, isCombTypeConsCall + , isCombTypeConsPartCall + , isPublic + ) + +import Curry.FlatCurry.Typed.Type + +-- TProg ---------------------------------------------------------------------- + +-- |transform program +trTProg :: (String -> [String] -> [TypeDecl] -> [TFuncDecl] -> [OpDecl] -> b) + -> TProg -> b +trTProg prog (TProg name imps types funcs ops) = prog name imps types funcs ops + +-- Selectors + +-- |get name from program +tProgName :: TProg -> String +tProgName = trTProg (\name _ _ _ _ -> name) + +-- |get imports from program +tProgImports :: TProg -> [String] +tProgImports = trTProg (\_ imps _ _ _ -> imps) + +-- |get type declarations from program +tProgTypes :: TProg -> [TypeDecl] +tProgTypes = trTProg (\_ _ types _ _ -> types) + +-- |get functions from program +tProgTFuncs :: TProg -> [TFuncDecl] +tProgTFuncs = trTProg (\_ _ _ funcs _ -> funcs) + +-- |get infix operators from program +tProgOps :: TProg -> [OpDecl] +tProgOps = trTProg (\_ _ _ _ ops -> ops) + +-- Update Operations + +-- |update program +updTProg :: (String -> String) -> + ([String] -> [String]) -> + ([TypeDecl] -> [TypeDecl]) -> + ([TFuncDecl] -> [TFuncDecl]) -> + ([OpDecl] -> [OpDecl]) -> TProg -> TProg +updTProg fn fi ft ff fo = trTProg prog + where + prog name imps types funcs ops + = TProg (fn name) (fi imps) (ft types) (ff funcs) (fo ops) + +-- |update name of program +updTProgName :: Update TProg String +updTProgName f = updTProg f id id id id + +-- |update imports of program +updTProgImports :: Update TProg [String] +updTProgImports f = updTProg id f id id id + +-- |update type declarations of program +updTProgTypes :: Update TProg [TypeDecl] +updTProgTypes f = updTProg id id f id id + +-- |update functions of program +updTProgTFuncs :: Update TProg [TFuncDecl] +updTProgTFuncs f = updTProg id id id f id + +-- |update infix operators of program +updTProgOps :: Update TProg [OpDecl] +updTProgOps = updTProg id id id id + +-- Auxiliary Functions + +-- |get all program variables (also from patterns) +allVarsInTProg :: TProg -> [(VarIndex, TypeExpr)] +allVarsInTProg = concatMap allVarsInTFunc . tProgTFuncs + +-- |lift transformation on expressions to program +updTProgTExps :: Update TProg TExpr +updTProgTExps = updTProgTFuncs . map . updTFuncBody + +-- |rename programs variables +rnmAllVarsInTProg :: Update TProg VarIndex +rnmAllVarsInTProg = updTProgTFuncs . map . rnmAllVarsInTFunc + +-- |update all qualified names in program +updQNamesInTProg :: Update TProg QName +updQNamesInTProg f = updTProg id id + (map (updQNamesInType f)) (map (updQNamesInTFunc f)) (map (updOpName f)) + +-- |rename program (update name of and all qualified names in program) +rnmTProg :: String -> TProg -> TProg +rnmTProg name p = updTProgName (const name) (updQNamesInTProg rnm p) + where + rnm (m, n) | m == tProgName p = (name, n) + | otherwise = (m, n) + +-- TFuncDecl ------------------------------------------------------------------ + +-- |transform function +trTFunc :: (QName -> Int -> Visibility -> TypeExpr -> TRule -> b) -> TFuncDecl -> b +trTFunc func (TFunc name arity vis t rule) = func name arity vis t rule + +-- Selectors + +-- |get name of function +tFuncName :: TFuncDecl -> QName +tFuncName = trTFunc (\name _ _ _ _ -> name) + +-- |get arity of function +tFuncArity :: TFuncDecl -> Int +tFuncArity = trTFunc (\_ arity _ _ _ -> arity) + +-- |get visibility of function +tFuncVisibility :: TFuncDecl -> Visibility +tFuncVisibility = trTFunc (\_ _ vis _ _ -> vis) + +-- |get type of function +tFuncType :: TFuncDecl -> TypeExpr +tFuncType = trTFunc (\_ _ _ t _ -> t) + +-- |get rule of function +tFuncTRule :: TFuncDecl -> TRule +tFuncTRule = trTFunc (\_ _ _ _ rule -> rule) + +-- Update Operations + +-- |update function +updTFunc :: (QName -> QName) -> + (Int -> Int) -> + (Visibility -> Visibility) -> + (TypeExpr -> TypeExpr) -> + (TRule -> TRule) -> TFuncDecl -> TFuncDecl +updTFunc fn fa fv ft fr = trTFunc func + where + func name arity vis t rule + = TFunc (fn name) (fa arity) (fv vis) (ft t) (fr rule) + +-- |update name of function +updTFuncName :: Update TFuncDecl QName +updTFuncName f = updTFunc f id id id id + +-- |update arity of function +updTFuncArity :: Update TFuncDecl Int +updTFuncArity f = updTFunc id f id id id + +-- |update visibility of function +updTFuncVisibility :: Update TFuncDecl Visibility +updTFuncVisibility f = updTFunc id id f id id + +-- |update type of function +updFuncType :: Update TFuncDecl TypeExpr +updFuncType f = updTFunc id id id f id + +-- |update rule of function +updTFuncTRule :: Update TFuncDecl TRule +updTFuncTRule = updTFunc id id id id + +-- Auxiliary Functions + +-- |is function public? +isPublicTFunc :: TFuncDecl -> Bool +isPublicTFunc = isPublic . tFuncVisibility + +-- |is function externally defined? +isExternal :: TFuncDecl -> Bool +isExternal = isTRuleExternal . tFuncTRule + +-- |get variable names in a function declaration +allVarsInTFunc :: TFuncDecl -> [(VarIndex, TypeExpr)] +allVarsInTFunc = allVarsInTRule . tFuncTRule + +-- |get arguments of function, if not externally defined +tFuncArgs :: TFuncDecl -> [(VarIndex, TypeExpr)] +tFuncArgs = tRuleArgs . tFuncTRule + +-- |get body of function, if not externally defined +tFuncBody :: TFuncDecl -> TExpr +tFuncBody = tRuleBody . tFuncTRule + +-- |get the right-hand-sides of a 'FuncDecl' +tFuncRHS :: TFuncDecl -> [TExpr] +tFuncRHS f | not (isExternal f) = orCase (tFuncBody f) + | otherwise = [] + where + orCase e + | isTOr e = concatMap orCase (orExps e) + | isTCase e = concatMap (orCase . tBranchTExpr) (caseBranches e) + | otherwise = [e] + +-- |rename all variables in function +rnmAllVarsInTFunc :: Update TFuncDecl VarIndex +rnmAllVarsInTFunc = updTFunc id id id id . rnmAllVarsInTRule + +-- |update all qualified names in function +updQNamesInTFunc :: Update TFuncDecl QName +updQNamesInTFunc f = updTFunc f id id (updQNamesInTypeExpr f) (updQNamesInTRule f) + +-- |update arguments of function, if not externally defined +updTFuncArgs :: Update TFuncDecl [(VarIndex, TypeExpr)] +updTFuncArgs = updTFuncTRule . updTRuleArgs + +-- |update body of function, if not externally defined +updTFuncBody :: Update TFuncDecl TExpr +updTFuncBody = updTFuncTRule . updTRuleBody + +-- TRule ---------------------------------------------------------------------- + +-- |transform rule +trTRule :: ([(VarIndex, TypeExpr)] -> TExpr -> b) -> (TypeExpr -> String -> b) -> TRule -> b +trTRule rule _ (TRule args e) = rule args e +trTRule _ ext (TExternal ty s) = ext ty s + +-- Selectors + +-- |get rules arguments if it's not external +tRuleArgs :: TRule -> [(VarIndex, TypeExpr)] +tRuleArgs = trTRule const undefined + +-- |get rules body if it's not external +tRuleBody :: TRule -> TExpr +tRuleBody = trTRule (\_ e -> e) undefined + +-- |get rules external declaration +tRuleExtDecl :: TRule -> String +tRuleExtDecl = trTRule undefined (\_ s -> s) + +-- Test Operations + +-- |is rule external? +isTRuleExternal :: TRule -> Bool +isTRuleExternal = trTRule (\_ _ -> False) (\_ _ -> True) + +-- Update Operations + +-- |update rule +updTRule :: (TypeExpr -> TypeExpr) -> + ([(VarIndex, TypeExpr)] -> [(VarIndex, TypeExpr)]) -> + (TExpr -> TExpr) -> + (String -> String) -> TRule -> TRule +updTRule fannot fa fe fs = trTRule rule ext + where + rule args e = TRule (fa args) (fe e) + ext ty s = TExternal (fannot ty) (fs s) + +-- |update rules TypeExpr +updTRuleType :: Update TRule TypeExpr +updTRuleType f = updTRule f id id id + +-- |update rules arguments +updTRuleArgs :: Update TRule [(VarIndex, TypeExpr)] +updTRuleArgs f = updTRule id f id id + +-- |update rules body +updTRuleBody :: Update TRule TExpr +updTRuleBody f = updTRule id id f id + +-- |update rules external declaration +updTRuleExtDecl :: Update TRule String +updTRuleExtDecl = updTRule id id id + +-- Auxiliary Functions + +-- |get variable names in a functions rule +allVarsInTRule :: TRule -> [(VarIndex, TypeExpr)] +allVarsInTRule = trTRule (\args body -> args ++ allVars body) (\_ _ -> []) + +-- |rename all variables in rule +rnmAllVarsInTRule :: Update TRule VarIndex +rnmAllVarsInTRule f = updTRule id (map (\(a, b) -> (f a, b))) (rnmAllVars f) id + +-- |update all qualified names in rule +updQNamesInTRule :: Update TRule QName +updQNamesInTRule = updTRuleBody . updQNames + +-- TExpr ---------------------------------------------------------------------- + +-- Selectors + +-- |get internal number of variable +varNr :: TExpr -> VarIndex +varNr (TVarE _ n) = n +varNr _ = error "Curry.FlatCurry.Typed.Goodies.varNr: no variable" + +-- |get literal if expression is literal expression +literal :: TExpr -> Literal +literal (TLit _ l) = l +literal _ = error "Curry.FlatCurry.Typed.Goodies.literal: no literal" + +-- |get combination type of a combined expression +combType :: TExpr -> CombType +combType (TComb _ ct _ _) = ct +combType _ = error $ "Curry.FlatCurry.Typed.Goodies.combType: " ++ + "no combined expression" + +-- |get name of a combined expression +combName :: TExpr -> QName +combName (TComb _ _ name _) = name +combName _ = error $ "Curry.FlatCurry.Typed.Goodies.combName: " ++ + "no combined expression" + +-- |get arguments of a combined expression +combArgs :: TExpr -> [TExpr] +combArgs (TComb _ _ _ args) = args +combArgs _ = error $ "Curry.FlatCurry.Typed.Goodies.combArgs: " ++ + "no combined expression" + +-- |get number of missing arguments if expression is combined +missingCombArgs :: TExpr -> Int +missingCombArgs = missingArgs . combType + where + missingArgs :: CombType -> Int + missingArgs = trCombType 0 id 0 id + +-- |get indices of variables in let declaration +letBinds :: TExpr -> [((VarIndex, TypeExpr), TExpr)] +letBinds (TLet vs _) = vs +letBinds _ = error $ "Curry.FlatCurry.Typed.Goodies.letBinds: " ++ + "no let expression" + +-- |get body of let declaration +letBody :: TExpr -> TExpr +letBody (TLet _ e) = e +letBody _ = error $ "Curry.FlatCurry.Typed.Goodies.letBody: " ++ + "no let expression" + +-- |get variable indices from declaration of free variables +freeVars :: TExpr -> [(VarIndex, TypeExpr)] +freeVars (TFree vs _) = vs +freeVars _ = error $ "Curry.FlatCurry.Typed.Goodies.freeVars: " ++ + "no declaration of free variables" + +-- |get expression from declaration of free variables +freeExpr :: TExpr -> TExpr +freeExpr (TFree _ e) = e +freeExpr _ = error $ "Curry.FlatCurry.Typed.Goodies.freeExpr: " ++ + "no declaration of free variables" + +-- |get expressions from or-expression +orExps :: TExpr -> [TExpr] +orExps (TOr e1 e2) = [e1, e2] +orExps _ = error $ "Curry.FlatCurry.Typed.Goodies.orExps: " ++ + "no or expression" + +-- |get case-type of case expression +caseType :: TExpr -> CaseType +caseType (TCase ct _ _) = ct +caseType _ = error $ "Curry.FlatCurry.Typed.Goodies.caseType: " ++ + "no case expression" + +-- |get scrutinee of case expression +caseExpr :: TExpr -> TExpr +caseExpr (TCase _ e _) = e +caseExpr _ = error $ "Curry.FlatCurry.Typed.Goodies.caseExpr: " ++ + "no case expression" + + +-- |get branch expressions from case expression +caseBranches :: TExpr -> [TBranchExpr] +caseBranches (TCase _ _ bs) = bs +caseBranches _ = error "Curry.FlatCurry.Typed.Goodies.caseBranches: no case expression" + +-- Test Operations + +-- |is expression a variable? +isTVarE :: TExpr -> Bool +isTVarE e = case e of + TVarE _ _ -> True + _ -> False + +-- |is expression a literal expression? +isTLit :: TExpr -> Bool +isTLit e = case e of + TLit _ _ -> True + _ -> False + +-- |is expression combined? +isTComb :: TExpr -> Bool +isTComb e = case e of + TComb _ _ _ _ -> True + _ -> False + +-- |is expression a let expression? +isTLet :: TExpr -> Bool +isTLet e = case e of + TLet _ _ -> True + _ -> False + +-- |is expression a declaration of free variables? +isTFree :: TExpr -> Bool +isTFree e = case e of + TFree _ _ -> True + _ -> False + +-- |is expression an or-expression? +isTOr :: TExpr -> Bool +isTOr e = case e of + TOr _ _ -> True + _ -> False + +-- |is expression a case expression? +isTCase :: TExpr -> Bool +isTCase e = case e of + TCase _ _ _ -> True + _ -> False + +-- |transform expression +trTExpr :: (TypeExpr -> VarIndex -> b) + -> (TypeExpr -> Literal -> b) + -> (TypeExpr -> CombType -> QName -> [b] -> b) + -> ([((VarIndex, TypeExpr), b)] -> b -> b) + -> ([(VarIndex, TypeExpr)] -> b -> b) + -> (b -> b -> b) + -> (CaseType -> b -> [c] -> b) + -> (TPattern -> b -> c) + -> (b -> TypeExpr -> b) + -> TExpr + -> b +trTExpr var lit comb lt fr oR cas branch typed expr = case expr of + TVarE ty n -> var ty n + TLit ty l -> lit ty l + TComb ty ct name args -> comb ty ct name (map f args) + TLet bs e -> lt (map (\(v, x) -> (v, f x)) bs) (f e) + TFree vs e -> fr vs (f e) + TOr e1 e2 -> oR (f e1) (f e2) + TCase ct e bs -> cas ct (f e) (map (\ (TBranch p e') -> branch p (f e')) bs) + TTyped e ty -> typed (f e) ty + where + f = trTExpr var lit comb lt fr oR cas branch typed + +-- |update all variables in given expression +updVars :: (TypeExpr -> VarIndex -> TExpr) -> TExpr -> TExpr +updVars var = trTExpr var TLit TComb TLet TFree TOr TCase TBranch TTyped + +-- |update all literals in given expression +updLiterals :: (TypeExpr -> Literal -> TExpr) -> TExpr -> TExpr +updLiterals lit = trTExpr TVarE lit TComb TLet TFree TOr TCase TBranch TTyped + +-- |update all combined expressions in given expression +updCombs :: (TypeExpr -> CombType -> QName -> [TExpr] -> TExpr) -> TExpr -> TExpr +updCombs comb = trTExpr TVarE TLit comb TLet TFree TOr TCase TBranch TTyped + +-- |update all let expressions in given expression +updLets :: ([((VarIndex, TypeExpr), TExpr)] -> TExpr -> TExpr) -> TExpr -> TExpr +updLets lt = trTExpr TVarE TLit TComb lt TFree TOr TCase TBranch TTyped + +-- |update all free declarations in given expression +updFrees :: ([(VarIndex, TypeExpr)] -> TExpr -> TExpr) -> TExpr -> TExpr +updFrees fr = trTExpr TVarE TLit TComb TLet fr TOr TCase TBranch TTyped + +-- |update all or expressions in given expression +updOrs :: (TExpr -> TExpr -> TExpr) -> TExpr -> TExpr +updOrs oR = trTExpr TVarE TLit TComb TLet TFree oR TCase TBranch TTyped + +-- |update all case expressions in given expression +updCases :: (CaseType -> TExpr -> [TBranchExpr] -> TExpr) -> TExpr -> TExpr +updCases cas = trTExpr TVarE TLit TComb TLet TFree TOr cas TBranch TTyped + +-- |update all case branches in given expression +updBranches :: (TPattern -> TExpr -> TBranchExpr) -> TExpr -> TExpr +updBranches branch = trTExpr TVarE TLit TComb TLet TFree TOr TCase branch TTyped + +-- |update all typed expressions in given expression +updTypeds :: (TExpr -> TypeExpr -> TExpr) -> TExpr -> TExpr +updTypeds = trTExpr TVarE TLit TComb TLet TFree TOr TCase TBranch + +-- Auxiliary Functions + +-- |is expression a call of a function where all arguments are provided? +isFuncCall :: TExpr -> Bool +isFuncCall e = isTComb e && isCombTypeFuncCall (combType e) + +-- |is expression a partial function call? +isFuncPartCall :: TExpr -> Bool +isFuncPartCall e = isTComb e && isCombTypeFuncPartCall (combType e) + +-- |is expression a call of a constructor? +isConsCall :: TExpr -> Bool +isConsCall e = isTComb e && isCombTypeConsCall (combType e) + +-- |is expression a partial constructor call? +isConsPartCall :: TExpr -> Bool +isConsPartCall e = isTComb e && isCombTypeConsPartCall (combType e) + +-- |is expression fully evaluated? +isGround :: TExpr -> Bool +isGround e + = case e of + TComb _ ConsCall _ args -> all isGround args + _ -> isTLit e + +-- |get all variables (also pattern variables) in expression +allVars :: TExpr -> [(VarIndex, TypeExpr)] +allVars e = trTExpr var lit comb lt fr (.) cas branch typ e [] + where + var a v = (:) (v, a) + lit = const (const id) + comb _ _ _ = foldr (.) id + lt bs e' = e' . foldr (.) id (map (\(n,ns) -> (n:) . ns) bs) + fr vs e' = (vs++) . e' + cas _ e' bs = e' . foldr (.) id bs + branch pat e' = (args pat ++) . e' + typ = const + args pat | isConsPattern pat = tPatArgs pat + | otherwise = [] + +-- |rename all variables (also in patterns) in expression +rnmAllVars :: Update TExpr VarIndex +rnmAllVars f = trTExpr var TLit TComb lt fr TOr TCase branch TTyped + where + var a = TVarE a . f + lt = TLet . map (\((n, b), e) -> ((f n, b), e)) + fr = TFree . map (\(b, c) -> (f b, c)) + branch = TBranch . updTPatArgs (map (\(a, b) -> (f a, b))) + +-- |update all qualified names in expression +updQNames :: Update TExpr QName +updQNames f = trTExpr TVarE TLit comb TLet TFree TOr TCase branch TTyped + where + comb ty ct name args = TComb ty ct (f name) args + branch = TBranch . updTPatCons f + +-- TBranchExpr ---------------------------------------------------------------- + +-- |transform branch expression +trTBranch :: (TPattern -> TExpr -> b) -> TBranchExpr -> b +trTBranch branch (TBranch pat e) = branch pat e + +-- Selectors + +-- |get pattern from branch expression +tBranchTPattern :: TBranchExpr -> TPattern +tBranchTPattern = trTBranch const + +-- |get expression from branch expression +tBranchTExpr :: TBranchExpr -> TExpr +tBranchTExpr = trTBranch (\_ e -> e) + +-- Update Operations + +-- |update branch expression +updTBranch :: (TPattern -> TPattern) -> (TExpr -> TExpr) -> TBranchExpr -> TBranchExpr +updTBranch fp fe = trTBranch branch + where + branch pat e = TBranch (fp pat) (fe e) + +-- |update pattern of branch expression +updTBranchTPattern :: Update TBranchExpr TPattern +updTBranchTPattern f = updTBranch f id + +-- |update expression of branch expression +updTBranchTExpr :: Update TBranchExpr TExpr +updTBranchTExpr = updTBranch id + +-- TPattern ------------------------------------------------------------------- + +-- |transform pattern +trTPattern :: (TypeExpr -> QName -> [(VarIndex, TypeExpr)] -> b) -> (TypeExpr -> Literal -> b) -> TPattern -> b +trTPattern pat _ (TPattern ty name args) = pat ty name args +trTPattern _ lpat (TLPattern a l) = lpat a l + +-- Selectors + +-- |get name from constructor pattern +tPatCons :: TPattern -> QName +tPatCons = trTPattern (\_ name _ -> name) undefined + +-- |get arguments from constructor pattern +tPatArgs :: TPattern -> [(VarIndex, TypeExpr)] +tPatArgs = trTPattern (\_ _ args -> args) undefined + +-- |get literal from literal pattern +tPatLiteral :: TPattern -> Literal +tPatLiteral = trTPattern undefined (const id) + +-- Test Operations + +-- |is pattern a constructor pattern? +isConsPattern :: TPattern -> Bool +isConsPattern = trTPattern (\_ _ _ -> True) (\_ _ -> False) + +-- Update Operations + +-- |update pattern +updTPattern :: (TypeExpr -> TypeExpr) -> + (QName -> QName) -> + ([(VarIndex, TypeExpr)] -> [(VarIndex, TypeExpr)]) -> + (Literal -> Literal) -> TPattern -> TPattern +updTPattern fannot fn fa fl = trTPattern pattern lpattern + where + pattern ty name args = TPattern (fannot ty) (fn name) (fa args) + lpattern ty l = TLPattern (fannot ty) (fl l) + +-- |update TypeExpr of pattern +updTPatType :: (TypeExpr -> TypeExpr) -> TPattern -> TPattern +updTPatType f = updTPattern f id id id + +-- |update constructors name of pattern +updTPatCons :: (QName -> QName) -> TPattern -> TPattern +updTPatCons f = updTPattern id f id id + +-- |update arguments of constructor pattern +updTPatArgs :: ([(VarIndex, TypeExpr)] -> [(VarIndex, TypeExpr)]) -> TPattern -> TPattern +updTPatArgs f = updTPattern id id f id + +-- |update literal of pattern +updTPatLiteral :: (Literal -> Literal) -> TPattern -> TPattern +updTPatLiteral = updTPattern id id id + +-- Auxiliary Functions + +-- |build expression from pattern +tPatExpr :: TPattern -> TExpr +tPatExpr = trTPattern (\ty name -> TComb ty ConsCall name . map (uncurry (flip TVarE))) TLit diff --git a/src/Curry/FlatCurry/Typed/Type.hs b/src/Curry/FlatCurry/Typed/Type.hs new file mode 100644 index 0000000000000000000000000000000000000000..ac428cb03645b927e597a0b563ab167b05281a1f --- /dev/null +++ b/src/Curry/FlatCurry/Typed/Type.hs @@ -0,0 +1,146 @@ +{- | + Module : $Header$ + Description : Representation of annotated FlatCurry. + Copyright : (c) 2016 - 2017 Finn Teegen + 2018 Kai-Oliver Prott + License : BSD-3-clause + + Maintainer : fte@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This library contains a version of FlatCurry's abstract syntax tree + modified with type information + + For more information about the abstract syntax tree of `FlatCurry`, + see the documentation of the respective module. +-} + +module Curry.FlatCurry.Typed.Type + ( module Curry.FlatCurry.Typed.Type + , module Curry.FlatCurry.Typeable + , module Curry.FlatCurry.Type + ) where + +import Data.Binary +import Control.Monad + +import Curry.FlatCurry.Typeable +import Curry.FlatCurry.Type ( QName, VarIndex, Visibility (..), TVarIndex + , TypeDecl (..), Kind (..), OpDecl (..), Fixity (..) + , TypeExpr (..), ConsDecl (..), NewConsDecl (..) + , Literal (..), CombType (..), CaseType (..) + ) + +data TProg = TProg String [String] [TypeDecl] [TFuncDecl] [OpDecl] + deriving (Eq, Read, Show) + +data TFuncDecl = TFunc QName Int Visibility TypeExpr TRule + deriving (Eq, Read, Show) + +data TRule + = TRule [(VarIndex, TypeExpr)] TExpr + | TExternal TypeExpr String + deriving (Eq, Read, Show) + +data TExpr + = TVarE TypeExpr VarIndex -- otherwise name clash with TypeExpr's TVar + | TLit TypeExpr Literal + | TComb TypeExpr CombType QName [TExpr] + | TLet [((VarIndex, TypeExpr), TExpr)] TExpr + | TFree [(VarIndex, TypeExpr)] TExpr + | TOr TExpr TExpr + | TCase CaseType TExpr [TBranchExpr] + | TTyped TExpr TypeExpr + deriving (Eq, Read, Show) + +data TBranchExpr = TBranch TPattern TExpr + deriving (Eq, Read, Show) + +data TPattern + = TPattern TypeExpr QName [(VarIndex, TypeExpr)] + | TLPattern TypeExpr Literal + deriving (Eq, Read, Show) + +instance Typeable TRule where + typeOf (TRule args e) = foldr (FuncType . snd) (typeOf e) args + typeOf (TExternal ty _) = ty + +instance Typeable TExpr where + typeOf (TVarE ty _) = ty + typeOf (TLit ty _) = ty + typeOf (TComb ty _ _ _) = ty + typeOf (TLet _ e) = typeOf e + typeOf (TFree _ e) = typeOf e + typeOf (TOr e _) = typeOf e + typeOf (TCase _ _ (e:_)) = typeOf e + typeOf (TTyped _ ty) = ty + typeOf (TCase _ _ []) = error $ "Curry.FlatCurry.Typed.Type.typeOf: " ++ + "empty list in case expression" + +instance Typeable TPattern where + typeOf (TPattern ty _ _) = ty + typeOf (TLPattern ty _) = ty + +instance Typeable TBranchExpr where + typeOf (TBranch _ e) = typeOf e + +instance Binary TProg where + put (TProg mid im tys fus ops) = + put mid >> put im >> put tys >> put fus >> put ops + get = TProg <$> get <*> get <*> get <*> get <*> get + +instance Binary TFuncDecl where + put (TFunc qid arity vis ty r) = + put qid >> put arity >> put vis >> put ty >> put r + get = TFunc <$> get <*> get <*> get <*> get <*> get + +instance Binary TRule where + put (TRule alts e) = putWord8 0 >> put alts >> put e + put (TExternal ty n ) = putWord8 1 >> put ty >> put n + + get = do + x <- getWord8 + case x of + 0 -> liftM2 TRule get get + 1 -> liftM2 TExternal get get + _ -> fail "Invalid encoding for TRule" + +instance Binary TExpr where + put (TVarE ty v) = putWord8 0 >> put ty >> put v + put (TLit ty l) = putWord8 1 >> put ty >> put l + put (TComb ty cty qid es) = + putWord8 2 >> put ty >> put cty >> put qid >> put es + put (TLet bs e) = putWord8 3 >> put bs >> put e + put (TFree vs e) = putWord8 4 >> put vs >> put e + put (TOr e1 e2) = putWord8 5 >> put e1 >> put e2 + put (TCase cty ty as) = putWord8 6 >> put cty >> put ty >> put as + put (TTyped e ty) = putWord8 7 >> put e >> put ty + + get = do + x <- getWord8 + case x of + 0 -> liftM2 TVarE get get + 1 -> liftM2 TLit get get + 2 -> liftM4 TComb get get get get + 3 -> liftM2 TLet get get + 4 -> liftM2 TFree get get + 5 -> liftM2 TOr get get + 6 -> liftM3 TCase get get get + 7 -> liftM2 TTyped get get + _ -> fail "Invalid encoding for TExpr" + +instance Binary TBranchExpr where + put (TBranch p e) = put p >> put e + get = liftM2 TBranch get get + +instance Binary TPattern where + put (TPattern ty qid vs) = putWord8 0 >> put ty >> put qid >> put vs + put (TLPattern ty l ) = putWord8 1 >> put ty >> put l + + get = do + x <- getWord8 + case x of + 0 -> liftM3 TPattern get get get + 1 -> liftM2 TLPattern get get + _ -> fail "Invalid encoding for TPattern" diff --git a/src/Curry/Syntax.hs b/src/Curry/Syntax.hs new file mode 100644 index 0000000000000000000000000000000000000000..72738b1953ca7af43008d6b542254af0e240c893 --- /dev/null +++ b/src/Curry/Syntax.hs @@ -0,0 +1,81 @@ +{- | + Module : $Header$ + Description : Interface for reading and manipulating Curry source code + Copyright : (c) 2009 Holger Siegel + 2011 - 2013 Björn Peemöller + 2016 Finn Teegen + 2016 Jan Tikovsky + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable +-} +module Curry.Syntax + ( module Curry.Syntax.Type + , module Curry.Syntax.Utils + , L.Token (..), L.Category (..), L.Attributes (..) + , unlit, unlitLexSource, unlitParseHeader, unlitParsePragmas, unlitParseModule + , lexSource, parseInterface, parseHeader, parsePragmas, parseModule, parseGoal + , pPrint, pPrintPrec + , showModule + ) where + +import Curry.Base.Monad (CYM) +import Curry.Base.Span (Span) +import Curry.Base.Pretty (pPrint, pPrintPrec) +import qualified Curry.Files.Unlit as U (unlit) + +import qualified Curry.Syntax.Lexer as L +import qualified Curry.Syntax.Parser as P +import Curry.Syntax.Pretty () +import Curry.Syntax.ShowModule (showModule) +import Curry.Syntax.Type +import Curry.Syntax.Utils + +-- |Unliterate a LiterateCurry file, identity on normal Curry file. +unlit :: FilePath -> String -> CYM String +unlit = U.unlit + +-- |Unliterate and return the result of a lexical analysis of the source +-- program @src@. +-- The result is a list of tuples consisting of a 'Span' and a 'Token'. +unlitLexSource :: FilePath -> String -> CYM [(Span, L.Token)] +unlitLexSource fn src = U.unlit fn src >>= L.lexSource fn + +-- |Unliterate and parse only pragmas of a Curry 'Module' +unlitParsePragmas :: FilePath -> String -> CYM (Module ()) +unlitParsePragmas fn src = U.unlit fn src >>= P.parsePragmas fn + +-- |Unliterate and parse a Curry 'Module' header +unlitParseHeader :: FilePath -> String -> CYM (Module ()) +unlitParseHeader fn src = U.unlit fn src >>= P.parseHeader fn + +-- |Unliterate and parse a Curry 'Module' +unlitParseModule :: FilePath -> String -> CYM (Module ()) +unlitParseModule fn src = U.unlit fn src >>= P.parseSource fn + +-- |Return the result of a lexical analysis of the source program @src@. +-- The result is a list of tuples consisting of a 'Span' and a 'Token'. +lexSource :: FilePath -> String -> CYM [(Span, L.Token)] +lexSource = L.lexSource + +-- |Parse a Curry 'Interface' +parseInterface :: FilePath -> String -> CYM Interface +parseInterface = P.parseInterface + +-- |Parse only pragmas of a Curry 'Module' +parsePragmas :: FilePath -> String -> CYM (Module ()) +parsePragmas = P.parsePragmas + +-- |Parse a Curry 'Module' header +parseHeader :: FilePath -> String -> CYM (Module ()) +parseHeader = P.parseHeader + +-- |Parse a Curry 'Module' +parseModule :: FilePath -> String -> CYM (Module ()) +parseModule = P.parseSource + +-- |Parse a 'Goal', i.e. an expression with (optional) local declarations +parseGoal :: String -> CYM (Goal ()) +parseGoal = P.parseGoal diff --git a/src/Curry/Syntax/Extension.hs b/src/Curry/Syntax/Extension.hs new file mode 100644 index 0000000000000000000000000000000000000000..17152663c0f626330e8d6d4c13bd42c69d00f6e5 --- /dev/null +++ b/src/Curry/Syntax/Extension.hs @@ -0,0 +1,120 @@ +{- | + Module : $Header$ + Description : Curry language extensions + Copyright : (c) 2013 - 2014 Björn Peemöller + 2016 Finn Teegen + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This module provides the data structures for Curry language extensions. +-} + +module Curry.Syntax.Extension + ( -- * Extensions + Extension (..), KnownExtension (..), classifyExtension, kielExtensions + -- * Tools + , Tool (..), classifyTool + ) where + +import Data.Binary +import Data.Char (toUpper) +import Control.Monad + +import Curry.Base.Ident (Ident (..)) +import Curry.Base.Position +import Curry.Base.SpanInfo + +-- |Specified language extensions, either known or unknown. +data Extension + = KnownExtension SpanInfo KnownExtension -- ^ a known extension + | UnknownExtension SpanInfo String -- ^ an unknown extension + deriving (Eq, Read, Show) + +instance HasSpanInfo Extension where + getSpanInfo (KnownExtension spi _) = spi + getSpanInfo (UnknownExtension spi _) = spi + + setSpanInfo spi (KnownExtension _ ke) = KnownExtension spi ke + setSpanInfo spi (UnknownExtension _ s) = UnknownExtension spi s + +instance HasPosition Extension where + getPosition = getStartPosition + setPosition = setStartPosition + +instance Binary Extension where + put (KnownExtension p e) = putWord8 0 >> put p >> put e + put (UnknownExtension p e) = putWord8 1 >> put p >> put e + + get = do + x <- getWord8 + case x of + 0 -> liftM2 KnownExtension get get + 1 -> liftM2 UnknownExtension get get + _ -> fail "Invalid encoding for Extension" + +instance Binary KnownExtension where + put AnonFreeVars = putWord8 0 + put CPP = putWord8 1 + put FunctionalPatterns = putWord8 2 + put NegativeLiterals = putWord8 3 + put NoImplicitPrelude = putWord8 4 + + get = do + x <- getWord8 + case x of + 0 -> return AnonFreeVars + 1 -> return CPP + 2 -> return FunctionalPatterns + 3 -> return NegativeLiterals + 4 -> return NoImplicitPrelude + _ -> fail "Invalid encoding for KnownExtension" + +-- |Known language extensions of Curry. +data KnownExtension + = AnonFreeVars -- ^ anonymous free variables + | CPP -- ^ C preprocessor + | FunctionalPatterns -- ^ functional patterns + | NegativeLiterals -- ^ negative literals + | NoImplicitPrelude -- ^ no implicit import of the prelude + deriving (Eq, Read, Show, Enum, Bounded) + +-- |Classifies a 'String' as an 'Extension' +classifyExtension :: Ident -> Extension +classifyExtension i = case reads extName of + [(e, "")] -> KnownExtension (getSpanInfo i) e + _ -> UnknownExtension (getSpanInfo i) extName + where extName = idName i + +-- |'Extension's available by Kiel's Curry compilers. +kielExtensions :: [KnownExtension] +kielExtensions = [AnonFreeVars, FunctionalPatterns] + +-- |Different Curry tools which may accept compiler options. +data Tool = KICS2 | PAKCS | CYMAKE | FRONTEND | UnknownTool String + deriving (Eq, Read, Show) + +instance Binary Tool where + put KICS2 = putWord8 0 + put PAKCS = putWord8 1 + put CYMAKE = putWord8 2 + put FRONTEND = putWord8 3 + put (UnknownTool s) = putWord8 4 >> put s + + get = do + x <- getWord8 + case x of + 0 -> return KICS2 + 1 -> return PAKCS + 2 -> return CYMAKE + 3 -> return FRONTEND + 4 -> fmap UnknownTool get + _ -> fail "Invalid encoding for Tool" + +-- |Classifies a 'String' as a 'Tool' +classifyTool :: String -> Tool +classifyTool str = case reads (map toUpper str) of + [(t, "")] -> t + _ -> UnknownTool str diff --git a/src/Curry/Syntax/InterfaceEquivalence.hs b/src/Curry/Syntax/InterfaceEquivalence.hs new file mode 100644 index 0000000000000000000000000000000000000000..071af9f3f8ba5a1731f6ac53608aab3aac808709 --- /dev/null +++ b/src/Curry/Syntax/InterfaceEquivalence.hs @@ -0,0 +1,209 @@ +{- | + Module : $Header$ + Description : Comparison of Curry Interfaces + Copyright : (c) 2000 - 2007 Wolfgang Lux + 2014 - 2015 Björn Peemöller + 2014 Jan Tikovsky + 2016 Finn Teegen + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + If a module is recompiled, the compiler has to check whether the + interface file must be updated. This must be done if any exported + entity has been changed, or an export was removed or added. The + function 'intfEquiv' checks whether two interfaces are + equivalent, i.e., whether they define the same entities. +-} +module Curry.Syntax.InterfaceEquivalence (fixInterface, intfEquiv) where + +import Data.List (deleteFirstsBy, sort) +import qualified Data.Set as Set + +import Curry.Base.Ident +import Curry.Syntax + +infix 4 =~=, `eqvSet` + +-- |Are two given interfaces equivalent? +intfEquiv :: Interface -> Interface -> Bool +intfEquiv = (=~=) + +-- |Type class to express the equivalence of two values +class Equiv a where + (=~=) :: a -> a -> Bool + +instance Equiv a => Equiv (Maybe a) where + Nothing =~= Nothing = True + Nothing =~= Just _ = False + Just _ =~= Nothing = False + Just x =~= Just y = x =~= y + +instance Equiv a => Equiv [a] where + [] =~= [] = True + (x:xs) =~= (y:ys) = x =~= y && xs =~= ys + _ =~= _ = False + +eqvList, eqvSet :: Equiv a => [a] -> [a] -> Bool +xs `eqvList` ys = length xs == length ys && and (zipWith (=~=) xs ys) +xs `eqvSet` ys = null (deleteFirstsBy (=~=) xs ys ++ deleteFirstsBy (=~=) ys xs) + +instance Equiv Interface where + Interface m1 is1 ds1 =~= Interface m2 is2 ds2 + = m1 == m2 && is1 `eqvSet` is2 && ds1 `eqvSet` ds2 + +instance Equiv IImportDecl where + IImportDecl _ m1 =~= IImportDecl _ m2 = m1 == m2 + +-- Since the kind of type constructors or type classes can be omitted +-- in the interface when the kind is simple, i.e., it is either * or of +-- the form * -> ... -> *, a non given kind has to be considered equivalent +-- to a given one if the latter is simple. + +eqvKindExpr :: Maybe KindExpr -> Maybe KindExpr -> Bool +Nothing `eqvKindExpr` (Just k) = isSimpleKindExpr k +(Just k) `eqvKindExpr` Nothing = isSimpleKindExpr k +k1 `eqvKindExpr` k2 = k1 == k2 + +isSimpleKindExpr :: KindExpr -> Bool +isSimpleKindExpr Star = True +isSimpleKindExpr (ArrowKind Star k) = isSimpleKindExpr k +isSimpleKindExpr _ = False + + +instance Equiv IDecl where + IInfixDecl _ fix1 p1 op1 =~= IInfixDecl _ fix2 p2 op2 + = fix1 == fix2 && p1 == p2 && op1 == op2 + HidingDataDecl _ tc1 k1 tvs1 =~= HidingDataDecl _ tc2 k2 tvs2 + = tc1 == tc2 && k1 `eqvKindExpr` k2 && tvs1 == tvs2 + IDataDecl _ tc1 k1 tvs1 cs1 hs1 =~= IDataDecl _ tc2 k2 tvs2 cs2 hs2 + = tc1 == tc2 && k1 `eqvKindExpr` k2 && tvs1 == tvs2 && cs1 =~= cs2 && + hs1 `eqvSet` hs2 + INewtypeDecl _ tc1 k1 tvs1 nc1 hs1 =~= INewtypeDecl _ tc2 k2 tvs2 nc2 hs2 + = tc1 == tc2 && k1 `eqvKindExpr` k2 && tvs1 == tvs2 && nc1 =~= nc2 && + hs1 `eqvSet` hs2 + ITypeDecl _ tc1 k1 tvs1 ty1 =~= ITypeDecl _ tc2 k2 tvs2 ty2 + = tc1 == tc2 && k1 `eqvKindExpr` k2 && tvs1 == tvs2 && ty1 == ty2 + IFunctionDecl _ f1 cm1 n1 qty1 =~= IFunctionDecl _ f2 cm2 n2 qty2 + = f1 == f2 && cm1 == cm2 && n1 == n2 && qty1 == qty2 + HidingClassDecl _ cx1 cls1 k1 _ =~= HidingClassDecl _ cx2 cls2 k2 _ + = cx1 == cx2 && cls1 == cls2 && k1 `eqvKindExpr` k2 + IClassDecl _ cx1 cls1 k1 _ ms1 hs1 =~= IClassDecl _ cx2 cls2 k2 _ ms2 hs2 + = cx1 == cx2 && cls1 == cls2 && k1 `eqvKindExpr` k2 && + ms1 `eqvList` ms2 && hs1 `eqvSet` hs2 + IInstanceDecl _ cx1 cls1 ty1 is1 m1 =~= IInstanceDecl _ cx2 cls2 ty2 is2 m2 + = cx1 == cx2 && cls1 == cls2 && ty1 == ty2 && sort is1 == sort is2 && + m1 == m2 + _ =~= _ = False + +instance Equiv ConstrDecl where + ConstrDecl _ c1 tys1 =~= ConstrDecl _ c2 tys2 + = c1 == c2 && tys1 == tys2 + ConOpDecl _ ty11 op1 ty12 =~= ConOpDecl _ ty21 op2 ty22 + = op1 == op2 && ty11 == ty21 && ty12 == ty22 + RecordDecl _ c1 fs1 =~= RecordDecl _ c2 fs2 + = c1 == c2 && fs1 `eqvList` fs2 + _ =~= _ = False + +instance Equiv FieldDecl where + FieldDecl _ ls1 ty1 =~= FieldDecl _ ls2 ty2 = ls1 == ls2 && ty1 == ty2 + +instance Equiv NewConstrDecl where + NewConstrDecl _ c1 ty1 =~= NewConstrDecl _ c2 ty2 = c1 == c2 && ty1 == ty2 + NewRecordDecl _ c1 fld1 =~= NewRecordDecl _ c2 fld2 = c1 == c2 && fld1 == fld2 + _ =~= _ = False + +instance Equiv IMethodDecl where + IMethodDecl _ f1 a1 qty1 =~= IMethodDecl _ f2 a2 qty2 + = f1 == f2 && a1 == a2 && qty1 == qty2 + +instance Equiv Ident where + (=~=) = (==) + +-- If we check for a change in the interface, we do not need to check the +-- interface declarations, but still must disambiguate (nullary) type +-- constructors and type variables in type expressions. This is handled +-- by function 'fixInterface' and the associated type class 'FixInterface'. + +-- |Disambiguate nullary type constructors and type variables. +fixInterface :: Interface -> Interface +fixInterface (Interface m is ds) = Interface m is $ + fix (Set.fromList (typeConstructors ds)) ds + +class FixInterface a where + fix :: Set.Set Ident -> a -> a + +instance FixInterface a => FixInterface (Maybe a) where + fix tcs = fmap (fix tcs) + +instance FixInterface a => FixInterface [a] where + fix tcs = map (fix tcs) + +instance FixInterface IDecl where + fix tcs (IDataDecl p tc k vs cs hs) = + IDataDecl p tc k vs (fix tcs cs) hs + fix tcs (INewtypeDecl p tc k vs nc hs) = + INewtypeDecl p tc k vs (fix tcs nc) hs + fix tcs (ITypeDecl p tc k vs ty) = + ITypeDecl p tc k vs (fix tcs ty) + fix tcs (IFunctionDecl p f cm n qty) = + IFunctionDecl p f cm n (fix tcs qty) + fix tcs (HidingClassDecl p cx cls k tv) = + HidingClassDecl p (fix tcs cx) cls k tv + fix tcs (IClassDecl p cx cls k tv ms hs) = + IClassDecl p (fix tcs cx) cls k tv (fix tcs ms) hs + fix tcs (IInstanceDecl p cx cls inst is m) = + IInstanceDecl p (fix tcs cx) cls (fix tcs inst) is m + fix _ d = d + +instance FixInterface ConstrDecl where + fix tcs (ConstrDecl p c tys) = ConstrDecl p c (fix tcs tys) + fix tcs (ConOpDecl p ty1 op ty2) = ConOpDecl p (fix tcs ty1) + op (fix tcs ty2) + fix tcs (RecordDecl p c fs) = RecordDecl p c (fix tcs fs) + +instance FixInterface FieldDecl where + fix tcs (FieldDecl p ls ty) = FieldDecl p ls (fix tcs ty) + +instance FixInterface NewConstrDecl where + fix tcs (NewConstrDecl p c ty ) = NewConstrDecl p c (fix tcs ty) + fix tcs (NewRecordDecl p c (i,ty)) = NewRecordDecl p c (i, fix tcs ty) + +instance FixInterface IMethodDecl where + fix tcs (IMethodDecl p f a qty) = IMethodDecl p f a (fix tcs qty) + +instance FixInterface QualTypeExpr where + fix tcs (QualTypeExpr spi cx ty) = QualTypeExpr spi (fix tcs cx) (fix tcs ty) + +instance FixInterface Constraint where + fix tcs (Constraint spi qcls ty) = Constraint spi qcls (fix tcs ty) + +instance FixInterface TypeExpr where + fix tcs (ConstructorType spi tc) + | not (isQualified tc) && not (isPrimTypeId tc) && tc' `Set.notMember` tcs + = VariableType spi tc' + | otherwise = ConstructorType spi tc + where tc' = unqualify tc + fix tcs (ApplyType spi ty1 ty2) = ApplyType spi (fix tcs ty1) (fix tcs ty2) + fix tcs (VariableType spi tv) + | tv `Set.member` tcs = ConstructorType spi (qualify tv) + | otherwise = VariableType spi tv + fix tcs (TupleType spi tys) = TupleType spi (fix tcs tys) + fix tcs (ListType spi ty) = ListType spi (fix tcs ty) + fix tcs (ArrowType spi ty1 ty2) = ArrowType spi (fix tcs ty1) (fix tcs ty2) + fix tcs (ParenType spi ty) = ParenType spi (fix tcs ty) + fix tcs (ForallType spi vs ty) = ForallType spi vs (fix tcs ty) + +typeConstructors :: [IDecl] -> [Ident] +typeConstructors ds = [tc | (QualIdent _ Nothing tc) <- foldr tyCons [] ds] + where tyCons (IInfixDecl _ _ _ _) tcs = tcs + tyCons (HidingDataDecl _ tc _ _) tcs = tc : tcs + tyCons (IDataDecl _ tc _ _ _ _) tcs = tc : tcs + tyCons (INewtypeDecl _ tc _ _ _ _) tcs = tc : tcs + tyCons (ITypeDecl _ tc _ _ _) tcs = tc : tcs + tyCons (IFunctionDecl _ _ _ _ _) tcs = tcs + tyCons (HidingClassDecl _ _ _ _ _) tcs = tcs + tyCons (IClassDecl _ _ _ _ _ _ _) tcs = tcs + tyCons (IInstanceDecl _ _ _ _ _ _) tcs = tcs diff --git a/src/Curry/Syntax/Lexer.hs b/src/Curry/Syntax/Lexer.hs new file mode 100644 index 0000000000000000000000000000000000000000..414bdb550167998eda1c05c17256a4c4b370e6bf --- /dev/null +++ b/src/Curry/Syntax/Lexer.hs @@ -0,0 +1,889 @@ +{- | + Module : $Header$ + Description : A lexer for Curry + Copyright : (c) 1999 - 2004 Wolfgang Lux + 2005 Martin Engelke + 2011 - 2013 Björn Peemöller + 2016 Finn Teegen + 2016 Jan Tikovsky + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable +-} +module Curry.Syntax.Lexer + ( -- * Data types for tokens + Token (..), Category (..), Attributes (..) + + -- * lexing functions + , lexSource, lexer, fullLexer + ) where + +import Prelude hiding (fail) +import Data.Char + ( chr, ord, isAlpha, isAlphaNum, isDigit, isHexDigit, isOctDigit + , isSpace, isUpper, toLower + ) +import Data.List (intercalate) +import qualified Data.Map as Map + (Map, union, lookup, findWithDefault, fromList) + +import Curry.Base.LexComb +import Curry.Base.Position +import Curry.Base.Span + +-- --------------------------------------------------------------------------- +-- Tokens. Note that the equality and ordering instances of Token disregard +-- the attributes, as so that the parser decides about accepting a token +-- just by its category. +-- --------------------------------------------------------------------------- + +-- |Data type for curry lexer tokens +data Token = Token Category Attributes + +instance Eq Token where + Token c1 _ == Token c2 _ = c1 == c2 + +instance Ord Token where + Token c1 _ `compare` Token c2 _ = c1 `compare` c2 + +instance Symbol Token where + isEOF (Token c _) = c == EOF + + dist _ (Token VSemicolon _) = (0, 0) + dist _ (Token VRightBrace _) = (0, 0) + dist _ (Token EOF _) = (0, 0) + dist _ (Token DotDot _) = (0, 1) + dist _ (Token DoubleColon _) = (0, 1) + dist _ (Token LeftArrow _) = (0, 1) + dist _ (Token RightArrow _) = (0, 1) + dist _ (Token DoubleArrow _) = (0, 1) + dist _ (Token KW_do _) = (0, 1) + dist _ (Token KW_if _) = (0, 1) + dist _ (Token KW_in _) = (0, 1) + dist _ (Token KW_of _) = (0, 1) + dist _ (Token Id_as _) = (0, 1) + dist _ (Token KW_let _) = (0, 2) + dist _ (Token PragmaEnd _) = (0, 2) + dist _ (Token KW_case _) = (0, 3) + dist _ (Token KW_class _) = (0, 4) + dist _ (Token KW_data _) = (0, 3) + dist _ (Token KW_default _) = (0, 6) + dist _ (Token KW_deriving _) = (0, 7) + dist _ (Token KW_else _) = (0, 3) + dist _ (Token KW_free _) = (0, 3) + dist _ (Token KW_then _) = (0, 3) + dist _ (Token KW_type _) = (0, 3) + dist _ (Token KW_fcase _) = (0, 4) + dist _ (Token KW_infix _) = (0, 4) + dist _ (Token KW_instance _) = (0, 7) + dist _ (Token KW_where _) = (0, 4) + dist _ (Token Id_ccall _) = (0, 4) + dist _ (Token KW_import _) = (0, 5) + dist _ (Token KW_infixl _) = (0, 5) + dist _ (Token KW_infixr _) = (0, 5) + dist _ (Token KW_module _) = (0, 5) + dist _ (Token Id_forall _) = (0, 5) + dist _ (Token Id_hiding _) = (0, 5) + dist _ (Token KW_newtype _) = (0, 6) + dist _ (Token KW_external _) = (0, 7) + dist _ (Token Id_interface _) = (0, 8) + dist _ (Token Id_primitive _) = (0, 8) + dist _ (Token Id_qualified _) = (0, 8) + dist _ (Token PragmaHiding _) = (0, 9) + dist _ (Token PragmaLanguage _) = (0, 11) + dist _ (Token Id a) = distAttr False a + dist _ (Token QId a) = distAttr False a + dist _ (Token Sym a) = distAttr False a + dist _ (Token QSym a) = distAttr False a + dist _ (Token IntTok a) = distAttr False a + dist _ (Token FloatTok a) = distAttr False a + dist _ (Token CharTok a) = distAttr False a + dist c (Token StringTok a) = updColDist c (distAttr False a) + dist _ (Token LineComment a) = distAttr True a + dist c (Token NestedComment a) = updColDist c (distAttr True a) + dist _ (Token PragmaOptions a) = let (ld, cd) = distAttr False a + in (ld, cd + 11) + dist _ _ = (0, 0) + +-- TODO: Comment +updColDist :: Int -> Distance -> Distance +updColDist c (ld, cd) = (ld, if ld == 0 then cd else cd - c + 1) + +distAttr :: Bool -> Attributes -> Distance +distAttr isComment attr = case attr of + NoAttributes -> (0, 0) + CharAttributes _ orig -> (0, length orig + 1) + IntAttributes _ orig -> (0, length orig - 1) + FloatAttributes _ orig -> (0, length orig - 1) + StringAttributes _ orig + -- comment without surrounding quotes + | isComment -> (ld, cd) + -- string with one ending double quote or two surrounding double quotes + -- (column distance + 1 / + 2) + | '\n' `elem` orig -> (ld, cd + 1) + | otherwise -> (ld, cd + 2) + where ld = length (filter (== '\n') orig) + cd = length (takeWhile (/= '\n') (reverse orig)) - 1 + IdentAttributes mid i -> (0, length (intercalate "." (mid ++ [i])) - 1) + OptionsAttributes mt args -> case mt of + Nothing -> (0, distArgs + 1) + Just t -> (0, length t + distArgs + 2) + where distArgs = length args + +-- |Category of curry tokens +data Category + -- literals + = CharTok + | IntTok + | FloatTok + | StringTok + + -- identifiers + | Id -- identifier + | QId -- qualified identifier + | Sym -- symbol + | QSym -- qualified symbol + + -- punctuation symbols + | LeftParen -- ( + | RightParen -- ) + | Semicolon -- ; + | LeftBrace -- { + | RightBrace -- } + | LeftBracket -- [ + | RightBracket -- ] + | Comma -- , + | Underscore -- _ + | Backquote -- ` + + -- layout + | VSemicolon -- virtual ; + | VRightBrace -- virtual } + + -- reserved keywords + | KW_case + | KW_class + | KW_data + | KW_default + | KW_deriving + | KW_do + | KW_else + | KW_external + | KW_fcase + | KW_free + | KW_if + | KW_import + | KW_in + | KW_infix + | KW_infixl + | KW_infixr + | KW_instance + | KW_let + | KW_module + | KW_newtype + | KW_of + | KW_then + | KW_type + | KW_where + + -- reserved operators + | At -- @ + | Colon -- : + | DotDot -- .. + | DoubleColon -- :: + | Equals -- = + | Backslash -- \ + | Bar -- | + | LeftArrow -- <- + | RightArrow -- -> + | Tilde -- ~ + | DoubleArrow -- => + + -- special identifiers + | Id_as + | Id_ccall + | Id_forall + | Id_hiding + | Id_interface + | Id_primitive + | Id_qualified + + -- special operators + | SymDot -- . + | SymMinus -- - + + -- special symbols + | SymStar -- kind star (*) + + -- pragmas + | PragmaLanguage -- {-# LANGUAGE + | PragmaOptions -- {-# OPTIONS + | PragmaHiding -- {-# HIDING + | PragmaMethod -- {-# METHOD + | PragmaModule -- {-# MODULE + | PragmaEnd -- #-} + + + -- comments (only for full lexer) inserted by men & bbr + | LineComment + | NestedComment + + -- end-of-file token + | EOF + deriving (Eq, Ord) + +-- There are different kinds of attributes associated with the tokens. +-- Most attributes simply save the string corresponding to the token. +-- However, for qualified identifiers, we also record the list of module +-- qualifiers. The values corresponding to a literal token are properly +-- converted already. To simplify the creation and extraction of +-- attribute values, we make use of records. + +-- |Attributes associated to a token +data Attributes + = NoAttributes + | CharAttributes { cval :: Char , original :: String } + | IntAttributes { ival :: Integer , original :: String } + | FloatAttributes { fval :: Double , original :: String } + | StringAttributes { sval :: String , original :: String } + | IdentAttributes { modulVal :: [String] , sval :: String } + | OptionsAttributes { toolVal :: Maybe String, toolArgs :: String } + +instance Show Attributes where + showsPrec _ NoAttributes = showChar '_' + showsPrec _ (CharAttributes cv _) = shows cv + showsPrec _ (IntAttributes iv _) = shows iv + showsPrec _ (FloatAttributes fv _) = shows fv + showsPrec _ (StringAttributes sv _) = shows sv + showsPrec _ (IdentAttributes mid i) = showsEscaped + $ intercalate "." $ mid ++ [i] + showsPrec _ (OptionsAttributes mt s) = showsTool mt + . showChar ' ' . showString s + where showsTool = maybe id (\t -> showChar '_' . showString t) + + +-- --------------------------------------------------------------------------- +-- The 'Show' instance of 'Token' is designed to display all tokens in their +-- source representation. +-- --------------------------------------------------------------------------- + +showsEscaped :: String -> ShowS +showsEscaped s = showChar '`' . showString s . showChar '\'' + +showsIdent :: Attributes -> ShowS +showsIdent a = showString "identifier " . shows a + +showsSpecialIdent :: String -> ShowS +showsSpecialIdent s = showString "identifier " . showsEscaped s + +showsOperator :: Attributes -> ShowS +showsOperator a = showString "operator " . shows a + +showsSpecialOperator :: String -> ShowS +showsSpecialOperator s = showString "operator " . showsEscaped s + +instance Show Token where + showsPrec _ (Token Id a) = showsIdent a + showsPrec _ (Token QId a) = showString "qualified " + . showsIdent a + showsPrec _ (Token Sym a) = showsOperator a + showsPrec _ (Token QSym a) = showString "qualified " + . showsOperator a + showsPrec _ (Token IntTok a) = showString "integer " . shows a + showsPrec _ (Token FloatTok a) = showString "float " . shows a + showsPrec _ (Token CharTok a) = showString "character " . shows a + showsPrec _ (Token StringTok a) = showString "string " . shows a + showsPrec _ (Token LeftParen _) = showsEscaped "(" + showsPrec _ (Token RightParen _) = showsEscaped ")" + showsPrec _ (Token Semicolon _) = showsEscaped ";" + showsPrec _ (Token LeftBrace _) = showsEscaped "{" + showsPrec _ (Token RightBrace _) = showsEscaped "}" + showsPrec _ (Token LeftBracket _) = showsEscaped "[" + showsPrec _ (Token RightBracket _) = showsEscaped "]" + showsPrec _ (Token Comma _) = showsEscaped "," + showsPrec _ (Token Underscore _) = showsEscaped "_" + showsPrec _ (Token Backquote _) = showsEscaped "`" + showsPrec _ (Token VSemicolon _) + = showsEscaped ";" . showString " (inserted due to layout)" + showsPrec _ (Token VRightBrace _) + = showsEscaped "}" . showString " (inserted due to layout)" + showsPrec _ (Token At _) = showsEscaped "@" + showsPrec _ (Token Colon _) = showsEscaped ":" + showsPrec _ (Token DotDot _) = showsEscaped ".." + showsPrec _ (Token DoubleArrow _) = showsEscaped "=>" + showsPrec _ (Token DoubleColon _) = showsEscaped "::" + showsPrec _ (Token Equals _) = showsEscaped "=" + showsPrec _ (Token Backslash _) = showsEscaped "\\" + showsPrec _ (Token Bar _) = showsEscaped "|" + showsPrec _ (Token LeftArrow _) = showsEscaped "<-" + showsPrec _ (Token RightArrow _) = showsEscaped "->" + showsPrec _ (Token Tilde _) = showsEscaped "~" + showsPrec _ (Token SymDot _) = showsSpecialOperator "." + showsPrec _ (Token SymMinus _) = showsSpecialOperator "-" + showsPrec _ (Token SymStar _) = showsEscaped "*" + showsPrec _ (Token KW_case _) = showsEscaped "case" + showsPrec _ (Token KW_class _) = showsEscaped "class" + showsPrec _ (Token KW_data _) = showsEscaped "data" + showsPrec _ (Token KW_default _) = showsEscaped "default" + showsPrec _ (Token KW_deriving _) = showsEscaped "deriving" + showsPrec _ (Token KW_do _) = showsEscaped "do" + showsPrec _ (Token KW_else _) = showsEscaped "else" + showsPrec _ (Token KW_external _) = showsEscaped "external" + showsPrec _ (Token KW_fcase _) = showsEscaped "fcase" + showsPrec _ (Token KW_free _) = showsEscaped "free" + showsPrec _ (Token KW_if _) = showsEscaped "if" + showsPrec _ (Token KW_import _) = showsEscaped "import" + showsPrec _ (Token KW_in _) = showsEscaped "in" + showsPrec _ (Token KW_infix _) = showsEscaped "infix" + showsPrec _ (Token KW_infixl _) = showsEscaped "infixl" + showsPrec _ (Token KW_infixr _) = showsEscaped "infixr" + showsPrec _ (Token KW_instance _) = showsEscaped "instance" + showsPrec _ (Token KW_let _) = showsEscaped "let" + showsPrec _ (Token KW_module _) = showsEscaped "module" + showsPrec _ (Token KW_newtype _) = showsEscaped "newtype" + showsPrec _ (Token KW_of _) = showsEscaped "of" + showsPrec _ (Token KW_then _) = showsEscaped "then" + showsPrec _ (Token KW_type _) = showsEscaped "type" + showsPrec _ (Token KW_where _) = showsEscaped "where" + showsPrec _ (Token Id_as _) = showsSpecialIdent "as" + showsPrec _ (Token Id_ccall _) = showsSpecialIdent "ccall" + showsPrec _ (Token Id_forall _) = showsSpecialIdent "forall" + showsPrec _ (Token Id_hiding _) = showsSpecialIdent "hiding" + showsPrec _ (Token Id_interface _) = showsSpecialIdent "interface" + showsPrec _ (Token Id_primitive _) = showsSpecialIdent "primitive" + showsPrec _ (Token Id_qualified _) = showsSpecialIdent "qualified" + showsPrec _ (Token PragmaLanguage _) = showString "{-# LANGUAGE" + showsPrec _ (Token PragmaOptions a) = showString "{-# OPTIONS" + . shows a + showsPrec _ (Token PragmaHiding _) = showString "{-# HIDING" + showsPrec _ (Token PragmaMethod _) = showString "{-# METHOD" + showsPrec _ (Token PragmaModule _) = showString "{-# MODULE" + showsPrec _ (Token PragmaEnd _) = showString "#-}" + showsPrec _ (Token LineComment a) = shows a + showsPrec _ (Token NestedComment a) = shows a + showsPrec _ (Token EOF _) = showString "" + +-- --------------------------------------------------------------------------- +-- The following functions can be used to construct tokens with +-- specific attributes. +-- --------------------------------------------------------------------------- + +-- |Construct a simple 'Token' without 'Attributes' +tok :: Category -> Token +tok t = Token t NoAttributes + +-- |Construct a 'Token' for a single 'Char' +charTok :: Char -> String -> Token +charTok c o = Token CharTok CharAttributes { cval = c, original = o } + +-- |Construct a 'Token' for an int value +intTok :: Integer -> String -> Token +intTok base digits = Token IntTok IntAttributes + { ival = convertIntegral base digits, original = digits } + +-- |Construct a 'Token' for a float value +floatTok :: String -> String -> Int -> String -> Token +floatTok mant frac expo rest = Token FloatTok FloatAttributes + { fval = convertFloating mant frac expo + , original = mant ++ "." ++ frac ++ rest } + +-- |Construct a 'Token' for a string value +stringTok :: String -> String -> Token +stringTok cs s = Token StringTok StringAttributes { sval = cs, original = s } + +-- |Construct a 'Token' for identifiers +idTok :: Category -> [String] -> String -> Token +idTok t mIdent ident = Token t + IdentAttributes { modulVal = mIdent, sval = ident } + +-- TODO +pragmaOptionsTok :: Maybe String -> String -> Token +pragmaOptionsTok mbTool s = Token PragmaOptions + OptionsAttributes { toolVal = mbTool, toolArgs = s } + +-- |Construct a 'Token' for a line comment +lineCommentTok :: String -> Token +lineCommentTok s = Token LineComment + StringAttributes { sval = s, original = s } + +-- |Construct a 'Token' for a nested comment +nestedCommentTok :: String -> Token +nestedCommentTok s = Token NestedComment + StringAttributes { sval = s, original = s } + +-- --------------------------------------------------------------------------- +-- Tables for reserved operators and identifiers +-- --------------------------------------------------------------------------- + +-- |Map of reserved operators +reservedOps:: Map.Map String Category +reservedOps = Map.fromList + [ ("@" , At ) + , (":" , Colon ) + , ("=>", DoubleArrow) + , ("::", DoubleColon) + , ("..", DotDot ) + , ("=" , Equals ) + , ("\\", Backslash ) + , ("|" , Bar ) + , ("<-", LeftArrow ) + , ("->", RightArrow ) + , ("~" , Tilde ) + ] + +-- |Map of reserved and special operators +reservedSpecialOps :: Map.Map String Category +reservedSpecialOps = Map.union reservedOps $ Map.fromList + [ ("." , SymDot ) + , ("-" , SymMinus ) + , ("*" , SymStar ) + ] + +-- |Map of keywords +keywords :: Map.Map String Category +keywords = Map.fromList + [ ("case" , KW_case ) + , ("class" , KW_class ) + , ("data" , KW_data ) + , ("default" , KW_default ) + , ("deriving", KW_deriving) + , ("do" , KW_do ) + , ("else" , KW_else ) + , ("external", KW_external) + , ("fcase" , KW_fcase ) + , ("free" , KW_free ) + , ("if" , KW_if ) + , ("import" , KW_import ) + , ("in" , KW_in ) + , ("infix" , KW_infix ) + , ("infixl" , KW_infixl ) + , ("infixr" , KW_infixr ) + , ("instance", KW_instance) + , ("let" , KW_let ) + , ("module" , KW_module ) + , ("newtype" , KW_newtype ) + , ("of" , KW_of ) + , ("then" , KW_then ) + , ("type" , KW_type ) + , ("where" , KW_where ) + ] + +-- |Map of keywords and special identifiers +keywordsSpecialIds :: Map.Map String Category +keywordsSpecialIds = Map.union keywords $ Map.fromList + [ ("as" , Id_as ) + , ("ccall" , Id_ccall ) + , ("forall" , Id_forall ) + , ("hiding" , Id_hiding ) + , ("interface", Id_interface) + , ("primitive", Id_primitive) + , ("qualified", Id_qualified) + ] + +pragmas :: Map.Map String Category +pragmas = Map.fromList + [ ("language", PragmaLanguage) + , ("options" , PragmaOptions ) + , ("hiding" , PragmaHiding ) + , ("method" , PragmaMethod ) + , ("module" , PragmaModule ) + ] + + +-- --------------------------------------------------------------------------- +-- Character classes +-- --------------------------------------------------------------------------- + +-- |Check whether a 'Char' is allowed for identifiers +isIdentChar :: Char -> Bool +isIdentChar c = isAlphaNum c || c `elem` "'_" + +-- |Check whether a 'Char' is allowed for symbols +isSymbolChar :: Char -> Bool +isSymbolChar c = c `elem` "~!@#$%^&*+-=<>:?./|\\" + +-- --------------------------------------------------------------------------- +-- Lexing functions +-- --------------------------------------------------------------------------- + +-- |Lex source code +lexSource :: FilePath -> String -> CYM [(Span, Token)] +lexSource = parse (applyLexer fullLexer) + +-- |CPS-Lexer for Curry +lexer :: Lexer Token a +lexer = skipWhiteSpace True -- skip comments + +-- |CPS-Lexer for Curry which also lexes comments. +-- This lexer is useful for documentation tools. +fullLexer :: Lexer Token a +fullLexer = skipWhiteSpace False -- lex comments + +-- |Lex the source code and skip whitespaces +skipWhiteSpace :: Bool -> Lexer Token a +skipWhiteSpace skipComments suc fail = skip + where + skip sp [] bol = suc sp (tok EOF) sp [] bol + skip sp c@('-':'-':_) _ = lexLineComment sucComment fail sp c True + skip sp c@('{':'-':'#':_) bol = lexPragma noPragma suc fail sp c bol + skip sp c@('{':'-':_) bol = lexNestedComment sucComment fail sp c bol + skip sp cs@(c:s) bol + | c == '\t' = warnP sp "Tab character" skip (tabSpan sp) s bol + | c == '\n' = skip (nlSpan sp) s True + | isSpace c = skip (nextSpan sp) s bol + | bol = lexBOL suc fail sp cs bol + | otherwise = lexToken suc fail sp cs bol + sucComment = if skipComments then (\ _suc _fail -> skip) else suc + noPragma = lexNestedComment sucComment fail + +-- Lex a line comment +lexLineComment :: Lexer Token a +lexLineComment suc _ sp str = case break (== '\n') str of + (c, s ) -> suc sp (lineCommentTok c) (incrSpan sp $ length c) s + +lexPragma :: P a -> Lexer Token a +lexPragma noPragma suc fail sp0 str = pragma (incrSpan sp0 3) (drop 3 str) + where + skip = noPragma sp0 str + pragma sp [] = fail sp0 "Unterminated pragma" sp [] + pragma sp cs@(c : s) + | c == '\t' = pragma (tabSpan sp) s + | c == '\n' = pragma (nlSpan sp) s + | isSpace c = pragma (nextSpan sp) s + | isAlpha c = case Map.lookup (map toLower prag) pragmas of + Nothing -> skip + Just PragmaOptions -> lexOptionsPragma sp0 suc fail sp1 rest + Just t -> suc sp0 (tok t) sp1 rest + | otherwise = skip + where + (prag, rest) = span isAlphaNum cs + sp1 = incrSpan sp (length prag) + +lexOptionsPragma :: Span -> Lexer Token a +lexOptionsPragma sp0 _ fail sp [] = fail sp0 "Unterminated Options pragma" sp [] +lexOptionsPragma sp0 suc fail sp (c : s) + | c == '\t' = lexArgs Nothing (tabSpan sp) s + | c == '\n' = lexArgs Nothing (nlSpan sp) s + | isSpace c = lexArgs Nothing (nextSpan sp) s + | c == '_' = let (tool, s1) = span isIdentChar s + in lexArgs (Just tool) (incrSpan sp (length tool + 1)) s1 + | otherwise = fail sp0 "Malformed Options pragma" sp s + where + lexArgs mbTool = lexRaw "" + where + lexRaw s0 sp1 r = case hash of + [] -> fail sp0 "End-of-file inside pragma" (incrSpan sp1 len) [] + '#':'-':'}':_ -> token (trim $ s0 ++ opts) (incrSpan sp1 len) hash + _ -> lexRaw (s0 ++ opts ++ "#") (incrSpan sp1 (len + 1)) (drop 1 hash) + where + (opts, hash) = span (/= '#') r + len = length opts + token = suc sp0 . pragmaOptionsTok mbTool + trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +-- Lex a nested comment +lexNestedComment :: Lexer Token a +lexNestedComment suc fail sp0 = lnc (0 :: Integer) id sp0 + where + -- d : nesting depth + -- comm: comment already lexed as functional list + lnc d comm sp str = case (d, str) of + (_, []) -> fail sp0 "Unterminated nested comment" sp [] + (1, '-':'}':s) -> suc sp0 (nestedCommentTok (comm "-}")) (incrSpan sp 2) s + (_, '{':'-':s) -> cont (d+1) ("{-" ++) (incrSpan sp 2) s + (_, '-':'}':s) -> cont (d-1) ("-}" ++) (incrSpan sp 2) s + (_, c@'\t' :s) -> cont d (c:) (tabSpan sp) s + (_, c@'\n' :s) -> cont d (c:) (nlSpan sp) s + (_, c :s) -> cont d (c:) (nextSpan sp) s + where cont d' comm' = lnc d' (comm . comm') + +-- Lex tokens at the beginning of a line, managing layout. +lexBOL :: Lexer Token a +lexBOL suc fail sp s _ [] = lexToken suc fail sp s False [] +lexBOL suc fail sp s _ ctxt@(n:rest) + | col < n = suc sp (tok VRightBrace) sp s True rest + | col == n = lexSemiOrWhere suc fail sp s False ctxt + | otherwise = lexToken suc fail sp s False ctxt + where col = column (span2Pos sp) + +lexSemiOrWhere :: Lexer Token a +lexSemiOrWhere suc _ sp ('w':'h':'e':'r':'e':s@(c:_)) + | not (isIdentChar c) = suc sp (tok KW_where) sp s +lexSemiOrWhere suc _ sp s = suc sp (tok VSemicolon) sp s + +-- Lex a single 'Token' +lexToken :: Lexer Token a +lexToken suc _ sp [] = suc sp (tok EOF) sp [] +lexToken suc fail sp cs@(c:s) + | take 3 cs == "#-}" = suc sp (tok PragmaEnd) (incrSpan sp 3) (drop 3 cs) + | c == '(' = token LeftParen + | c == ')' = token RightParen + | c == ',' = token Comma + | c == ';' = token Semicolon + | c == '[' = token LeftBracket + | c == ']' = token RightBracket + | c == '_' = token Underscore + | c == '`' = token Backquote + | c == '{' = token LeftBrace + | c == '}' = lexRightBrace (suc sp) (nextSpan sp) s + | c == '\'' = lexChar sp suc fail (nextSpan sp) s + | c == '\"' = lexString sp suc fail (nextSpan sp) s + | isAlpha c = lexIdent (suc sp) sp cs + | isSymbolChar c = lexSymbol (suc sp) sp cs + | isDigit c = lexNumber (suc sp) sp cs + | otherwise = fail sp ("Illegal character " ++ show c) sp s + where token t = suc sp (tok t) (nextSpan sp) s + +-- Lex a right brace and pop from the context stack +lexRightBrace :: (Token -> P a) -> P a +lexRightBrace cont sp s bol ctxt = cont (tok RightBrace) sp s bol (drop 1 ctxt) + +-- Lex an identifier +lexIdent :: (Token -> P a) -> P a +lexIdent cont sp s = maybe (lexOptQual cont (token Id) [ident]) (cont . token) + (Map.lookup ident keywordsSpecialIds) + (incrSpan sp $ length ident) rest + where (ident, rest) = span isIdentChar s + token t = idTok t [] ident + +-- Lex a symbol +lexSymbol :: (Token -> P a) -> P a +lexSymbol cont sp s = cont + (idTok (Map.findWithDefault Sym sym reservedSpecialOps) [] sym) + (incrSpan sp $ length sym) rest + where (sym, rest) = span isSymbolChar s + +-- Lex an optionally qualified entity (identifier or symbol). +lexOptQual :: (Token -> P a) -> Token -> [String] -> P a +lexOptQual cont token mIdent sp cs@('.':c:s) + | isAlpha c = lexQualIdent cont identCont mIdent + (nextSpan sp) (c:s) + | isSymbolChar c && c /= '.' = lexQualSymbol cont identCont mIdent + (nextSpan sp) (c:s) +-- | c `elem` ":[(" = lexQualPrimitive cont token mIdent (nextSpan sp) (c:s) + where identCont _ _ = cont token sp cs +lexOptQual cont token mIdent sp cs@('.':'.':c:s) + | isSymbolChar c = lexQualSymbol cont identCont mIdent + (nextSpan sp) ('.':c:s) + | not $ isIdentChar c = lexQualSymbol cont identCont mIdent + (nextSpan sp) ('.':c:s) + where identCont _ _ = cont token sp cs +lexOptQual cont token _ sp cs = cont token sp cs + +-- Lex a qualified identifier. +lexQualIdent :: (Token -> P a) -> P a -> [String] -> P a +lexQualIdent cont identCont mIdent sp s = + maybe (lexOptQual cont (idTok QId mIdent ident) (mIdent ++ [ident])) + (const identCont) + (Map.lookup ident keywords) + (incrSpan sp (length ident)) rest + where (ident, rest) = span isIdentChar s + +-- Lex a qualified symbol. +lexQualSymbol :: (Token -> P a) -> P a -> [String] -> P a +lexQualSymbol cont identCont mIdent sp s = + maybe (cont (idTok QSym mIdent sym)) (const identCont) + (Map.lookup sym reservedOps) + (incrSpan sp (length sym)) rest + where (sym, rest) = span isSymbolChar s + +-- --------------------------------------------------------------------------- +-- /Note:/ since Curry allows an unlimited range of integer numbers, +-- read numbers must be converted to Haskell type 'Integer'. +-- --------------------------------------------------------------------------- + +-- Lex a numeric literal. +lexNumber :: (Token -> P a) -> P a +lexNumber cont sp ('0':c:s) + | c `elem` "bB" = lexBinary cont nullCont (incrSpan sp 2) s + | c `elem` "oO" = lexOctal cont nullCont (incrSpan sp 2) s + | c `elem` "xX" = lexHexadecimal cont nullCont (incrSpan sp 2) s + where nullCont _ _ = cont (intTok 10 "0") (nextSpan sp) (c:s) +lexNumber cont sp s = lexOptFraction cont (intTok 10 digits) digits + (incrSpan sp $ length digits) rest + where (digits, rest) = span isDigit s + +-- Lex a binary literal. +lexBinary :: (Token -> P a) -> P a -> P a +lexBinary cont nullCont sp s + | null digits = nullCont undefined undefined + | otherwise = cont (intTok 2 digits) (incrSpan sp $ length digits) rest + where (digits, rest) = span isBinDigit s + isBinDigit c = c >= '0' && c <= '1' + +-- Lex an octal literal. +lexOctal :: (Token -> P a) -> P a -> P a +lexOctal cont nullCont sp s + | null digits = nullCont undefined undefined + | otherwise = cont (intTok 8 digits) (incrSpan sp $ length digits) rest + where (digits, rest) = span isOctDigit s + +-- Lex a hexadecimal literal. +lexHexadecimal :: (Token -> P a) -> P a -> P a +lexHexadecimal cont nullCont sp s + | null digits = nullCont undefined undefined + | otherwise = cont (intTok 16 digits) (incrSpan sp $ length digits) rest + where (digits, rest) = span isHexDigit s + +-- Lex an optional fractional part (float literal). +lexOptFraction :: (Token -> P a) -> Token -> String -> P a +lexOptFraction cont _ mant sp ('.':c:s) + | isDigit c = lexOptExponent cont (floatTok mant frac 0 "") mant frac + (incrSpan sp (length frac+1)) rest + where (frac,rest) = span isDigit (c:s) +lexOptFraction cont token mant sp (c:s) + | c `elem` "eE" = lexSignedExponent cont intCont mant "" [c] (nextSpan sp) s + where intCont _ _ = cont token sp (c:s) +lexOptFraction cont token _ sp s = cont token sp s + +-- Lex an optional exponent (float literal). +lexOptExponent :: (Token -> P a) -> Token -> String -> String -> P a +lexOptExponent cont token mant frac sp (c:s) + | c `elem` "eE" = lexSignedExponent cont floatCont mant frac [c] (nextSpan sp) s + where floatCont _ _ = cont token sp (c:s) +lexOptExponent cont token _ _ sp s = cont token sp s + +-- Lex an exponent with sign (float literal). +lexSignedExponent :: (Token -> P a) -> P a -> String -> String -> String + -> P a +lexSignedExponent cont floatCont mant frac e sp str = case str of + ('+':c:s) | isDigit c -> lexExpo (e ++ "+") id (nextSpan sp) (c:s) + ('-':c:s) | isDigit c -> lexExpo (e ++ "-") negate (nextSpan sp) (c:s) + (c:_) | isDigit c -> lexExpo e id sp str + _ -> floatCont sp str + where lexExpo = lexExponent cont mant frac + +-- Lex an exponent without sign (float literal). +lexExponent :: (Token -> P a) -> String -> String -> String -> (Int -> Int) + -> P a +lexExponent cont mant frac e expSign sp s = + cont (floatTok mant frac expo (e ++ digits)) (incrSpan sp $ length digits) rest + where (digits, rest) = span isDigit s + expo = expSign (convertIntegral 10 digits) + +-- Lex a character literal. +lexChar :: Span -> Lexer Token a +lexChar sp0 _ fail sp [] = fail sp0 "Illegal character constant" sp [] +lexChar sp0 success fail sp (c:s) + | c == '\\' = lexEscape sp (\d o -> lexCharEnd d o sp0 success fail) + fail (nextSpan sp) s + | c == '\n' = fail sp0 "Illegal character constant" sp (c:s) + | c == '\t' = lexCharEnd c "\t" sp0 success fail (tabSpan sp) s + | otherwise = lexCharEnd c [c] sp0 success fail (nextSpan sp) s + +-- Lex the end of a character literal. +lexCharEnd :: Char -> String -> Span -> Lexer Token a +lexCharEnd c o sp0 suc _ sp ('\'':s) = suc sp0 (charTok c o) (nextSpan sp) s +lexCharEnd _ _ sp0 _ fail sp s = + fail sp0 "Improperly terminated character constant" sp s + +-- Lex a String literal. +lexString :: Span -> Lexer Token a +lexString sp0 suc fail = lexStringRest "" id + where + lexStringRest _ _ sp [] = improperTermination sp + lexStringRest s0 so sp (c:s) + | c == '\n' = improperTermination sp + | c == '\"' = suc sp0 (stringTok (reverse s0) (so "")) (nextSpan sp) s + | c == '\\' = lexStringEscape sp s0 so lexStringRest fail (nextSpan sp) s + | c == '\t' = lexStringRest (c:s0) (so . (c:)) (tabSpan sp) s + | otherwise = lexStringRest (c:s0) (so . (c:)) (nextSpan sp) s + improperTermination sp = fail sp0 "Improperly terminated string constant" sp [] + +-- Lex an escaped character inside a string. +lexStringEscape :: Span -> String -> (String -> String) + -> (String -> (String -> String) -> P a) + -> FailP a -> P a +lexStringEscape sp0 _ _ _ fail sp [] = lexEscape sp0 undefined fail sp [] +lexStringEscape sp0 s0 so suc fail sp cs@(c:s) + -- The escape sequence represents an empty character of length zero + | c == '&' = suc s0 (so . ("\\&" ++)) (nextSpan sp) s + | isSpace c = lexStringGap so (suc s0) fail sp cs + | otherwise = lexEscape sp0 (\ c' s' -> suc (c': s0) (so . (s' ++))) fail sp cs + +-- Lex a string gap. +lexStringGap :: (String -> String) -> ((String -> String) -> P a) + -> FailP a -> P a +lexStringGap _ _ fail sp [] = fail sp "End-of-file in string gap" sp [] +lexStringGap so suc fail sp (c:s) + | c == '\\' = suc (so . (c:)) (nextSpan sp) s + | c == '\t' = lexStringGap (so . (c:)) suc fail (tabSpan sp) s + | c == '\n' = lexStringGap (so . (c:)) suc fail (nlSpan sp) s + | isSpace c = lexStringGap (so . (c:)) suc fail (nextSpan sp) s + | otherwise = fail sp ("Illegal character in string gap: " ++ show c) sp s + +-- Lex an escaped character. +lexEscape :: Span -> (Char -> String -> P a) -> FailP a -> P a +lexEscape sp0 suc fail sp str = case str of + -- character escape + ('a' :s) -> suc '\a' "\\a" (nextSpan sp) s + ('b' :s) -> suc '\b' "\\b" (nextSpan sp) s + ('f' :s) -> suc '\f' "\\f" (nextSpan sp) s + ('n' :s) -> suc '\n' "\\n" (nextSpan sp) s + ('r' :s) -> suc '\r' "\\r" (nextSpan sp) s + ('t' :s) -> suc '\t' "\\t" (nextSpan sp) s + ('v' :s) -> suc '\v' "\\v" (nextSpan sp) s + ('\\':s) -> suc '\\' "\\\\" (nextSpan sp) s + ('"' :s) -> suc '\"' "\\\"" (nextSpan sp) s + ('\'':s) -> suc '\'' "\\\'" (nextSpan sp) s + -- control characters + ('^':c:s) | isControlEsc c -> controlEsc c (incrSpan sp 2) s + -- numeric escape + ('o':c:s) | isOctDigit c -> numEsc 8 isOctDigit ("\\o" ++) (nextSpan sp) (c:s) + ('x':c:s) | isHexDigit c -> numEsc 16 isHexDigit ("\\x" ++) (nextSpan sp) (c:s) + (c:s) | isDigit c -> numEsc 10 isDigit ("\\" ++) sp (c:s) + -- ascii escape + _ -> asciiEscape sp0 suc fail sp str + where numEsc = numEscape sp0 suc fail + controlEsc c = suc (chr (ord c `mod` 32)) ("\\^" ++ [c]) + isControlEsc c = isUpper c || c `elem` "@[\\]^_" + +numEscape :: Span -> (Char -> String -> P a) -> FailP a -> Int + -> (Char -> Bool) -> (String -> String) -> P a +numEscape sp0 suc fail b isDigit' so sp s + | n >= ord minBound && n <= ord maxBound + = suc (chr n) (so digits) (incrSpan sp $ length digits) rest + | otherwise + = fail sp0 "Numeric escape out-of-range" sp s + where (digits, rest) = span isDigit' s + n = convertIntegral b digits + +asciiEscape :: Span -> (Char -> String -> P a) -> FailP a -> P a +asciiEscape sp0 suc fail sp str = case str of + ('N':'U':'L':s) -> suc '\NUL' "\\NUL" (incrSpan sp 3) s + ('S':'O':'H':s) -> suc '\SOH' "\\SOH" (incrSpan sp 3) s + ('S':'T':'X':s) -> suc '\STX' "\\STX" (incrSpan sp 3) s + ('E':'T':'X':s) -> suc '\ETX' "\\ETX" (incrSpan sp 3) s + ('E':'O':'T':s) -> suc '\EOT' "\\EOT" (incrSpan sp 3) s + ('E':'N':'Q':s) -> suc '\ENQ' "\\ENQ" (incrSpan sp 3) s + ('A':'C':'K':s) -> suc '\ACK' "\\ACK" (incrSpan sp 3) s + ('B':'E':'L':s) -> suc '\BEL' "\\BEL" (incrSpan sp 3) s + ('B':'S' :s) -> suc '\BS' "\\BS" (incrSpan sp 2) s + ('H':'T' :s) -> suc '\HT' "\\HT" (incrSpan sp 2) s + ('L':'F' :s) -> suc '\LF' "\\LF" (incrSpan sp 2) s + ('V':'T' :s) -> suc '\VT' "\\VT" (incrSpan sp 2) s + ('F':'F' :s) -> suc '\FF' "\\FF" (incrSpan sp 2) s + ('C':'R' :s) -> suc '\CR' "\\CR" (incrSpan sp 2) s + ('S':'O' :s) -> suc '\SO' "\\SO" (incrSpan sp 2) s + ('S':'I' :s) -> suc '\SI' "\\SI" (incrSpan sp 2) s + ('D':'L':'E':s) -> suc '\DLE' "\\DLE" (incrSpan sp 3) s + ('D':'C':'1':s) -> suc '\DC1' "\\DC1" (incrSpan sp 3) s + ('D':'C':'2':s) -> suc '\DC2' "\\DC2" (incrSpan sp 3) s + ('D':'C':'3':s) -> suc '\DC3' "\\DC3" (incrSpan sp 3) s + ('D':'C':'4':s) -> suc '\DC4' "\\DC4" (incrSpan sp 3) s + ('N':'A':'K':s) -> suc '\NAK' "\\NAK" (incrSpan sp 3) s + ('S':'Y':'N':s) -> suc '\SYN' "\\SYN" (incrSpan sp 3) s + ('E':'T':'B':s) -> suc '\ETB' "\\ETB" (incrSpan sp 3) s + ('C':'A':'N':s) -> suc '\CAN' "\\CAN" (incrSpan sp 3) s + ('E':'M' :s) -> suc '\EM' "\\EM" (incrSpan sp 2) s + ('S':'U':'B':s) -> suc '\SUB' "\\SUB" (incrSpan sp 3) s + ('E':'S':'C':s) -> suc '\ESC' "\\ESC" (incrSpan sp 3) s + ('F':'S' :s) -> suc '\FS' "\\FS" (incrSpan sp 2) s + ('G':'S' :s) -> suc '\GS' "\\GS" (incrSpan sp 2) s + ('R':'S' :s) -> suc '\RS' "\\RS" (incrSpan sp 2) s + ('U':'S' :s) -> suc '\US' "\\US" (incrSpan sp 2) s + ('S':'P' :s) -> suc '\SP' "\\SP" (incrSpan sp 2) s + ('D':'E':'L':s) -> suc '\DEL' "\\DEL" (incrSpan sp 3) s + s -> fail sp0 "Illegal escape sequence" sp s diff --git a/src/Curry/Syntax/Parser.hs b/src/Curry/Syntax/Parser.hs new file mode 100644 index 0000000000000000000000000000000000000000..351dc09d6898d6527dd2225467be89e3415e4b45 --- /dev/null +++ b/src/Curry/Syntax/Parser.hs @@ -0,0 +1,1428 @@ +{- | + Module : $Header$ + Description : A Parser for Curry + Copyright : (c) 1999 - 2004 Wolfgang Lux + 2005 Martin Engelke + 2011 - 2015 Björn Peemöller + 2016 - 2017 Finn Teegen + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + The Curry parser is implemented using the (mostly) LL(1) parsing + combinators implemented in 'Curry.Base.LLParseComb'. +-} +module Curry.Syntax.Parser + ( parseSource, parseHeader, parsePragmas, parseInterface, parseGoal + ) where + +import Curry.Base.Ident +import Curry.Base.Monad (CYM) +import Curry.Base.Position (Position(..), getPosition, setPosition, incr) +import Curry.Base.LLParseComb +import Curry.Base.Span hiding (file) -- clash with Position.file +import Curry.Base.SpanInfo + +import Curry.Syntax.Extension +import Curry.Syntax.Lexer (Token (..), Category (..), Attributes (..), lexer) +import Curry.Syntax.Type + +-- |Parse a 'Module' +parseSource :: FilePath -> String -> CYM (Module ()) +parseSource = fullParser (mkMod <$> moduleHeader <*> layout moduleDecls) lexer + where mkMod f ((im, ds), lay) = f lay im ds + +-- |Parse only pragmas of a 'Module' +parsePragmas :: FilePath -> String -> CYM (Module ()) +parsePragmas + = prefixParser ((\ps sp -> setEndPosition NoPos + (Module (spanInfo sp []) WhitespaceLayout + ps mainMIdent Nothing [] [])) + <$> modulePragmas <*> spanPosition) + lexer + +-- |Parse a 'Module' header +parseHeader :: FilePath -> String -> CYM (Module ()) +parseHeader = prefixParser + (mkMod <$> moduleHeader <*> startLayout importDecls) lexer + where + importDecls = mkImport <$> many ((,) <$> importDecl + <*> many (spanPosition <*-> semicolon)) + mkImport xs = let (im, spss) = unzip xs in (im, concat spss) + mkMod f (im, lay) = f lay im [] + +-- |Parse an 'Interface' +parseInterface :: FilePath -> String -> CYM Interface +parseInterface = fullParser interface lexer + +-- |Parse a 'Goal' +parseGoal :: String -> CYM (Goal ()) +parseGoal = fullParser goal lexer "" + +-- --------------------------------------------------------------------------- +-- Module header +-- --------------------------------------------------------------------------- + +-- |Parser for a module header +moduleHeader :: Parser a Token + (LayoutInfo -> [ImportDecl] -> [Decl b] -> Module b) +moduleHeader = + (\sp ps (m, es, inf) lay is ds -> updateEndPos $ + Module (spanInfo sp inf) lay ps m es is ds) + <$> spanPosition + <*> modulePragmas + <*> header + where header = (\sp1 m es sp2 -> (m, es, [sp1,sp2])) + <$> tokenSpan KW_module + <*> modIdent + <*> option exportSpec + <*> spanPosition + <*-> expectWhere + `opt` (mainMIdent, Nothing, []) + +modulePragmas :: Parser a Token [ModulePragma] +modulePragmas = many (languagePragma <|> optionsPragma) + +languagePragma :: Parser a Token ModulePragma +languagePragma = languagePragma' + <$> tokenSpan PragmaLanguage + <*> (languageExtension `sepBy1Sp` comma) + <*> tokenSpan PragmaEnd + where languageExtension = classifyExtension <$> ident + languagePragma' sp1 (ex, ss) sp2 = updateEndPos $ + LanguagePragma (spanInfo sp1 (sp1 : ss ++ [sp2])) ex + +-- TODO The span info is not 100% complete due to the lexer +-- combining OPTIONS, toolVal and toolArgs +optionsPragma :: Parser a Token ModulePragma +optionsPragma = optionsPragma' + <$> spanPosition + <*> token PragmaOptions + <*> tokenSpan PragmaEnd + where optionsPragma' sp1 a sp2 = updateEndPos $ + OptionsPragma (spanInfo sp1 [sp1, sp2]) + (classifyTool <$> toolVal a) + (toolArgs a) + +-- |Parser for an export specification +exportSpec :: Parser a Token ExportSpec +exportSpec = exportSpec' <$> spanPosition <*> parensSp (export `sepBySp` comma) + where exportSpec' sp1 ((ex, ss),sp2,sp3) = updateEndPos $ + Exporting (spanInfo sp1 (sp2:(ss ++ [sp3]))) ex + +-- |Parser for an export item +export :: Parser a Token Export +export = qtycon <**> (tcExportWith <$> parensSp spec `opt` tcExport) + <|> tcExport <$> qfun <\> qtycon + <|> exportModule' <$> tokenSpan KW_module <*> modIdent + where spec = (\sp -> (ExportTypeAll , [sp])) <$> tokenSpan DotDot + <|> (\(c, ss) -> (exportTypeWith' c, ss )) <$> con `sepBySp` comma + tcExport qtc = updateEndPos $ Export (fromSrcSpan (getSrcSpan qtc)) qtc + tcExportWith ((spc, ss), sp1, sp2) qtc = + updateEndPos $ setSrcInfoPoints (sp1 : (ss ++ [sp2])) $ + spc (fromSrcSpan (getSrcSpan qtc)) qtc + exportTypeWith' c spi qtc = ExportTypeWith spi qtc c + exportModule' sp = updateEndPos . ExportModule (spanInfo sp [sp]) + +moduleDecls :: Parser a Token (([ImportDecl], [Decl ()]), [Span]) +moduleDecls = mkImpDecl <$> importDecl + <*> (moduleDecls' `opt` ([], [], [])) + <|> mkTopDecl <$> topDecls + where + mkImpDecl i (is, ds, sps) = ((i:is, ds), sps) + mkTopDecl (ds, sps) = (([], ds), sps) + + moduleDecls' = mkDecls <$> spanPosition <*-> semicolon <*> moduleDecls + mkDecls sp ((im, ds), sps) = (im, ds, sp:sps) + +-- |Parser for a single import declaration +importDecl :: Parser a Token ImportDecl +importDecl = importDecl' + <$> tokenSpan KW_import + <*> option (tokenSpan Id_qualified) + <*> modIdent + <*> option ((,) <$> tokenSpan Id_as <*> modIdent) + <*> option importSpec + where + importDecl' sp1 (Just sp2) mid (Just (sp3, alias)) = updateEndPos . + ImportDecl (spanInfo sp1 [sp1, sp2, sp3]) mid True (Just alias) + importDecl' sp1 Nothing mid (Just (sp3, alias)) = updateEndPos . + ImportDecl (spanInfo sp1 [sp1, sp3]) mid False (Just alias) + importDecl' sp1 (Just sp2) mid Nothing = updateEndPos . + ImportDecl (spanInfo sp1 [sp1, sp2]) mid True Nothing + importDecl' sp1 Nothing mid Nothing = updateEndPos . + ImportDecl (spanInfo sp1 [sp1]) mid False Nothing + +-- |Parser for an import specification +importSpec :: Parser a Token ImportSpec +importSpec = spanPosition + <**> (hiding' <$-> token Id_hiding `opt` importing') + <*> parensSp (importSp `sepBySp` comma) + where + hiding' sp1 ((specs, ss), sp2, sp3) = updateEndPos $ + Hiding (spanInfo sp1 (sp1 : sp2 : (ss ++ [sp3]))) specs + importing' sp1 ((specs, ss), sp2, sp3) = updateEndPos $ + Importing (spanInfo sp1 ( sp2 : (ss ++ [sp3]))) specs + +importSp :: Parser a Token Import +importSp = tycon <**> (tcImportWith <$> parensSp spec `opt` tcImport) + <|> tcImport <$> fun <\> tycon + where spec = (\sp -> (ImportTypeAll , [sp])) <$> tokenSpan DotDot + <|> (\(c, ss) -> (importTypeWith' c, ss )) <$> con `sepBySp` comma + tcImport tc = updateEndPos $ Import (fromSrcSpan (getSrcSpan tc)) tc + tcImportWith ((spc, ss), sp1, sp2) tc = + updateEndPos $ setSrcInfoPoints (sp1 : (ss ++ [sp2])) $ + spc (fromSrcSpan (getSrcSpan tc)) tc + importTypeWith' c spi tc = ImportTypeWith spi tc c +-- --------------------------------------------------------------------------- +-- Interfaces +-- --------------------------------------------------------------------------- + +-- |Parser for an interface +interface :: Parser a Token Interface +interface = uncurry <$> intfHeader <*> braces intfDecls + +intfHeader :: Parser a Token ([IImportDecl] -> [IDecl] -> Interface) +intfHeader = Interface <$-> token Id_interface <*> modIdent <*-> expectWhere + +intfDecls :: Parser a Token ([IImportDecl], [IDecl]) +intfDecls = impDecl <$> iImportDecl + <*> (semicolon <-*> intfDecls `opt` ([], [])) + <|> (,) [] <$> intfDecl `sepBy` semicolon + where impDecl i (is, ds) = (i:is, ds) + +-- |Parser for a single interface import declaration +iImportDecl :: Parser a Token IImportDecl +iImportDecl = IImportDecl <$> tokenPos KW_import <*> modIdent + +-- |Parser for a single interface declaration +intfDecl :: Parser a Token IDecl +intfDecl = choice [ iInfixDecl, iHidingDecl, iDataDecl, iNewtypeDecl + , iTypeDecl , iFunctionDecl <\> token Id_hiding + , iClassDecl, iInstanceDecl ] + +-- |Parser for an interface infix declaration +iInfixDecl :: Parser a Token IDecl +iInfixDecl = infixDeclLhs iInfixDecl' <*> integer <*> qfunop + where iInfixDecl' sp = IInfixDecl (span2Pos sp) + +-- |Parser for an interface hiding declaration +iHidingDecl :: Parser a Token IDecl +iHidingDecl = tokenPos Id_hiding <**> (hDataDecl <|> hClassDecl) + where + hDataDecl = hiddenData <$-> token KW_data <*> withKind qtycon <*> many tyvar + hClassDecl = hiddenClass <$> classInstHead KW_class (withKind qtycls) clsvar + hiddenData (tc, k) tvs p = HidingDataDecl p tc k tvs + hiddenClass (_, _, cx, (qcls, k), tv) p = HidingClassDecl p cx qcls k tv + +-- |Parser for an interface data declaration +iDataDecl :: Parser a Token IDecl +iDataDecl = iTypeDeclLhs IDataDecl KW_data <*> constrs <*> iHiddenPragma + where constrs = equals <-*> constrDecl `sepBy1` bar `opt` [] + +-- |Parser for an interface newtype declaration +iNewtypeDecl :: Parser a Token IDecl +iNewtypeDecl = iTypeDeclLhs INewtypeDecl KW_newtype + <*-> equals <*> newConstrDecl <*> iHiddenPragma + +-- |Parser for an interface type synonym declaration +iTypeDecl :: Parser a Token IDecl +iTypeDecl = iTypeDeclLhs ITypeDecl KW_type + <*-> equals <*> type0 + +-- |Parser for an interface hiding pragma +iHiddenPragma :: Parser a Token [Ident] +iHiddenPragma = token PragmaHiding + <-*> (con `sepBy` comma) + <*-> token PragmaEnd + `opt` [] + +-- |Parser for an interface function declaration +iFunctionDecl :: Parser a Token IDecl +iFunctionDecl = IFunctionDecl <$> position <*> qfun <*> option iMethodPragma + <*> arity <*-> token DoubleColon <*> qualType + +-- |Parser for an interface method pragma +iMethodPragma :: Parser a Token Ident +iMethodPragma = token PragmaMethod <-*> clsvar <*-> token PragmaEnd + +-- |Parser for function's arity +arity :: Parser a Token Int +arity = int `opt` 0 + +iTypeDeclLhs :: (Position -> QualIdent -> Maybe KindExpr -> [Ident] -> a) + -> Category -> Parser b Token a +iTypeDeclLhs f kw = f' <$> tokenPos kw <*> withKind qtycon <*> many tyvar + where f' p (tc, k) = f p tc k + +-- |Parser for an interface class declaration +iClassDecl :: Parser a Token IDecl +iClassDecl = (\(sp, _, cx, (qcls, k), tv) -> + IClassDecl (span2Pos sp) cx qcls k tv) + <$> classInstHead KW_class (withKind qtycls) clsvar + <*> braces (iMethod `sepBy` semicolon) + <*> iClassHidden + +-- |Parser for an interface method declaration +iMethod :: Parser a Token IMethodDecl +iMethod = IMethodDecl <$> position + <*> fun <*> option int <*-> token DoubleColon <*> qualType + +-- |Parser for an interface hiding pragma +iClassHidden :: Parser a Token [Ident] +iClassHidden = token PragmaHiding + <-*> (fun `sepBy` comma) + <*-> token PragmaEnd + `opt` [] + +-- |Parser for an interface instance declaration +iInstanceDecl :: Parser a Token IDecl +iInstanceDecl = (\(sp, _, cx, qcls, inst) -> + IInstanceDecl (span2Pos sp) cx qcls inst) + <$> classInstHead KW_instance qtycls type2 + <*> braces (iImpl `sepBy` semicolon) + <*> option iModulePragma + +-- |Parser for an interface method implementation +iImpl :: Parser a Token IMethodImpl +iImpl = (,) <$> fun <*> arity + +iModulePragma :: Parser a Token ModuleIdent +iModulePragma = token PragmaModule <-*> modIdent <*-> token PragmaEnd + +-- --------------------------------------------------------------------------- +-- Top-Level Declarations +-- --------------------------------------------------------------------------- + +topDecls :: Parser a Token ([Decl ()], [Span]) +topDecls = topDecl `sepBySp` semicolon + +topDecl :: Parser a Token (Decl ()) +topDecl = choice [ dataDecl, externalDataDecl, newtypeDecl, typeDecl + , classDecl, instanceDecl, defaultDecl + , infixDecl, functionDecl ] + +dataDecl :: Parser a Token (Decl ()) +dataDecl = combineWithSpans + <$> typeDeclLhs dataDecl' KW_data + <*> ((addSpan <$> tokenSpan Equals <*> constrs) `opt` ([],[])) + <*> deriv + where constrs = constrDecl `sepBy1Sp` bar + dataDecl' sp = DataDecl (spanInfo sp [sp]) + +externalDataDecl :: Parser a Token (Decl ()) +externalDataDecl = decl <$> tokenSpan KW_external <*> typeDeclLhs (,,) KW_data + where decl sp1 (sp2, tc, tvs) = updateEndPos $ + ExternalDataDecl (spanInfo sp1 [sp1, sp2]) tc tvs + +newtypeDecl :: Parser a Token (Decl ()) +newtypeDecl = combineWithSpans + <$> typeDeclLhs newtypeDecl' KW_newtype + <*> ((\sp c -> (c, [sp])) <$> tokenSpan Equals <*> newConstrDecl) + <*> deriv + where newtypeDecl' sp = NewtypeDecl (spanInfo sp [sp]) + +combineWithSpans :: HasSpanInfo a => + (t1 -> t2 -> a) -> (t1, [Span]) -> (t2, [Span]) -> a +combineWithSpans df (cs, sps1) (cls, sps2) + = updateEndPos $ setSrcInfoPoints (getSrcInfoPoints res ++ sps1 ++ sps2) res + where res = df cs cls + +typeDecl :: Parser a Token (Decl ()) +typeDecl = typeDeclLhs typeDecl' KW_type <*> tokenSpan Equals <*> type0 + where typeDecl' sp1 tyc tyv sp2 txp = updateEndPos $ + TypeDecl (spanInfo sp1 [sp1, sp2]) tyc tyv txp + +typeDeclLhs :: (Span -> Ident -> [Ident] -> a) -> Category + -> Parser b Token a +typeDeclLhs f kw = f <$> tokenSpan kw <*> tycon <*> many anonOrTyvar + +constrDecl :: Parser a Token ConstrDecl +constrDecl = spanPosition <**> constr + where + constr = conId <**> identDecl + <|> tokenSpan LeftParen <**> parenDecl + <|> type1 <\> conId <\> leftParen <**> opDecl + identDecl = many type2 <**> (conType <$> opDecl `opt` conDecl) + <|> recDecl <$> recFields + parenDecl = conOpDeclPrefix + <$> conSym <*> tokenSpan RightParen <*> type2 <*> type2 + <|> tupleType <**> (tokenSpan RightParen <**> opDeclParen) + opDecl = conOpDecl <$> conop <*> type1 + opDeclParen = conOpDeclParen <$> conop <*> type1 + recFields = layoutOff <-*> bracesSp (fieldDecl `sepBySp` comma) + conType f tys c = f $ foldl mkApply (mkConstructorType $ qualify c) tys + mkApply t1 t2 = updateEndPos $ ApplyType (fromSrcSpan (getSrcSpan t1)) t1 t2 + mkConstructorType qid = ConstructorType (fromSrcSpan (getSrcSpan qid)) qid + conDecl tys c sp = updateEndPos $ + ConstrDecl (SpanInfo sp []) c tys + conOpDecl op ty2 ty1 sp = updateEndPos $ + ConOpDecl (SpanInfo sp []) ty1 op ty2 + conOpDeclParen op ty2 sp1 ty1 sp2 sp5 = updateEndPos $ + ConOpDecl (SpanInfo sp5 [sp2, sp1]) ty1 op ty2 + conOpDeclPrefix op sp1 ty1 ty2 sp2 sp3 = updateEndPos $ + ConOpDecl (SpanInfo sp3 [sp2, sp1]) ty1 op ty2 + recDecl ((fs, ss), sp1, sp2) c sp3 = updateEndPos $ + RecordDecl (SpanInfo sp3 (sp1 : ss ++ [sp2])) c fs + +fieldDecl :: Parser a Token FieldDecl +fieldDecl = mkFieldDecl <$> spanPosition <*> labels + <*> tokenSpan DoubleColon <*> type0 + where labels = fun `sepBy1Sp` comma + mkFieldDecl sp1 (idt,ss) sp2 ty = updateEndPos $ + FieldDecl (spanInfo sp1 (ss ++ [sp2])) idt ty + +newConstrDecl :: Parser a Token NewConstrDecl +newConstrDecl = spanPosition <**> (con <**> newConstr) + where newConstr = newConDecl <$> type2 + <|> newRecDecl <$> newFieldDecl + newConDecl ty c sp = updateEndPos $ NewConstrDecl (spanInfo sp []) c ty + newRecDecl ((idt, sp2, ty), sp3, sp4) c sp1 = updateEndPos $ + NewRecordDecl (spanInfo sp1 [sp3,sp2,sp4]) c (idt, ty) + +newFieldDecl :: Parser a Token ((Ident, Span, TypeExpr), Span, Span) +newFieldDecl = layoutOff <-*> bracesSp labelDecl + where labelDecl = (,,) <$> fun <*> tokenSpan DoubleColon <*> type0 + +deriv :: Parser a Token ([QualIdent], [Span]) +deriv = (addSpan <$> tokenSpan KW_deriving <*> classes) `opt` ([], []) + where classes = ((\q -> ([q], [])) <$> qtycls) + <|> ((\sp1 (qs, ss) sp2 -> (qs, sp1 : (ss ++ [sp2]))) + <$> tokenSpan LeftParen + <*> (qtycls `sepBySp` comma) + <*> tokenSpan RightParen) + +functionDecl :: Parser a Token (Decl ()) +functionDecl = spanPosition <**> decl + where decl = fun `sepBy1Sp` comma <**> funListDecl <|?> funRule + +funRule :: Parser a Token (Span -> Decl ()) +funRule = mkFunDecl <$> lhs <*> declRhs + where lhs = (\f -> + (f, updateEndPos $ FunLhs (fromSrcSpan (getSrcSpan f)) f [])) + <$> fun <|?> funLhs + +funListDecl :: Parser a Token (([Ident],[Span]) -> Span -> Decl ()) +funListDecl = typeSig <|> mkExtFun <$> tokenSpan KW_external + where mkExtFun sp1 (vs,ss) sp2 = updateEndPos $ + ExternalDecl (spanInfo sp2 (ss++[sp1])) (map (Var ()) vs) + + +typeSig :: Parser a Token (([Ident],[Span]) -> Span -> Decl ()) +typeSig = sig <$> tokenSpan DoubleColon <*> qualType + where sig sp1 qty (vs,ss) sp2 = updateEndPos $ + TypeSig (spanInfo sp2 (ss++[sp1])) vs qty + +mkFunDecl :: (Ident, Lhs ()) -> Rhs () -> Span -> Decl () +mkFunDecl (f, lhs) rhs' p = updateEndPos $ + FunctionDecl (spanInfo p []) () f [updateEndPos $ + Equation (spanInfo p []) lhs rhs'] + +funLhs :: Parser a Token (Ident, Lhs ()) +funLhs = mkFunLhs <$> fun <*> many1 pattern2 + <|?> flip ($ updateEndPos) <$> pattern1 <*> opLhs + <|?> curriedLhs + where + opLhs = opLHS funSym (gConSym <\> funSym) + <|> tokenSpan Backquote <**> + opLHSSp ((,) <$> funId <*> spanPosition + <*-> expectBackquote) + ((,) <$> qConId <\> funId <*> spanPosition + <*-> expectBackquote) + opLHS funP consP = mkOpLhs <$> funP <*> pattern0 + <|> mkInfixPat <$> consP <*> pattern1 <*> opLhs + opLHSSp funP consP = mkOpLhsSp <$> funP <*> pattern0 + <|> mkInfixPatSp <$> consP <*> pattern1 <*> opLhs + mkFunLhs f ts = (f , updateEndPos $ FunLhs (fromSrcSpan (getSrcSpan f)) f ts) + mkOpLhs op t2 f t1 = + let t1' = f t1 + in (op, updateEndPos $ OpLhs (fromSrcSpan (getSrcSpan t1')) t1' op t2) + mkInfixPat op t2 f g t1 = + f (g . InfixPattern (fromSrcSpan (getSrcSpan t1)) () t1 op) t2 + mkOpLhsSp (op, sp1) t2 sp2 f t1 = + let t1' = f t1 + in (op, updateEndPos $ + OpLhs (spanInfo (getSrcSpan t1') [sp2, sp1]) t1' op t2) + + mkInfixPatSp (op, sp1) t2 g sp2 f t1 = + g (f . InfixPattern (spanInfo (getSrcSpan t1) [sp2, sp1]) () t1 op) t2 + + +curriedLhs :: Parser a Token (Ident, Lhs ()) +curriedLhs = apLhs <$> parensSp funLhs <*> many1 pattern2 + where apLhs ((f, lhs), sp1, sp2) ts = + let spi = fromSrcSpan sp1 + in (f, updateEndPos $ setSrcInfoPoints [sp1, sp2] $ ApLhs spi lhs ts) + +declRhs :: Parser a Token (Rhs ()) +declRhs = rhs equals + +rhs :: Parser a Token b -> Parser a Token (Rhs ()) +rhs eq = rhsExpr <*> localDecls + where rhsExpr = mkSimpleRhs <$> spanPosition <*-> eq <*> expr + <|> mkGuardedRhs <$> spanPosition <*> many1 (condExpr eq) + mkSimpleRhs sp1 e (Just sp2, ds, li) = updateEndPos $ + SimpleRhs (SpanInfo sp1 [sp1, sp2]) li e ds + mkSimpleRhs sp1 e (Nothing, ds, li) = updateEndPos $ + SimpleRhs (SpanInfo sp1 [sp1]) li e ds + mkGuardedRhs sp1 ce (Just sp2, ds, li) = updateEndPos $ + GuardedRhs (SpanInfo sp1 [sp1, sp2]) li ce ds + mkGuardedRhs sp1 ce (Nothing, ds, li) = updateEndPos $ + GuardedRhs (SpanInfo sp1 [sp1]) li ce ds + +whereClause :: Parser a Token b -> Parser a Token (Maybe Span, [b], LayoutInfo) +whereClause decl = (\sp (ds, li) -> (Just sp, ds, li)) + <$> tokenSpan KW_where + <*> layoutWhere decl `opt` (Nothing, [], WhitespaceLayout) + +localDecls :: Parser a Token (Maybe Span, [Decl ()], LayoutInfo) +localDecls = whereClause valueOrInfixDecl + +valueDecls :: Parser a Token ([Decl ()], [Span]) +valueDecls = valueOrInfixDecl `sepBySp` semicolon + +valueOrInfixDecl :: Parser a Token (Decl ()) +valueOrInfixDecl = choice [infixDecl, valueDecl] + +infixDecl :: Parser a Token (Decl ()) +infixDecl = infixDeclLhs infixDecl' + <*> option ((,) <$> spanPosition <*> integer) + <*> funop `sepBy1Sp` comma + where infixDecl' sp1 inf (Just (sp2, pr)) (ids, ss) = + updateEndPos $ InfixDecl (spanInfo sp1 (sp1:sp2:ss)) inf (Just pr) ids + infixDecl' sp1 inf Nothing (ids, ss) = + updateEndPos $ InfixDecl (spanInfo sp1 (sp1 :ss)) inf Nothing ids + +infixDeclLhs :: (Span -> Infix -> a) -> Parser b Token a +infixDeclLhs f = f <$> spanPosition <*> tokenOps infixKW + where infixKW = [(KW_infix, Infix), (KW_infixl, InfixL), (KW_infixr, InfixR)] + +valueDecl :: Parser a Token (Decl ()) +valueDecl = spanPosition <**> decl + where + decl = var `sepBy1Sp` comma <**> valListDecl + <|?> patOrFunDecl <$> pattern0 <*> declRhs + <|?> mkFunDecl <$> curriedLhs <*> declRhs + + valListDecl = funListDecl + <|> mkFree <$> tokenSpan KW_free + where mkFree sp1 (vs, ss) sp2 = updateEndPos $ + FreeDecl (spanInfo sp2 (ss ++ [sp1])) (map (Var ()) vs) + + patOrFunDecl (ConstructorPattern spi _ c ts) + | not (isConstrId c) = mkFunDecl (f, FunLhs spi f ts) + where f = unqualify c + patOrFunDecl t = patOrOpDecl updateEndPos t + + patOrOpDecl f (InfixPattern spi a t1 op t2) + | isConstrId op = patOrOpDecl (f . InfixPattern spi a t1 op) t2 + | otherwise = mkFunDecl (op', updateEndPos $ OpLhs spi (f t1) op' t2) + where op' = unqualify op + patOrOpDecl f t = mkPatDecl (f t) + + mkPatDecl t rhs' sp = updateEndPos $ PatternDecl (fromSrcSpan sp) t rhs' + + isConstrId c = c == qConsId || isQualified c || isQTupleId c + +defaultDecl :: Parser a Token (Decl ()) +defaultDecl = mkDefaultDecl <$> tokenSpan KW_default + <*> parensSp (type0 `sepBySp` comma) + where mkDefaultDecl sp1 ((ty, ss), sp2, sp3) = updateEndPos $ + DefaultDecl (spanInfo sp1 (sp1 : sp2 : (ss ++ [sp3]))) ty + +classInstHead :: Category -> Parser a Token b -> Parser a Token c + -> Parser a Token (Span, [Span], Context, b, c) +classInstHead kw cls ty = f <$> tokenSpan kw + <*> optContext (,,) ((,) <$> cls <*> ty) + where f sp (cx, ss, (cls', ty')) = (sp, ss, cx, cls', ty') + +classDecl :: Parser a Token (Decl ()) +classDecl = mkClass + <$> classInstHead KW_class tycls clsvar + <*> whereClause innerDecl + where + --TODO: Refactor by left-factorization + --TODO: Support infixDecl + innerDecl = foldr1 (<|?>) + [ spanPosition <**> (fun `sepBy1Sp` comma <**> typeSig) + , spanPosition <**> funRule + {-, infixDecl-} ] + mkClass (sp1, ss, cx, cls, tv) (Just sp2, ds, li) = updateEndPos $ + ClassDecl (SpanInfo sp1 (sp1 : (ss ++ [sp2]))) li cx cls tv ds + mkClass (sp1, ss, cx, cls, tv) (Nothing, ds, li) = updateEndPos $ + ClassDecl (SpanInfo sp1 (sp1 : ss)) li cx cls tv ds + +instanceDecl :: Parser a Token (Decl ()) +instanceDecl = mkInstance + <$> classInstHead KW_instance qtycls type2 + <*> whereClause innerDecl + where + innerDecl = spanPosition <**> funRule + mkInstance (sp1, ss, cx, qcls, inst) (Just sp2, ds, li) = updateEndPos $ + InstanceDecl (SpanInfo sp1 (sp1 : (ss ++ [sp2]))) li cx qcls inst ds + mkInstance (sp1, ss, cx, qcls, inst) (Nothing, ds, li) = updateEndPos $ + InstanceDecl (SpanInfo sp1 (sp1 : ss)) li cx qcls inst ds +-- --------------------------------------------------------------------------- +-- Type classes +-- --------------------------------------------------------------------------- + +optContext :: (Context -> [Span] -> a -> b) + -> Parser c Token a + -> Parser c Token b +optContext f p = combine <$> context <*> tokenSpan DoubleArrow <*> p + <|?> f [] [] <$> p + where combine (ctx, ss) sp = f ctx (ss ++ [sp]) + +context :: Parser a Token (Context, [Span]) +context = (\c -> ([c], [])) <$> constraint + <|> combine <$> parensSp (constraint `sepBySp` comma) + where combine ((ctx, ss), sp1, sp2) = (ctx, sp1 : (ss ++ [sp2])) + +constraint :: Parser a Token Constraint +constraint = mkConstraint <$> spanPosition <*> qtycls <*> conType + where varType = mkVariableType <$> spanPosition <*> clsvar + conType = fmap ((,) []) varType + <|> mk <$> parensSp + (foldl mkApplyType <$> varType <*> many1 type2) + mkConstraint sp qtc (ss, ty) = updateEndPos $ + Constraint (spanInfo sp ss) qtc ty + mkVariableType sp = VariableType (fromSrcSpan sp) + mkApplyType t1 t2 = + ApplyType (fromSrcSpan (combineSpans (getSrcSpan t1) + (getSrcSpan t2))) + t1 t2 + mk (a, sp1, sp2) = ([sp1, sp2], a) + +-- --------------------------------------------------------------------------- +-- Kinds +-- --------------------------------------------------------------------------- + +withKind :: Parser a Token b -> Parser a Token (b, Maybe KindExpr) +withKind p = implicitKind <$> p + <|?> parens (explicitKind <$> p <*-> token DoubleColon <*> kind0) + where implicitKind x = (x, Nothing) + explicitKind x k = (x, Just k) + +-- kind0 ::= kind1 ['->' kind0] +kind0 :: Parser a Token KindExpr +kind0 = kind1 `chainr1` (ArrowKind <$-> token RightArrow) + +-- kind1 ::= * | '(' kind0 ')' +kind1 :: Parser a Token KindExpr +kind1 = Star <$-> token SymStar + <|> parens kind0 + +-- --------------------------------------------------------------------------- +-- Types +-- --------------------------------------------------------------------------- + +-- qualType ::= [context '=>'] type0 +qualType :: Parser a Token QualTypeExpr +qualType = mkQualTypeExpr <$> spanPosition <*> optContext (,,) type0 + where mkQualTypeExpr sp (cx, ss, ty) = updateEndPos $ + QualTypeExpr (spanInfo sp ss) cx ty + +-- type0 ::= type1 ['->' type0] +type0 :: Parser a Token TypeExpr +type0 = type1 `chainr1` (mkArrowType <$> tokenSpan RightArrow) + where mkArrowType sp ty1 ty2 = updateEndPos $ + ArrowType (spanInfo (getSrcSpan ty1) [sp]) ty1 ty2 + +-- type1 ::= [type1] type2 +type1 :: Parser a Token TypeExpr +type1 = foldl1 mkApplyType <$> many1 type2 + where mkApplyType ty1 ty2 = updateEndPos $ + ApplyType (fromSrcSpan (getSrcSpan ty1)) ty1 ty2 + +-- type2 ::= anonType | identType | parenType | bracketType +type2 :: Parser a Token TypeExpr +type2 = anonType <|> identType <|> parenType <|> bracketType + +-- anonType ::= '_' +anonType :: Parser a Token TypeExpr +anonType = mkVariableType <$> spanPosition <*> anonIdent + where mkVariableType sp = VariableType (fromSrcSpan sp) + +-- identType ::= +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 = setEndPosition (end (getSrcSpan idt)) + mkParenTuple p sp1 sp2 = + setSpanInfo (spanInfo (combineSpans sp2 sp1) [sp2, sp1]) p + mkFunIdentP idt sp1 f sp2 = setSrcSpan (combineSpans sp2 sp1) (f idt) + mkParenMinus f sp1 idt sp2 = setSrcSpan (combineSpans sp2 sp1) (f idt) + mkConsPattern f ts c = updateEndPos $ + ConstructorPattern (fromSrcSpan (getSrcSpan (f c))) () (f c) ts + mkGconPattern qid sp1 ps sp2 = updateEndPos $ + ConstructorPattern (spanInfo (getSrcSpan qid) [sp2,sp1]) () qid ps + +pattern2 :: Parser a Token (Pattern ()) +pattern2 = literalPattern <|> anonPattern <|> identPattern + <|> parenPattern <|> listPattern <|> lazyPattern + +-- literalPattern ::= | | | +literalPattern :: Parser a Token (Pattern ()) +literalPattern = flip LiteralPattern () <$> fmap fromSrcSpan spanPosition + <*> literal + +-- anonPattern ::= '_' +anonPattern :: Parser a Token (Pattern ()) +anonPattern = flip VariablePattern () <$> fmap fromSrcSpan spanPosition + <*> anonIdent + +-- identPattern ::= Variable [ '@' pattern2 | '{' fields '}' +-- | qConId [ '{' fields '}' ] +identPattern :: Parser a Token (Pattern ()) +identPattern = varId <**> optAsRecPattern -- unqualified + <|> qConId <\> varId <**> optRecPattern -- qualified + +-- TODO: document me! +parenPattern :: Parser a Token (Pattern ()) +parenPattern = tokenSpan LeftParen <**> parenPattern' + where + parenPattern' = minus <**> minusPattern + <|> mkConstructorPattern <$> gconId <*> tokenSpan RightParen + <|> mkFunAsRec <$> funSym <\> minus <*> tokenSpan RightParen + <*> optAsRecPattern + <|> mkParenTuple <$> parenTuplePattern <\> minus <*> tokenSpan RightParen + minusPattern = mkOptAsRec <$> tokenSpan RightParen <*> optAsRecPattern + <|> mkParen <$> parenMinusPattern <*> tokenSpan RightParen + + mkConstructorPattern qid sp1 sp2 = + ConstructorPattern (fromSrcSpan (combineSpans sp2 sp1)) () qid [] + mkFunAsRec = flip (flip . mkOptAsRec) + mkParenTuple p sp1 sp2 = + let ss = getSrcInfoPoints p + spi = spanInfo (combineSpans sp2 sp1) (sp2 : (ss ++ [sp1])) + in setSpanInfo spi p + mkOptAsRec sp1 f idt sp2 = + let p = f idt + ss = getSrcInfoPoints p + spi = spanInfo (combineSpans sp2 sp1) ([sp2, sp1] ++ ss) + in setSpanInfo spi p + mkParen f sp1 idt sp2 = + let p = f idt + ss = getSrcInfoPoints p + spi = spanInfo (combineSpans sp2 sp1) (sp2 : (ss ++ [sp1])) + in setSpanInfo spi p + +-- listPattern ::= '[' pattern0s ']' +-- pattern0s ::= {- empty -} +-- | pattern0 ',' pattern0s +listPattern :: Parser a Token (Pattern ()) +listPattern = mkListPattern <$> bracketsSp (pattern0 `sepBySp` comma) + where mkListPattern ((ps, ss), sp1, sp2) = updateEndPos $ + ListPattern (spanInfo sp1 (sp1 : (ss ++ [sp2]))) () ps + +-- lazyPattern ::= '~' pattern2 +lazyPattern :: Parser a Token (Pattern ()) +lazyPattern = mkLazyPattern <$> tokenSpan Tilde <*> pattern2 + where mkLazyPattern sp p = updateEndPos $ LazyPattern (spanInfo sp [sp]) p + +-- optRecPattern ::= [ '{' fields '}' ] +optRecPattern :: Parser a Token (QualIdent -> Pattern ()) +optRecPattern = mkRecordPattern <$> fieldsSp pattern0 `opt` mkConPattern + where + mkRecordPattern ((fs, ss), sp1, sp2) c = updateEndPos $ + RecordPattern (spanInfo (getSrcSpan c) (sp1 : (ss ++ [sp2]))) () c fs + mkConPattern c = ConstructorPattern (fromSrcSpan (getSrcSpan c)) () c [] + +-- --------------------------------------------------------------------------- +-- Partial patterns used in the combinators above, but also for parsing +-- the left-hand side of a declaration. +-- --------------------------------------------------------------------------- + +gconId :: Parser a Token QualIdent +gconId = colon <|> tupleCommas + +negNum :: Parser a Token (Pattern ()) +negNum = mkNegativePattern <$> spanPosition <*> + (Int <$> integer <|> Float <$> float) + where mkNegativePattern sp = NegativePattern (fromSrcSpan sp) () + +optAsRecPattern :: Parser a Token (Ident -> Pattern ()) +optAsRecPattern = mkAsPattern <$> tokenSpan At <*> pattern2 + <|> mkRecordPattern <$> fieldsSp pattern0 + `opt` mkVariablePattern + where mkRecordPattern ((fs,ss),sp1,sp2) v = + let s = getPosition v + e = end sp2 + f = file s + spi = spanInfo (Span f s e) (sp1 : (ss ++ [sp2])) + in updateEndPos $ RecordPattern spi () (qualify v) fs + mkAsPattern sp p idt = + AsPattern (spanInfo (getSrcSpan idt) [sp]) idt p + mkVariablePattern idt = + VariablePattern (fromSrcSpan (getSrcSpan idt)) () idt + +optInfixPattern :: Parser a Token (Pattern () -> Pattern ()) +optInfixPattern = mkInfixPat <$> gconop <*> pattern0 + `opt` id + where mkInfixPat op t2 t1 = + let s = getPosition t1 + e = getSrcSpanEnd t2 + f = file s + in InfixPattern (fromSrcSpan (Span f s e)) () t1 op t2 + +optTuplePattern :: Parser a Token (Pattern () -> Pattern ()) +optTuplePattern = mkTuple <$> many1 ((,) <$> tokenSpan Comma <*> pattern0) + `opt` ParenPattern NoSpanInfo + where mkTuple ts t = let (ss, ps) = unzip ts + in TuplePattern (fromSrcInfoPoints ss) (t:ps) + +parenMinusPattern :: Parser a Token (Ident -> Pattern ()) +parenMinusPattern = mkNeg <$> negNum <.> optInfixPattern <.> optTuplePattern + where mkNeg neg idt = setEndPosition (end (getSrcSpan idt)) neg + +parenTuplePattern :: Parser a Token (Pattern ()) +parenTuplePattern = pattern0 <**> optTuplePattern + `opt` ConstructorPattern NoSpanInfo () qUnitId [] + +-- --------------------------------------------------------------------------- +-- Expressions +-- --------------------------------------------------------------------------- + +-- condExpr ::= '|' expr0 eq expr +-- +-- Note: The guard is an `expr0` instead of `expr` since conditional expressions +-- may also occur in case expressions, and an expression like +-- @ +-- case a of { _ -> True :: Bool -> a } +-- @ +-- can not be parsed with a limited parser lookahead. +condExpr :: Parser a Token b -> Parser a Token (CondExpr ()) +condExpr eq = mkCondExpr <$> spanPosition <*-> bar <*> expr0 + <*> spanPosition <*-> eq <*> expr + where mkCondExpr sp1 e1 sp2 e2 = updateEndPos $ + CondExpr (spanInfo sp1 [sp1, sp2]) e1 e2 + +-- expr ::= expr0 [ '::' type0 ] +expr :: Parser a Token (Expression ()) +expr = expr0 (mkTyped <$> tokenSpan DoubleColon <*> qualType) + where mkTyped sp qty e = updateEndPos $ setSrcSpan (getSrcSpan e) $ + Typed (fromSrcInfoPoints [sp]) e qty + +-- expr0 ::= expr1 { infixOp expr1 } +expr0 :: Parser a Token (Expression ()) +expr0 = expr1 `chainr1` (mkInfixApply <$> infixOp) + where mkInfixApply op e1 e2 = InfixApply + (fromSrcSpan (combineSpans (getSrcSpan e1) (getSrcSpan e2))) e1 op e2 + +-- expr1 ::= - expr2 | -. expr2 | expr2 +expr1 :: Parser a Token (Expression ()) +expr1 = mkUnaryMinus <$> minus <*> expr2 + <|> expr2 + where mkUnaryMinus idt ex = + let p = getPosition idt + e = getSrcSpanEnd ex + f = file p + in UnaryMinus (spanInfo (Span f p e) [Span f p (incr p 1)]) ex + +-- expr2 ::= lambdaExpr | letExpr | doExpr | ifExpr | caseExpr | expr3 +expr2 :: Parser a Token (Expression ()) +expr2 = choice [ lambdaExpr, letExpr, doExpr, ifExpr, caseExpr + , foldl1 mkApply <$> many1 expr3 + ] + where mkApply e1 e2 = updateEndPos $ Apply (fromSrcSpan (getSrcSpan e1)) e1 e2 + +expr3 :: Parser a Token (Expression ()) +expr3 = foldl mkRecordUpdate <$> expr4 <*> many recUpdate + where recUpdate = layoutOff <-*> bracesSp (field expr0 `sepBy1Sp` comma) + mkRecordUpdate e ((fs,ss), sp1, sp2) = updateEndPos $ + setSrcInfoPoints (sp1 : (ss ++ [sp2])) $ + RecordUpdate (fromSrcSpan (getSrcSpan e)) e fs + +expr4 :: Parser a Token (Expression ()) +expr4 = choice + [constant, anonFreeVariable, variable, parenExpr, listExpr] + +constant :: Parser a Token (Expression ()) +constant = mkLiteral <$> spanPosition <*> literal + where mkLiteral sp = Literal (fromSrcSpan sp) () + +anonFreeVariable :: Parser a Token (Expression ()) +anonFreeVariable = (\ p v -> mkVariable $ qualify $ addPositionIdent p v) + <$> position <*> anonIdent + where mkVariable qid = Variable (fromSrcSpan (getSrcSpan qid)) () qid + +variable :: Parser a Token (Expression ()) +variable = qFunId <**> optRecord + where optRecord = mkRecord <$> fieldsSp expr0 `opt` mkVariable + mkRecord ((fs,ss), sp1, sp2) qid = + let spi = spanInfo (getSrcSpan qid) (sp1 : (ss ++ [sp2])) + in updateEndPos $ Record spi () qid fs + mkVariable qid = Variable (fromSrcSpan (getSrcSpan qid)) () qid + +parenExpr :: Parser a Token (Expression ()) +parenExpr = fmap updateSpanWithBrackets (parensSp pExpr) + where + pExpr = minus <**> minusOrTuple + <|> mkConstructor () <$> tupleCommas + <|> leftSectionOrTuple <\> minus + <|> opOrRightSection <\> minus + `opt` Constructor (fromSrcInfoPoints []) () qUnitId + minusOrTuple = mkUnaryMinus <$> expr1 <.> infixOrTuple + `opt` mkVariable . qualify + leftSectionOrTuple = expr1 <**> infixOrTuple + infixOrTuple = ($ updateEndPos) <$> infixOrTuple' + infixOrTuple' = infixOp <**> leftSectionOrExp + <|> (.) <$> (optType <.> tupleExpr) + leftSectionOrExp = expr1 <**> (infixApp <$> infixOrTuple') + `opt` leftSection + optType = mkTyped <$> tokenSpan DoubleColon <*> qualType `opt` id + tupleExpr = mkTuple <$> many1 ((,) <$> tokenSpan Comma <*> expr) + `opt` Paren NoSpanInfo + opOrRightSection = qFunSym <**> optRightSection + <|> colon <**> optCRightSection + <|> infixOp <\> colon <\> qFunSym <**> rightSection + optRightSection = (. InfixOp () ) <$> rightSection + `opt` Variable NoSpanInfo () + optCRightSection = (. InfixConstr ()) <$> rightSection + `opt` Constructor NoSpanInfo () + rightSection = mkRightSection <$> expr0 + infixApp f e2 op g e1 = f (g . mkInfixApply e1 op) e2 + leftSection op f e = mkLeftSection (f e) op + mkTuple ses e = let (ss,es) = unzip ses + in Tuple (fromSrcInfoPoints ss) (e:es) + mkConstructor = Constructor NoSpanInfo + mkTyped sp ty e = Typed (fromSrcInfoPoints [sp]) e ty + mkRightSection = flip (RightSection NoSpanInfo) + mkLeftSection = LeftSection NoSpanInfo + mkInfixApply e1 op e2 = InfixApply (fromSrcSpan + (combineSpans (getSrcSpan e1) (getSrcSpan e2))) e1 op e2 + mkVariable = Variable NoSpanInfo () + mkUnaryMinus ex idt = + let p = getPosition idt + e = getSrcSpanEnd ex + f = file p + in UnaryMinus (spanInfo (Span f p e) [Span f p (incr p 1)]) ex + +infixOp :: Parser a Token (InfixOp ()) +infixOp = InfixOp () <$> qfunop <|> InfixConstr () <$> colon + +listExpr :: Parser a Token (Expression ()) +listExpr = updateSpanWithBrackets <$> + bracketsSp (elements `opt` List (fromSrcInfoPoints []) () []) + where + elements = expr <**> rest + rest = comprehension + <|> enumeration mkEnumFromTo mkEnumFrom + <|> (tokenSpan Comma <**> (expr <**>( + enumeration mkEnumFromThenTo mkEnumFromThen + <|> list <$> many ((,) <$> tokenSpan Comma <*> expr))) + `opt` (\ e -> List (fromSrcInfoPoints []) () [e])) + comprehension = mkListCompr <$> tokenSpan Bar <*> quals + enumeration enumTo enum = + tokenSpan DotDot <**> (enumTo <$> expr `opt` enum) + + mkEnumFrom sp = + EnumFrom (fromSrcInfoPoints [sp]) + mkEnumFromTo e1 sp e2 = + EnumFromTo (fromSrcInfoPoints [sp]) e2 e1 + mkEnumFromThen sp1 e1 sp2 e2 = + EnumFromThen (fromSrcInfoPoints [sp2,sp1]) e2 e1 + mkEnumFromThenTo e1 sp1 e2 sp2 e3 = + EnumFromThenTo (fromSrcInfoPoints [sp2,sp1]) e3 e2 e1 + mkListCompr sp qu e = ListCompr (fromSrcInfoPoints [sp]) e qu + + list xs e2 sp e1 = let (ss, es) = unzip xs + in List (fromSrcInfoPoints (sp:ss)) () (e1:e2:es) + +updateSpanWithBrackets :: HasSpanInfo a => (a, Span, Span) -> a +updateSpanWithBrackets (ex, sp1, sp2) = + let ss = getSrcInfoPoints ex + s = getPosition sp1 + e = end sp2 + f = file s + spi = spanInfo (Span f s e) (sp1 : (ss ++ [sp2])) + in setSpanInfo spi ex + +lambdaExpr :: Parser a Token (Expression ()) +lambdaExpr = mkLambda <$> tokenSpan Backslash <*> many1 pattern2 + <*> spanPosition <*-> expectRightArrow + <*> expr + where mkLambda sp1 ps sp2 e = updateEndPos $ Lambda (spanInfo sp1 [sp1, sp2]) ps e + +letExpr :: Parser a Token (Expression ()) +letExpr = mkLet <$> tokenSpan KW_let <*> layout valueDecls + <*> (tokenSpan KW_in "in expected") <*> expr + where + mkLet sp1 (ds, lay) sp2 e = updateEndPos $ + Let (spanInfo sp1 [sp1, sp2])lay ds e + +doExpr :: Parser a Token (Expression ()) +doExpr = mkDo <$> tokenSpan KW_do <*> layout stmts + where + mkDo sp ((stms, ex), lay) = updateEndPos $ + Do (spanInfo sp [sp]) lay stms ex + +ifExpr :: Parser a Token (Expression ()) +ifExpr = mkIfThenElse + <$> tokenSpan KW_if <*> expr + <*> (tokenSpan KW_then "then expected") <*> expr + <*> (tokenSpan KW_else "else expected") <*> expr + where mkIfThenElse sp1 e1 sp2 e2 sp3 e3 = updateEndPos $ + IfThenElse (spanInfo sp1 [sp1, sp2, sp3]) e1 e2 e3 + +caseExpr :: Parser a Token (Expression ()) +caseExpr = (mkCase Flex <$> tokenSpan KW_fcase + <|> mkCase Rigid <$> tokenSpan KW_case) + <*> expr + <*> (tokenSpan KW_of "of expected") + <*> layout (alt `sepBy1Sp` semicolon) + where + mkCase ct sp1 e sp2 (alts, lay) = updateEndPos $ + Case (spanInfo sp1 [sp1, sp2]) lay ct e alts + +alt :: Parser a Token (Alt ()) +alt = mkAlt <$> spanPosition <*> pattern0 + <*> spanPosition <*> rhs expectRightArrow + where mkAlt sp1 p sp2 = updateEndPos . Alt (spanInfo sp1 [sp2]) p + +fieldsSp :: Parser a Token b -> Parser a Token (([Field b], [Span]), Span, Span) +fieldsSp p = layoutOff <-*> bracesSp (field p `sepBySp` comma) + +field :: Parser a Token b -> Parser a Token (Field b) +field p = mkField <$> spanPosition <*> qfun + <*> spanPosition <*-> expectEquals + <*> p + where mkField sp1 q sp2 = updateEndPos . Field (spanInfo sp1 [sp2]) q + +-- --------------------------------------------------------------------------- +-- \paragraph{Statements in list comprehensions and \texttt{do} expressions} +-- Parsing statements is a bit difficult because the syntax of patterns +-- and expressions largely overlaps. The parser will first try to +-- recognize the prefix \emph{Pattern}~\texttt{<-} of a binding statement +-- and if this fails fall back into parsing an expression statement. In +-- addition, we have to be prepared that the sequence +-- \texttt{let}~\emph{LocalDefs} can be either a let-statement or the +-- prefix of a let expression. +-- --------------------------------------------------------------------------- + +stmts :: Parser a Token (([Statement ()], Expression ()), [Span]) +stmts = stmt reqStmts optStmts + +reqStmts :: Parser a Token (Statement () + -> (([Statement ()], Expression ()), [Span])) +reqStmts = mkStmts <$> spanPosition <*-> semicolon <*> stmts + where mkStmts sp ((sts, e), sps) st = ((st : sts, e), sp:sps) + +optStmts :: Parser a Token (Expression () + -> (([Statement ()], Expression ()), [Span])) +optStmts = succeed mkStmtExpr <.> reqStmts `opt` (\e -> (([], e), [])) + where mkStmtExpr e = StmtExpr (fromSrcSpan (getSrcSpan e)) e + +quals :: Parser a Token [Statement ()] +quals = stmt (succeed id) (succeed mkStmtExpr) `sepBy1` comma + where mkStmtExpr e = StmtExpr (fromSrcSpan (getSrcSpan e)) e + +stmt :: Parser a Token (Statement () -> b) + -> Parser a Token (Expression () -> b) -> Parser a Token b +stmt stmtCont exprCont = letStmt stmtCont exprCont + <|> exprOrBindStmt stmtCont exprCont + +letStmt :: Parser a Token (Statement () -> b) + -> Parser a Token (Expression () -> b) -> Parser a Token b +letStmt stmtCont exprCont = ((,) <$> tokenSpan KW_let <*> layout valueDecls) + <**> optExpr + where optExpr = let' <$> tokenSpan KW_in <*> expr <.> exprCont + <|> succeed stmtDecl' <.> stmtCont + where + let' sp1 e (sp2, (ds, lay)) = updateEndPos $ + Let (spanInfo sp2 [sp2, sp1]) lay ds e + stmtDecl' (sp2, (ds, lay)) = updateEndPos $ + StmtDecl (spanInfo sp2 [sp2]) lay ds + +exprOrBindStmt :: Parser a Token (Statement () -> b) + -> Parser a Token (Expression () -> b) + -> Parser a Token b +exprOrBindStmt stmtCont exprCont = + stmtBind' <$> spanPosition <*> pattern0 <*> tokenSpan LeftArrow <*> expr + <**> stmtCont + <|?> expr <\> token KW_let <**> exprCont + where + stmtBind' sp1 p sp2 e = updateEndPos $ + StmtBind (spanInfo sp1 [sp2]) p e + +-- --------------------------------------------------------------------------- +-- Goals +-- --------------------------------------------------------------------------- + +goal :: Parser a Token (Goal ()) +goal = mkGoal <$> spanPosition <*> expr <*> localDecls + where + mkGoal sp1 ex (Just sp2, ds, li) = updateEndPos $ + Goal (SpanInfo sp1 [sp2]) li ex ds + mkGoal sp1 ex (Nothing, ds, li) = updateEndPos $ + Goal (SpanInfo sp1 []) li ex ds + +-- --------------------------------------------------------------------------- +-- Literals, identifiers, and (infix) operators +-- --------------------------------------------------------------------------- + +char :: Parser a Token Char +char = cval <$> token CharTok + +float :: Parser a Token Double +float = fval <$> token FloatTok + +int :: Parser a Token Int +int = fromInteger <$> integer + +integer :: Parser a Token Integer +integer = ival <$> token IntTok + +string :: Parser a Token String +string = sval <$> token StringTok + +tycon :: Parser a Token Ident +tycon = conId + +anonOrTyvar :: Parser a Token Ident +anonOrTyvar = anonIdent <|> tyvar + +tyvar :: Parser a Token Ident +tyvar = varId + +clsvar :: Parser a Token Ident +clsvar = tyvar + +tycls :: Parser a Token Ident +tycls = conId + +qtycls :: Parser a Token QualIdent +qtycls = qConId + +qtycon :: Parser a Token QualIdent +qtycon = qConId + +varId :: Parser a Token Ident +varId = ident + +funId :: Parser a Token Ident +funId = ident + +conId :: Parser a Token Ident +conId = ident + +funSym :: Parser a Token Ident +funSym = sym + +conSym :: Parser a Token Ident +conSym = sym + +modIdent :: Parser a Token ModuleIdent +modIdent = mIdent "module name expected" + +var :: Parser a Token Ident +var = varId <|> updateSpanWithBrackets + <$> parensSp (funSym "operator symbol expected") + +fun :: Parser a Token Ident +fun = funId <|> updateSpanWithBrackets + <$> parensSp (funSym "operator symbol expected") + +con :: Parser a Token Ident +con = conId <|> updateSpanWithBrackets + <$> parensSp (conSym "operator symbol expected") + +funop :: Parser a Token Ident +funop = funSym <|> updateSpanWithBrackets + <$> backquotesSp (funId "operator name expected") + +conop :: Parser a Token Ident +conop = conSym <|> updateSpanWithBrackets + <$> backquotesSp (conId "operator name expected") + +qFunId :: Parser a Token QualIdent +qFunId = qIdent + +qConId :: Parser a Token QualIdent +qConId = qIdent + +qFunSym :: Parser a Token QualIdent +qFunSym = qSym + +qConSym :: Parser a Token QualIdent +qConSym = qSym + +gConSym :: Parser a Token QualIdent +gConSym = qConSym <|> colon + +qfun :: Parser a Token QualIdent +qfun = qFunId <|> updateSpanWithBrackets + <$> parensSp (qFunSym "operator symbol expected") + +qfunop :: Parser a Token QualIdent +qfunop = qFunSym <|> updateSpanWithBrackets + <$> backquotesSp (qFunId "operator name expected") + +gconop :: Parser a Token QualIdent +gconop = gConSym <|> updateSpanWithBrackets + <$> backquotesSp (qConId "operator name expected") + +anonIdent :: Parser a Token Ident +anonIdent = (`setSpanInfo` anonId) . fromSrcSpanBoth <$> tokenSpan Underscore + +mIdent :: Parser a Token ModuleIdent +mIdent = mIdent' <$> spanPosition <*> + tokens [Id,QId,Id_as,Id_ccall,Id_forall,Id_hiding, + Id_interface,Id_primitive,Id_qualified] + where mIdent' sp a = ModuleIdent (fromSrcSpanBoth sp) (modulVal a ++ [sval a]) + +ident :: Parser a Token Ident +ident = (\ sp t -> setSpanInfo (fromSrcSpanBoth sp) (mkIdent (sval t))) + <$> spanPosition <*> tokens [Id,Id_as,Id_ccall,Id_forall,Id_hiding, + Id_interface,Id_primitive,Id_qualified] + +qIdent :: Parser a Token QualIdent +qIdent = qualify <$> ident <|> qIdentWith QId + +sym :: Parser a Token Ident +sym = (\ sp t -> setSpanInfo (fromSrcSpanBoth sp) (mkIdent (sval t))) + <$> spanPosition <*> tokens [Sym, SymDot, SymMinus, SymStar] + +qSym :: Parser a Token QualIdent +qSym = qualify <$> sym <|> qIdentWith QSym + +qIdentWith :: Category -> Parser a Token QualIdent +qIdentWith c = mkQIdent <$> spanPosition <*> token c + where mkQIdent :: Span -> Attributes -> QualIdent + mkQIdent sp a = + let mid = ModuleIdent (fromSrcSpan sp) (modulVal a) + p = incr (getPosition sp) (mIdentLength mid - 1) + mid' = setEndPosition p mid + idt = setSrcSpan sp $ mkIdent (sval a) + idt' = setPosition (incr p 1) idt + in QualIdent (fromSrcSpanBoth sp) (Just mid') idt' + +colon :: Parser a Token QualIdent +colon = qualify . (`setSpanInfo` consId) . fromSrcSpanBoth <$> tokenSpan Colon + +minus :: Parser a Token Ident +minus = (`setSpanInfo` minusId) . fromSrcSpanBoth <$> tokenSpan SymMinus + +tupleCommas :: Parser a Token QualIdent +tupleCommas = (\ sp ss -> qualify $ updateEndPos $ setSpanInfo (spanInfo sp ss) + $ tupleId $ succ $ length ss) + <$> spanPosition <*> many1 (tokenSpan Comma) + +-- --------------------------------------------------------------------------- +-- Layout +-- --------------------------------------------------------------------------- + +-- |This function starts a new layout block but does not wait for its end. +-- This is only used for parsing the module header. +startLayout :: Parser a Token (b, [Span]) -> Parser a Token (b, LayoutInfo) +startLayout p = layoutOff <-*> + (createExpli1Layout <$> tokenSpan LeftBrace <*> p) + <|> layoutOn <-*> + (createWhiteLayout <$> p) + +layout :: Parser a Token (b, [Span]) -> Parser a Token (b, LayoutInfo) +layout p = (createExpliLayout + <$> (layoutOff <-*> bracesSp p)) + <|> (createWhiteLayout + <$> (layoutOn <-*> p <*-> (token VRightBrace <|> layoutEnd))) + +createExpli1Layout :: Span -> (b, [Span]) -> (b, LayoutInfo) +createExpli1Layout sp1 (b, ss) = (b, ExplicitLayout (sp1:ss)) + +createExpliLayout :: ((b, [Span]), Span, Span) -> (b, LayoutInfo) +createExpliLayout ((b, ss), sp1, spe) = (b, ExplicitLayout (sp1:ss ++ [spe])) + +createWhiteLayout :: (b, [Span]) -> (b, LayoutInfo) +createWhiteLayout (b, _) = (b, WhitespaceLayout) + +-- We have to remove an additional context on an empty where-clause +layoutWhere :: Parser a Token b -> Parser a Token ([b], LayoutInfo) +layoutWhere p = (createExpliLayout + <$> (layoutOff <-*> bracesSp (p `sepBySp` semicolon))) + <|> (createWhiteLayout + <$> (layoutOn <-*> (p `sepBy1Sp` semicolon) + <*-> (token VRightBrace <|> layoutEnd))) + <|> succeed ([], WhitespaceLayout) + +-- --------------------------------------------------------------------------- +-- Bracket combinators +-- --------------------------------------------------------------------------- + +braces :: Parser a Token b -> Parser a Token b +braces p = between leftBrace p rightBrace + +bracesSp :: Parser a Token b -> Parser a Token (b, Span, Span) +bracesSp p = (\sp1 b sp2 -> (b, sp1, sp2)) + <$> tokenSpan LeftBrace + <*> p + <*> tokenSpan RightBrace + +bracketsSp :: Parser a Token b -> Parser a Token (b, Span, Span) +bracketsSp p = (\sp1 b sp2 -> (b, sp1, sp2)) + <$> tokenSpan LeftBracket + <*> p + <*> tokenSpan RightBracket + +parens :: Parser a Token b -> Parser a Token b +parens p = between leftParen p rightParen + +parensSp :: Parser a Token b -> Parser a Token (b, Span, Span) +parensSp p = (\sp1 b sp2 -> (b, sp1, sp2)) + <$> tokenSpan LeftParen + <*> p + <*> tokenSpan RightParen + +backquotesSp :: Parser a Token b -> Parser a Token (b, Span, Span) +backquotesSp p = (\sp1 b sp2 -> (b, sp1, sp2)) + <$> tokenSpan Backquote + <*> p + <*> spanPosition <*-> expectBackquote + +-- --------------------------------------------------------------------------- +-- Simple token parsers +-- --------------------------------------------------------------------------- + +token :: Category -> Parser a Token Attributes +token c = attr <$> symbol (Token c NoAttributes) + where attr (Token _ a) = a + +tokens :: [Category] -> Parser a Token Attributes +tokens = foldr1 (<|>) . map token + +tokenPos :: Category -> Parser a Token Position +tokenPos c = position <*-> token c + +tokenSpan :: Category -> Parser a Token Span +tokenSpan c = spanPosition <*-> token c + +tokenOps :: [(Category, b)] -> Parser a Token b +tokenOps cs = ops [(Token c NoAttributes, x) | (c, x) <- cs] + +comma :: Parser a Token Attributes +comma = token Comma + +semicolon :: Parser a Token Attributes +semicolon = token Semicolon <|> token VSemicolon + +bar :: Parser a Token Attributes +bar = token Bar + +equals :: Parser a Token Attributes +equals = token Equals + +expectEquals :: Parser a Token Attributes +expectEquals = equals "= expected" + +expectWhere :: Parser a Token Attributes +expectWhere = token KW_where "where expected" + +expectRightArrow :: Parser a Token Attributes +expectRightArrow = token RightArrow "-> expected" + +backquote :: Parser a Token Attributes +backquote = token Backquote + +expectBackquote :: Parser a Token Attributes +expectBackquote = backquote "backquote (`) expected" + +leftParen :: Parser a Token Attributes +leftParen = token LeftParen + +rightParen :: Parser a Token Attributes +rightParen = token RightParen + +leftBrace :: Parser a Token Attributes +leftBrace = token LeftBrace + +rightBrace :: Parser a Token Attributes +rightBrace = token RightBrace diff --git a/src/Curry/Syntax/Pretty.hs b/src/Curry/Syntax/Pretty.hs new file mode 100644 index 0000000000000000000000000000000000000000..8b26438ca42dc18eccd76cfb278bf917c97c48fe --- /dev/null +++ b/src/Curry/Syntax/Pretty.hs @@ -0,0 +1,463 @@ +{- | + Module : $Header$ + Description : A pretty printer for Curry + Copyright : (c) 1999 - 2004 Wolfgang Lux + 2005 Martin Engelke + 2011 - 2015 Björn Peemöller + 2016 Finn Teegen + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This module implements a pretty printer for Curry expressions. It was + derived from the Haskell pretty printer provided in Simon Marlow's + Haskell parser. +-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Curry.Syntax.Pretty + ( pPrint, pPrintPrec, ppContext, ppInstanceType, ppIMethodImpl + , ppIdent, ppQIdent, ppInfixOp, ppQInfixOp, ppMIdent + ) where + +import Prelude hiding ((<>)) + +import Curry.Base.Ident +import Curry.Base.Pretty + +import Curry.Syntax.Type +import Curry.Syntax.Utils (opName) + +instance Pretty (Module a) where + pPrint (Module _ _ ps m es is ds) = ppModuleHeader ps m es is $$ ppSepBlock ds + +ppModuleHeader :: [ModulePragma] -> ModuleIdent -> Maybe ExportSpec + -> [ImportDecl] -> Doc +ppModuleHeader ps m es is + | null is = header + | otherwise = header $+$ text "" $+$ vcat (map pPrint is) + where header = vcat (map pPrint ps) + $+$ text "module" <+> ppMIdent m + <+> maybePP pPrint es <+> text "where" + +instance Pretty ModulePragma where + pPrint (LanguagePragma _ exts) = + ppPragma "LANGUAGE" $ list $ map pPrint exts + pPrint (OptionsPragma _ tool args) = + ppPragma "OPTIONS" $ maybe empty ((text "_" <>) . pPrint) tool <+> text args + +ppPragma :: String -> Doc -> Doc +ppPragma kw doc = text "{-#" <+> text kw <+> doc <+> text "#-}" + +instance Pretty Extension where + pPrint (KnownExtension _ e) = text (show e) + pPrint (UnknownExtension _ e) = text e + +instance Pretty Tool where + pPrint (UnknownTool t) = text t + pPrint t = text (show t) + +instance Pretty ExportSpec where + pPrint (Exporting _ es) = parenList (map pPrint es) + +instance Pretty Export where + pPrint (Export _ x) = ppQIdent x + pPrint (ExportTypeWith _ tc cs) = ppQIdent tc <> parenList (map ppIdent cs) + pPrint (ExportTypeAll _ tc) = ppQIdent tc <> text "(..)" + pPrint (ExportModule _ m) = text "module" <+> ppMIdent m + +instance Pretty ImportDecl where + pPrint (ImportDecl _ m q asM is) = + text "import" <+> ppQualified q <+> ppMIdent m <+> maybePP ppAs asM + <+> maybePP pPrint is + where + ppQualified q' = if q' then text "qualified" else empty + ppAs m' = text "as" <+> ppMIdent m' + +instance Pretty ImportSpec where + pPrint (Importing _ is) = parenList (map pPrint is) + pPrint (Hiding _ is) = text "hiding" <+> parenList (map pPrint is) + +instance Pretty Import where + pPrint (Import _ x) = ppIdent x + pPrint (ImportTypeWith _ tc cs) = ppIdent tc <> parenList (map ppIdent cs) + pPrint (ImportTypeAll _ tc) = ppIdent tc <> text "(..)" + +ppBlock :: Pretty a => [a] -> Doc +ppBlock = vcat . map pPrint + +ppSepBlock :: Pretty a => [a] -> Doc +ppSepBlock = vcat . map (\d -> text "" $+$ pPrint d) + +instance Pretty (Decl a) where + pPrint (InfixDecl _ fix p ops) = ppPrec fix p <+> list (map ppInfixOp ops) + pPrint (DataDecl _ tc tvs cs clss) = + sep (ppTypeDeclLhs "data" tc tvs : + map indent (zipWith (<+>) (equals : repeat vbar) (map pPrint cs) ++ + [ppDeriving clss])) + pPrint (ExternalDataDecl _ tc tvs) = ppTypeDeclLhs "external data" tc tvs + pPrint (NewtypeDecl _ tc tvs nc clss) = + sep (ppTypeDeclLhs "newtype" tc tvs <+> equals : + map indent [pPrint nc, ppDeriving clss]) + pPrint (TypeDecl _ tc tvs ty) = + sep [ppTypeDeclLhs "type" tc tvs <+> equals,indent (pPrintPrec 0 ty)] + pPrint (TypeSig _ fs ty) = + list (map ppIdent fs) <+> text "::" <+> pPrintPrec 0 ty + pPrint (FunctionDecl _ _ _ eqs) = vcat (map pPrint eqs) + pPrint (ExternalDecl _ vs) = list (map pPrint vs) <+> text "external" + pPrint (PatternDecl _ t rhs) = ppRule (pPrintPrec 0 t) equals rhs + pPrint (FreeDecl _ vs) = list (map pPrint vs) <+> text "free" + pPrint (DefaultDecl _ tys) = + text "default" <+> parenList (map (pPrintPrec 0) tys) + pPrint (ClassDecl _ _ cx cls clsvar ds) = + ppClassInstHead "class" cx (ppIdent cls) (ppIdent clsvar) <+> + ppIf (not $ null ds) (text "where") $$ + ppIf (not $ null ds) (indent $ ppBlock ds) + pPrint (InstanceDecl _ _ cx qcls inst ds) = + ppClassInstHead "instance" cx (ppQIdent qcls) (ppInstanceType inst) <+> + ppIf (not $ null ds) (text "where") $$ + ppIf (not $ null ds) (indent $ ppBlock ds) + +ppClassInstHead :: String -> Context -> Doc -> Doc -> Doc +ppClassInstHead kw cx cls ty = text kw <+> ppContext cx <+> cls <+> ty + +ppContext :: Context -> Doc +ppContext [] = empty +ppContext [c] = pPrint c <+> darrow +ppContext cs = parenList (map pPrint cs) <+> darrow + +instance Pretty Constraint where + pPrint (Constraint _ qcls ty) = ppQIdent qcls <+> pPrintPrec 2 ty + +ppInstanceType :: InstanceType -> Doc +ppInstanceType = pPrintPrec 2 + +ppDeriving :: [QualIdent] -> Doc +ppDeriving [] = empty +ppDeriving [qcls] = text "deriving" <+> ppQIdent qcls +ppDeriving qclss = text "deriving" <+> parenList (map ppQIdent qclss) + +ppPrec :: Infix -> Maybe Precedence -> Doc +ppPrec fix p = pPrint fix <+> ppPrio p + where + ppPrio Nothing = empty + ppPrio (Just p') = integer p' + +ppTypeDeclLhs :: String -> Ident -> [Ident] -> Doc +ppTypeDeclLhs kw tc tvs = text kw <+> ppIdent tc <+> hsep (map ppIdent tvs) + +instance Pretty ConstrDecl where + pPrint (ConstrDecl _ c tys) = + sep [ ppIdent c <+> fsep (map (pPrintPrec 2) tys) ] + pPrint (ConOpDecl _ ty1 op ty2) = + sep [ pPrintPrec 1 ty1, ppInfixOp op <+> pPrintPrec 1 ty2 ] + pPrint (RecordDecl _ c fs) = + sep [ ppIdent c <+> record (list (map pPrint fs)) ] + +instance Pretty FieldDecl where + pPrint (FieldDecl _ ls ty) = list (map ppIdent ls) + <+> text "::" <+> pPrintPrec 0 ty + +instance Pretty NewConstrDecl where + pPrint (NewConstrDecl _ c ty) = sep [ppIdent c <+> pPrintPrec 2 ty] + pPrint (NewRecordDecl _ c (i,ty)) = + sep [ppIdent c <+> record (ppIdent i <+> text "::" <+> pPrintPrec 0 ty)] + +ppQuantifiedVars :: [Ident] -> Doc +ppQuantifiedVars tvs + | null tvs = empty + | otherwise = text "forall" <+> hsep (map ppIdent tvs) <+> char '.' + +instance Pretty (Equation a) where + pPrint (Equation _ lhs rhs) = ppRule (pPrint lhs) equals rhs + +instance Pretty (Lhs a) where + pPrint (FunLhs _ f ts) = + ppIdent f <+> fsep (map (pPrintPrec 2) ts) + pPrint (OpLhs _ t1 f t2) = + pPrintPrec 1 t1 <+> ppInfixOp f <+> pPrintPrec 1 t2 + pPrint (ApLhs _ lhs ts) = + parens (pPrint lhs) <+> fsep (map (pPrintPrec 2) ts) + +ppRule :: Doc -> Doc -> Rhs a -> Doc +ppRule lhs eq (SimpleRhs _ _ e ds) = + sep [lhs <+> eq, indent (pPrintPrec 0 e)] $$ ppLocalDefs ds +ppRule lhs eq (GuardedRhs _ _ es ds) = + sep [lhs, indent (vcat (map (ppCondExpr eq) es))] $$ ppLocalDefs ds + +ppLocalDefs :: [Decl a] -> Doc +ppLocalDefs ds + | null ds = empty + | otherwise = indent (text "where" <+> ppBlock ds) + +-- --------------------------------------------------------------------------- +-- Interfaces +-- --------------------------------------------------------------------------- + +instance Pretty Interface where + pPrint (Interface m is ds) = + text "interface" <+> ppMIdent m <+> text "where" <+> lbrace + $$ vcat (punctuate semi $ map pPrint is ++ map pPrint ds) + $$ rbrace + +instance Pretty IImportDecl where + pPrint (IImportDecl _ m) = text "import" <+> ppMIdent m + +instance Pretty IDecl where + pPrint (IInfixDecl _ fix p op) = ppPrec fix (Just p) <+> ppQInfixOp op + pPrint (HidingDataDecl _ tc k tvs) = + text "hiding" <+> ppITypeDeclLhs "data" tc k tvs + pPrint (IDataDecl _ tc k tvs cs hs) = + sep (ppITypeDeclLhs "data" tc k tvs : + map indent (zipWith (<+>) (equals : repeat vbar) (map pPrint cs)) ++ + [indent (ppHiding hs)]) + pPrint (INewtypeDecl _ tc k tvs nc hs) = + sep [ ppITypeDeclLhs "newtype" tc k tvs <+> equals + , indent (pPrint nc) + , indent (ppHiding hs) + ] + pPrint (ITypeDecl _ tc k tvs ty) = + sep [ppITypeDeclLhs "type" tc k tvs <+> equals,indent (pPrintPrec 0 ty)] + pPrint (IFunctionDecl _ f cm a ty) = + sep [ ppQIdent f, maybePP (ppPragma "METHOD" . ppIdent) cm + , int a, text "::", pPrintPrec 0 ty ] + pPrint (HidingClassDecl _ cx qcls k clsvar) = text "hiding" <+> + ppClassInstHead "class" cx (ppQIdentWithKind qcls k) (ppIdent clsvar) + pPrint (IClassDecl _ cx qcls k clsvar ms hs) = + ppClassInstHead "class" cx (ppQIdentWithKind qcls k) (ppIdent clsvar) <+> + lbrace $$ + vcat (punctuate semi $ map (indent . pPrint) ms) $$ + rbrace <+> ppHiding hs + pPrint (IInstanceDecl _ cx qcls inst impls m) = + ppClassInstHead "instance" cx (ppQIdent qcls) (ppInstanceType inst) <+> + lbrace $$ + vcat (punctuate semi $ map (indent . ppIMethodImpl) impls) $$ + rbrace <+> maybePP (ppPragma "MODULE" . ppMIdent) m + +ppITypeDeclLhs :: String -> QualIdent -> Maybe KindExpr -> [Ident] -> Doc +ppITypeDeclLhs kw tc k tvs = + text kw <+> ppQIdentWithKind tc k <+> hsep (map ppIdent tvs) + +instance Pretty IMethodDecl where + pPrint (IMethodDecl _ f a qty) = + ppIdent f <+> maybePP int a <+> text "::" <+> pPrintPrec 0 qty + +ppIMethodImpl :: IMethodImpl -> Doc +ppIMethodImpl (f, a) = ppIdent f <+> int a + +ppQIdentWithKind :: QualIdent -> Maybe KindExpr -> Doc +ppQIdentWithKind tc (Just k) = + parens $ ppQIdent tc <+> text "::" <+> pPrintPrec 0 k +ppQIdentWithKind tc Nothing = ppQIdent tc + +ppHiding :: [Ident] -> Doc +ppHiding hs + | null hs = empty + | otherwise = ppPragma "HIDING" $ list $ map ppIdent hs + +-- --------------------------------------------------------------------------- +-- Kinds +-- --------------------------------------------------------------------------- + +instance Pretty KindExpr where + pPrintPrec _ Star = char '*' + pPrintPrec p (ArrowKind k1 k2) = + parenIf (p > 0) (fsep (ppArrowKind (ArrowKind k1 k2))) + where + ppArrowKind (ArrowKind k1' k2') = + pPrintPrec 1 k1' <+> rarrow : ppArrowKind k2' + ppArrowKind k = + [pPrintPrec 0 k] + +-- --------------------------------------------------------------------------- +-- Types +-- --------------------------------------------------------------------------- + +instance Pretty QualTypeExpr where + pPrint (QualTypeExpr _ cx ty) = ppContext cx <+> pPrintPrec 0 ty + +instance Pretty TypeExpr where + pPrintPrec _ (ConstructorType _ tc) = ppQIdent tc + pPrintPrec p (ApplyType _ ty1 ty2) = parenIf (p > 1) (ppApplyType ty1 [ty2]) + where + ppApplyType (ApplyType _ ty1' ty2') tys = + ppApplyType ty1' (ty2' : tys) + ppApplyType ty tys = + pPrintPrec 1 ty <+> fsep (map (pPrintPrec 2) tys) + pPrintPrec _ (VariableType _ tv) = ppIdent tv + pPrintPrec _ (TupleType _ tys) = parenList (map (pPrintPrec 0) tys) + pPrintPrec _ (ListType _ ty) = brackets (pPrintPrec 0 ty) + pPrintPrec p (ArrowType spi ty1 ty2) = parenIf (p > 0) + (fsep (ppArrowType (ArrowType spi ty1 ty2))) + where + ppArrowType (ArrowType _ ty1' ty2') = + pPrintPrec 1 ty1' <+> rarrow : ppArrowType ty2' + ppArrowType ty = + [pPrintPrec 0 ty] + pPrintPrec _ (ParenType _ ty) = parens (pPrintPrec 0 ty) + pPrintPrec p (ForallType _ vs ty) + | null vs = pPrintPrec p ty + | otherwise = parenIf (p > 0) $ ppQuantifiedVars vs <+> pPrintPrec 0 ty + +-- --------------------------------------------------------------------------- +-- Literals +-- --------------------------------------------------------------------------- + +instance Pretty Literal where + pPrint (Char c) = text (show c) + pPrint (Int i) = integer i + pPrint (Float f) = double f + pPrint (String s) = text (show s) + +-- --------------------------------------------------------------------------- +-- Patterns +-- --------------------------------------------------------------------------- + +instance Pretty (Pattern a) where + pPrintPrec p (LiteralPattern _ _ l) = + parenIf (p > 1 && isNegative l) (pPrint l) + where + isNegative (Char _) = False + isNegative (Int i) = i < 0 + isNegative (Float f) = f < 0.0 + isNegative (String _) = False + pPrintPrec p (NegativePattern _ _ l) = parenIf (p > 1) + (ppInfixOp minusId <> pPrint l) + pPrintPrec _ (VariablePattern _ _ v) = ppIdent v + pPrintPrec p (ConstructorPattern _ _ c ts) = parenIf (p > 1 && not (null ts)) + (ppQIdent c <+> fsep (map (pPrintPrec 2) ts)) + pPrintPrec p (InfixPattern _ _ t1 c t2) = parenIf (p > 0) + (sep [pPrintPrec 1 t1 <+> ppQInfixOp c, indent (pPrintPrec 0 t2)]) + pPrintPrec _ (ParenPattern _ t) = parens (pPrintPrec 0 t) + pPrintPrec _ (TuplePattern _ ts) = + parenList (map (pPrintPrec 0) ts) + pPrintPrec _ (ListPattern _ _ ts) = + bracketList (map (pPrintPrec 0) ts) + pPrintPrec _ (AsPattern _ v t) = + ppIdent v <> char '@' <> pPrintPrec 2 t + pPrintPrec _ (LazyPattern _ t) = char '~' <> pPrintPrec 2 t + pPrintPrec p (FunctionPattern _ _ f ts) = parenIf (p > 1 && not (null ts)) + (ppQIdent f <+> fsep (map (pPrintPrec 2) ts)) + pPrintPrec p (InfixFuncPattern _ _ t1 f t2) = parenIf (p > 0) + (sep [pPrintPrec 1 t1 <+> ppQInfixOp f, indent (pPrintPrec 0 t2)]) + pPrintPrec p (RecordPattern _ _ c fs) = parenIf (p > 1) + (ppQIdent c <+> record (list (map pPrint fs))) + +instance Pretty a => Pretty (Field a) where + pPrint (Field _ l t) = ppQIdent l <+> equals <+> pPrintPrec 0 t + +-- --------------------------------------------------------------------------- +-- Expressions +-- --------------------------------------------------------------------------- + +ppCondExpr :: Doc -> CondExpr a -> Doc +ppCondExpr eq (CondExpr _ g e) = + vbar <+> sep [pPrintPrec 0 g <+> eq, indent (pPrintPrec 0 e)] + +instance Pretty (Expression a) where + pPrintPrec _ (Literal _ _ l) = pPrint l + pPrintPrec _ (Variable _ _ v) = ppQIdent v + pPrintPrec _ (Constructor _ _ c) = ppQIdent c + pPrintPrec _ (Paren _ e) = parens (pPrintPrec 0 e) + pPrintPrec p (Typed _ e ty) = + parenIf (p > 0) (pPrintPrec 0 e <+> text "::" <+> pPrintPrec 0 ty) + pPrintPrec _ (Tuple _ es) = parenList (map (pPrintPrec 0) es) + pPrintPrec _ (List _ _ es) = bracketList (map (pPrintPrec 0) es) + pPrintPrec _ (ListCompr _ e qs) = + brackets (pPrintPrec 0 e <+> vbar <+> list (map pPrint qs)) + pPrintPrec _ (EnumFrom _ e) = + brackets (pPrintPrec 0 e <+> text "..") + pPrintPrec _ (EnumFromThen _ e1 e2) = + brackets (pPrintPrec 0 e1 <> comma <+> pPrintPrec 0 e2 <+> text "..") + pPrintPrec _ (EnumFromTo _ e1 e2) = + brackets (pPrintPrec 0 e1 <+> text ".." <+> pPrintPrec 0 e2) + pPrintPrec _ (EnumFromThenTo _ e1 e2 e3) = + brackets (pPrintPrec 0 e1 <> comma <+> pPrintPrec 0 e2 + <+> text ".." <+> pPrintPrec 0 e3) + pPrintPrec p (UnaryMinus _ e) = + parenIf (p > 1) (ppInfixOp minusId <> pPrintPrec 1 e) + pPrintPrec p (Apply _ e1 e2) = + parenIf (p > 1) (sep [pPrintPrec 1 e1, indent (pPrintPrec 2 e2)]) + pPrintPrec p (InfixApply _ e1 op e2) = parenIf (p > 0) + (sep [pPrintPrec 1 e1 <+> ppQInfixOp (opName op), indent (pPrintPrec 1 e2)]) + pPrintPrec _ (LeftSection _ e op) = + parens (pPrintPrec 1 e <+> ppQInfixOp (opName op)) + pPrintPrec _ (RightSection _ op e) = + parens (ppQInfixOp (opName op) <+> pPrintPrec 1 e) + pPrintPrec p (Lambda _ t e) = parenIf (p > 0) $ + sep [backsl <> fsep (map (pPrintPrec 2) t) <+> rarrow, + indent (pPrintPrec 0 e)] + pPrintPrec p (Let _ _ ds e) = parenIf (p > 0) + (sep [text "let" <+> ppBlock ds, text "in" <+> pPrintPrec 0 e]) + pPrintPrec p (Do _ _ sts e) = parenIf (p > 0) + (text "do" <+> (vcat (map pPrint sts) $$ pPrintPrec 0 e)) + pPrintPrec p (IfThenElse _ e1 e2 e3) = parenIf (p > 0) + (text "if" <+> + sep [pPrintPrec 0 e1, + text "then" <+> pPrintPrec 0 e2, + text "else" <+> pPrintPrec 0 e3]) + pPrintPrec p (Case _ _ ct e alts) = parenIf (p > 0) + (pPrint ct <+> pPrintPrec 0 e <+> text "of" $$ + indent (vcat (map pPrint alts))) + pPrintPrec p (Record _ _ c fs) = parenIf (p > 0) + (ppQIdent c <+> record (list (map pPrint fs))) + pPrintPrec _ (RecordUpdate _ e fs) = + pPrintPrec 0 e <+> record (list (map pPrint fs)) + +instance Pretty (Statement a) where + pPrint (StmtExpr _ e) = pPrintPrec 0 e + pPrint (StmtBind _ t e) = + sep [pPrintPrec 0 t <+> larrow, indent (pPrintPrec 0 e)] + pPrint (StmtDecl _ _ ds) = text "let" <+> ppBlock ds + +instance Pretty CaseType where + pPrint Rigid = text "case" + pPrint Flex = text "fcase" + +instance Pretty (Alt a) where + pPrint (Alt _ t rhs) = ppRule (pPrintPrec 0 t) rarrow rhs + +instance Pretty (Var a) where + pPrint (Var _ ident) = ppIdent ident + +instance Pretty (InfixOp a) where + pPrint (InfixOp _ op) = ppQInfixOp op + pPrint (InfixConstr _ op) = ppQInfixOp op + +-- --------------------------------------------------------------------------- +-- Names +-- --------------------------------------------------------------------------- + +-- |Pretty print an identifier +ppIdent :: Ident -> Doc +ppIdent x = parenIf (isInfixOp x) (text (idName x)) + +ppQIdent :: QualIdent -> Doc +ppQIdent x = parenIf (isQInfixOp x) (text (qualName x)) + +ppInfixOp :: Ident -> Doc +ppInfixOp x = bquotesIf (not (isInfixOp x)) (text (idName x)) + +ppQInfixOp :: QualIdent -> Doc +ppQInfixOp x = bquotesIf (not (isQInfixOp x)) (text (qualName x)) + +ppMIdent :: ModuleIdent -> Doc +ppMIdent m = text (moduleName m) + +-- --------------------------------------------------------------------------- +-- Print printing utilities +-- --------------------------------------------------------------------------- + +indent :: Doc -> Doc +indent = nest 2 + +parenList :: [Doc] -> Doc +parenList = parens . list + +record :: Doc -> Doc +record doc | isEmpty doc = braces empty + | otherwise = braces $ space <> doc <> space + +bracketList :: [Doc] -> Doc +bracketList = brackets . list diff --git a/src/Curry/Syntax/ShowModule.hs b/src/Curry/Syntax/ShowModule.hs new file mode 100644 index 0000000000000000000000000000000000000000..41e6bc4e84cfcf71c496d043dda2177284b7f19d --- /dev/null +++ b/src/Curry/Syntax/ShowModule.hs @@ -0,0 +1,777 @@ +{- | + Module : $Header$ + Copyright : (c) 2008 Sebastian Fischer + 2011 - 2015 Björn Peemöller + 2016 Finn Teegen + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + Transform a CurrySyntax module into a string representation without any + pretty printing. + + Behaves like a derived Show instance even on parts with a specific one. +-} +module Curry.Syntax.ShowModule (showModule) where + +import Curry.Base.Ident +import Curry.Base.Position +import Curry.Base.Span +import Curry.Base.SpanInfo + +import Curry.Syntax.Type + +-- |Show a Curry module like by an devired 'Show' instance +showModule :: Show a => Module a -> String +showModule m = showsModule m "\n" + +showsModule :: Show a => Module a -> ShowS +showsModule (Module spi li ps mident espec imps decls) + = showsString "Module " + . showsLayoutInfo li . space + . showsSpanInfo spi . space + . showsList (\p -> showsPragma p . newline) ps . space + . showsModuleIdent mident . newline + . showsMaybe showsExportSpec espec . newline + . showsList (\i -> showsImportDecl i . newline) imps + . showsList (\d -> showsDecl d . newline) decls + +showsPragma :: ModulePragma -> ShowS +showsPragma (LanguagePragma pos exts) + = showsString "(LanguagePragma " + . showsSpanInfo pos . space + . showsList showsExtension exts + . showsString ")" +showsPragma (OptionsPragma pos mbTool args) + = showsString "(OptionsPragma " + . showsSpanInfo pos . space + . showsMaybe shows mbTool + . shows args + . showsString ")" + +showsExtension :: Extension -> ShowS +showsExtension (KnownExtension p e) + = showsString "(KnownExtension " + . showsSpanInfo p . space + . shows e + . showString ")" +showsExtension (UnknownExtension p s) + = showsString "(UnknownExtension " + . showsSpanInfo p . space + . shows s + . showString ")" + +showsExportSpec :: ExportSpec -> ShowS +showsExportSpec (Exporting pos exports) + = showsString "(Exporting " + . showsSpanInfo pos . space + . showsList showsExport exports + . showsString ")" + +showsExport :: Export -> ShowS +showsExport (Export spi qident) + = showsString "(Export " + . showsSpanInfo spi . space + . showsQualIdent qident + . showsString ")" +showsExport (ExportTypeWith spi qident ids) + = showsString "(ExportTypeWith " + . showsSpanInfo spi . space + . showsQualIdent qident . space + . showsList showsIdent ids + . showsString ")" +showsExport (ExportTypeAll spi qident) + = showsString "(ExportTypeAll " + . showsSpanInfo spi . space + . showsQualIdent qident + . showsString ")" +showsExport (ExportModule spi m) + = showsString "(ExportModule " + . showsSpanInfo spi . space + . showsModuleIdent m + . showsString ")" + +showsImportDecl :: ImportDecl -> ShowS +showsImportDecl (ImportDecl spi mident quali mmident mimpspec) + = showsString "(ImportDecl " + . showsSpanInfo spi . space + . showsModuleIdent mident . space + . shows quali . space + . showsMaybe showsModuleIdent mmident . space + . showsMaybe showsImportSpec mimpspec + . showsString ")" + +showsImportSpec :: ImportSpec -> ShowS +showsImportSpec (Importing spi imports) + = showsString "(Importing " + . showsSpanInfo spi . space + . showsList showsImport imports + . showsString ")" +showsImportSpec (Hiding spi imports) + = showsString "(Hiding " + . showsSpanInfo spi . space + . showsList showsImport imports + . showsString ")" + +showsImport :: Import -> ShowS +showsImport (Import spi ident) + = showsString "(Import " + . showsSpanInfo spi . space + . showsIdent ident + . showsString ")" +showsImport (ImportTypeWith spi ident idents) + = showsString "(ImportTypeWith " + . showsSpanInfo spi . space + . showsIdent ident . space + . showsList showsIdent idents + . showsString ")" +showsImport (ImportTypeAll spi ident) + = showsString "(ImportTypeAll " + . showsSpanInfo spi . space + . showsIdent ident + . showsString ")" + +showsDecl :: Show a => Decl a -> ShowS +showsDecl (InfixDecl spi infx prec idents) + = showsString "(InfixDecl " + . showsSpanInfo spi . space + . shows infx . space + . showsMaybe shows prec . space + . showsList showsIdent idents + . showsString ")" +showsDecl (DataDecl spi ident idents consdecls classes) + = showsString "(DataDecl " + . showsSpanInfo spi . space + . showsIdent ident . space + . showsList showsIdent idents . space + . showsList showsConsDecl consdecls . space + . showsList showsQualIdent classes + . showsString ")" +showsDecl (ExternalDataDecl spi ident idents) + = showsString "(ExternalDataDecl " + . showsSpanInfo spi . space + . showsIdent ident . space + . showsList showsIdent idents + . showsString ")" +showsDecl (NewtypeDecl spi ident idents newconsdecl classes) + = showsString "(NewtypeDecl " + . showsSpanInfo spi . space + . showsIdent ident . space + . showsList showsIdent idents . space + . showsNewConsDecl newconsdecl . space + . showsList showsQualIdent classes + . showsString ")" +showsDecl (TypeDecl spi ident idents typ) + = showsString "(TypeDecl " + . showsSpanInfo spi . space + . showsIdent ident . space + . showsList showsIdent idents . space + . showsTypeExpr typ + . showsString ")" +showsDecl (TypeSig spi idents qtype) + = showsString "(TypeSig " + . showsSpanInfo spi . space + . showsList showsIdent idents . space + . showsQualTypeExpr qtype + . showsString ")" +showsDecl (FunctionDecl spi a ident eqs) + = showsString "(FunctionDecl " + . showsSpanInfo spi . space + . showsPrec 11 a . space + . showsIdent ident . space + . showsList showsEquation eqs + . showsString ")" +showsDecl (ExternalDecl spi vars) + = showsString "(ExternalDecl " + . showsSpanInfo spi . space + . showsList showsVar vars + . showsString ")" +showsDecl (PatternDecl spi cons rhs) + = showsString "(PatternDecl " + . showsSpanInfo spi . space + . showsConsTerm cons . space + . showsRhs rhs + . showsString ")" +showsDecl (FreeDecl spi vars) + = showsString "(FreeDecl " + . showsSpanInfo spi . space + . showsList showsVar vars + . showsString ")" +showsDecl (DefaultDecl spi types) + = showsString "(DefaultDecl " + . showsSpanInfo spi . space + . showsList showsTypeExpr types + . showsString ")" +showsDecl (ClassDecl spi li context cls clsvar decls) + = showsString "(ClassDecl " + . showsSpanInfo spi . space + . showsLayoutInfo li . space + . showsContext context . space + . showsIdent cls . space + . showsIdent clsvar . space + . showsList showsDecl decls + . showsString ")" +showsDecl (InstanceDecl spi li context qcls inst decls) + = showsString "(InstanceDecl " + . showsSpanInfo spi . space + . showsLayoutInfo li . space + . showsContext context . space + . showsQualIdent qcls . space + . showsInstanceType inst . space + . showsList showsDecl decls + . showsString ")" + +showsContext :: Context -> ShowS +showsContext = showsList showsConstraint + +showsConstraint :: Constraint -> ShowS +showsConstraint (Constraint spi qcls ty) + = showsString "(Constraint " + . showsSpanInfo spi . space + . showsQualIdent qcls . space + . showsTypeExpr ty + . showsString ")" + +showsInstanceType :: InstanceType -> ShowS +showsInstanceType = showsTypeExpr + +showsConsDecl :: ConstrDecl -> ShowS +showsConsDecl (ConstrDecl spi ident types) + = showsString "(ConstrDecl " + . showsSpanInfo spi . space + . showsIdent ident . space + . showsList showsTypeExpr types + . showsString ")" +showsConsDecl (ConOpDecl spi ty1 ident ty2) + = showsString "(ConOpDecl " + . showsSpanInfo spi . space + . showsTypeExpr ty1 . space + . showsIdent ident . space + . showsTypeExpr ty2 + . showsString ")" +showsConsDecl (RecordDecl spi ident fs) + = showsString "(RecordDecl " + . showsSpanInfo spi . space + . showsIdent ident . space + . showsList showsFieldDecl fs + . showsString ")" + +showsFieldDecl :: FieldDecl -> ShowS +showsFieldDecl (FieldDecl spi labels ty) + = showsString "(FieldDecl " + . showsSpanInfo spi . space + . showsList showsIdent labels . space + . showsTypeExpr ty + . showsString ")" + +showsNewConsDecl :: NewConstrDecl -> ShowS +showsNewConsDecl (NewConstrDecl spi ident typ) + = showsString "(NewConstrDecl " + . showsSpanInfo spi . space + . showsIdent ident . space + . showsTypeExpr typ + . showsString ")" +showsNewConsDecl (NewRecordDecl spi ident fld) + = showsString "(NewRecordDecl " + . showsSpanInfo spi . space + . showsIdent ident . space + . showsPair showsIdent showsTypeExpr fld + . showsString ")" + +showsQualTypeExpr :: QualTypeExpr -> ShowS +showsQualTypeExpr (QualTypeExpr spi context typ) + = showsString "(QualTypeExpr " + . showsSpanInfo spi . space + . showsContext context . space + . showsTypeExpr typ + . showsString ")" + +showsTypeExpr :: TypeExpr -> ShowS +showsTypeExpr (ConstructorType spi qident) + = showsString "(ConstructorType " + . showsSpanInfo spi . space + . showsQualIdent qident . space + . showsString ")" +showsTypeExpr (ApplyType spi type1 type2) + = showsString "(ApplyType " + . showsSpanInfo spi . space + . showsTypeExpr type1 . space + . showsTypeExpr type2 . space + . showsString ")" +showsTypeExpr (VariableType spi ident) + = showsString "(VariableType " + . showsSpanInfo spi . space + . showsIdent ident + . showsString ")" +showsTypeExpr (TupleType spi types) + = showsString "(TupleType " + . showsSpanInfo spi . space + . showsList showsTypeExpr types + . showsString ")" +showsTypeExpr (ListType spi typ) + = showsString "(ListType " + . showsSpanInfo spi . space + . showsTypeExpr typ + . showsString ")" +showsTypeExpr (ArrowType spi dom ran) + = showsString "(ArrowType " + . showsSpanInfo spi . space + . showsTypeExpr dom . space + . showsTypeExpr ran + . showsString ")" +showsTypeExpr (ParenType spi ty) + = showsString "(ParenType " + . showsSpanInfo spi . space + . showsTypeExpr ty + . showsString ")" +showsTypeExpr (ForallType spi vars ty) + = showsString "(ForallType " + . showsSpanInfo spi . space + . showsList showsIdent vars + . showsTypeExpr ty + . showsString ")" + +showsEquation :: Show a => Equation a -> ShowS +showsEquation (Equation spi lhs rhs) + = showsString "(Equation " + . showsSpanInfo spi . space + . showsLhs lhs . space + . showsRhs rhs + . showsString ")" + +showsLhs :: Show a => Lhs a -> ShowS +showsLhs (FunLhs spi ident conss) + = showsString "(FunLhs " + . showsSpanInfo spi . space + . showsIdent ident . space + . showsList showsConsTerm conss + . showsString ")" +showsLhs (OpLhs spi cons1 ident cons2) + = showsString "(OpLhs " + . showsSpanInfo spi . space + . showsConsTerm cons1 . space + . showsIdent ident . space + . showsConsTerm cons2 + . showsString ")" +showsLhs (ApLhs spi lhs conss) + = showsString "(ApLhs " + . showsSpanInfo spi . space + . showsLhs lhs . space + . showsList showsConsTerm conss + . showsString ")" + +showsRhs :: Show a => Rhs a -> ShowS +showsRhs (SimpleRhs spi li expr decls) + = showsString "(SimpleRhs " + . showsSpanInfo spi . space + . showsLayoutInfo li . space + . showsExpression expr . space + . showsList showsDecl decls + . showsString ")" +showsRhs (GuardedRhs spi li cexps decls) + = showsString "(GuardedRhs " + . showsSpanInfo spi . space + . showsLayoutInfo li . space + . showsList showsCondExpr cexps . space + . showsList showsDecl decls + . showsString ")" + +showsCondExpr :: Show a => CondExpr a -> ShowS +showsCondExpr (CondExpr spi exp1 exp2) + = showsString "(CondExpr " + . showsSpanInfo spi . space + . showsExpression exp1 . space + . showsExpression exp2 + . showsString ")" + +showsLiteral :: Literal -> ShowS +showsLiteral (Char c) + = showsString "(Char " + . shows c + . showsString ")" +showsLiteral (Int n) + = showsString "(Int " + . shows n + . showsString ")" +showsLiteral (Float x) + = showsString "(Float " + . shows x + . showsString ")" +showsLiteral (String s) + = showsString "(String " + . shows s + . showsString ")" + +showsConsTerm :: Show a => Pattern a -> ShowS +showsConsTerm (LiteralPattern spi a lit) + = showsString "(LiteralPattern " + . showsSpanInfo spi . space + . showsPrec 11 a . space + . showsLiteral lit + . showsString ")" +showsConsTerm (NegativePattern spi a lit) + = showsString "(NegativePattern " + . showsSpanInfo spi . space + . showsPrec 11 a . space + . showsLiteral lit + . showsString ")" +showsConsTerm (VariablePattern spi a ident) + = showsString "(VariablePattern " + . showsSpanInfo spi . space + . showsPrec 11 a . space + . showsIdent ident + . showsString ")" +showsConsTerm (ConstructorPattern spi a qident conss) + = showsString "(ConstructorPattern " + . showsSpanInfo spi . space + . showsPrec 11 a . space + . showsQualIdent qident . space + . showsList showsConsTerm conss + . showsString ")" +showsConsTerm (InfixPattern spi a cons1 qident cons2) + = showsString "(InfixPattern " + . showsSpanInfo spi . space + . showsPrec 11 a . space + . showsConsTerm cons1 . space + . showsQualIdent qident . space + . showsConsTerm cons2 + . showsString ")" +showsConsTerm (ParenPattern spi cons) + = showsString "(ParenPattern " + . showsSpanInfo spi . space + . showsConsTerm cons + . showsString ")" +showsConsTerm (TuplePattern spi conss) + = showsString "(TuplePattern " + . showsSpanInfo spi . space + . showsList showsConsTerm conss + . showsString ")" +showsConsTerm (ListPattern spi a conss) + = showsString "(ListPattern " + . showsSpanInfo spi . space + . showsPrec 11 a . space + . showsList showsConsTerm conss + . showsString ")" +showsConsTerm (AsPattern spi ident cons) + = showsString "(AsPattern " + . showsSpanInfo spi . space + . showsIdent ident . space + . showsConsTerm cons + . showsString ")" +showsConsTerm (LazyPattern spi cons) + = showsString "(LazyPattern " + . showsSpanInfo spi . space + . showsConsTerm cons + . showsString ")" +showsConsTerm (FunctionPattern spi a qident conss) + = showsString "(FunctionPattern " + . showsSpanInfo spi . space + . showsPrec 11 a . space + . showsQualIdent qident . space + . showsList showsConsTerm conss + . showsString ")" +showsConsTerm (InfixFuncPattern spi a cons1 qident cons2) + = showsString "(InfixFuncPattern " + . showsSpanInfo spi . space + . showsPrec 11 a . space + . showsConsTerm cons1 . space + . showsQualIdent qident . space + . showsConsTerm cons2 + . showsString ")" +showsConsTerm (RecordPattern spi a qident cfields) + = showsString "(RecordPattern " + . showsSpanInfo spi . space + . showsPrec 11 a . space + . showsQualIdent qident . space + . showsList (showsField showsConsTerm) cfields . space + . showsString ")" + +showsExpression :: Show a => Expression a -> ShowS +showsExpression (Literal spi a lit) + = showsString "(Literal " + . showsSpanInfo spi . space + . showsPrec 11 a . space + . showsLiteral lit + . showsString ")" +showsExpression (Variable spi a qident) + = showsString "(Variable " + . showsSpanInfo spi . space + . showsPrec 11 a . space + . showsQualIdent qident + . showsString ")" +showsExpression (Constructor spi a qident) + = showsString "(Constructor " + . showsSpanInfo spi . space + . showsPrec 11 a . space + . showsQualIdent qident + . showsString ")" +showsExpression (Paren spi expr) + = showsString "(Paren " + . showsSpanInfo spi . space + . showsExpression expr + . showsString ")" +showsExpression (Typed spi expr qtype) + = showsString "(Typed " + . showsSpanInfo spi . space + . showsExpression expr . space + . showsQualTypeExpr qtype + . showsString ")" +showsExpression (Tuple spi exps) + = showsString "(Tuple " + . showsSpanInfo spi . space + . showsList showsExpression exps + . showsString ")" +showsExpression (List spi a exps) + = showsString "(List " + . showsSpanInfo spi . space + . showsPrec 11 a . space + . showsList showsExpression exps + . showsString ")" +showsExpression (ListCompr spi expr stmts) + = showsString "(ListCompr " + . showsSpanInfo spi . space + . showsExpression expr . space + . showsList showsStatement stmts + . showsString ")" +showsExpression (EnumFrom spi expr) + = showsString "(EnumFrom " + . showsSpanInfo spi . space + . showsExpression expr + . showsString ")" +showsExpression (EnumFromThen spi exp1 exp2) + = showsString "(EnumFromThen " + . showsSpanInfo spi . space + . showsExpression exp1 . space + . showsExpression exp2 + . showsString ")" +showsExpression (EnumFromTo spi exp1 exp2) + = showsString "(EnumFromTo " + . showsSpanInfo spi . space + . showsExpression exp1 . space + . showsExpression exp2 + . showsString ")" +showsExpression (EnumFromThenTo spi exp1 exp2 exp3) + = showsString "(EnumFromThenTo " + . showsSpanInfo spi . space + . showsExpression exp1 . space + . showsExpression exp2 . space + . showsExpression exp3 + . showsString ")" +showsExpression (UnaryMinus spi expr) + = showsString "(UnaryMinus " + . showsSpanInfo spi . space + . showsExpression expr + . showsString ")" +showsExpression (Apply spi exp1 exp2) + = showsString "(Apply " + . showsSpanInfo spi . space + . showsExpression exp1 . space + . showsExpression exp2 + . showsString ")" +showsExpression (InfixApply spi exp1 op exp2) + = showsString "(InfixApply " + . showsSpanInfo spi . space + . showsExpression exp1 . space + . showsInfixOp op . space + . showsExpression exp2 + . showsString ")" +showsExpression (LeftSection spi expr op) + = showsString "(LeftSection " + . showsSpanInfo spi . space + . showsExpression expr . space + . showsInfixOp op + . showsString ")" +showsExpression (RightSection spi op expr) + = showsString "(RightSection " + . showsSpanInfo spi . space + . showsInfixOp op . space + . showsExpression expr + . showsString ")" +showsExpression (Lambda spi conss expr) + = showsString "(Lambda " + . showsSpanInfo spi . space + . showsList showsConsTerm conss . space + . showsExpression expr + . showsString ")" +showsExpression (Let spi li decls expr) + = showsString "(Let " + . showsSpanInfo spi . space + . showsLayoutInfo li . space + . showsList showsDecl decls . space + . showsExpression expr + . showsString ")" +showsExpression (Do spi li stmts expr) + = showsString "(Do " + . showsSpanInfo spi . space + . showsLayoutInfo li . space + . showsList showsStatement stmts . space + . showsExpression expr + . showsString ")" +showsExpression (IfThenElse spi exp1 exp2 exp3) + = showsString "(IfThenElse " + . showsSpanInfo spi . space + . showsExpression exp1 . space + . showsExpression exp2 . space + . showsExpression exp3 + . showsString ")" +showsExpression (Case spi li ct expr alts) + = showsString "(Case " + . showsSpanInfo spi . space + . showsLayoutInfo li . space + . showsCaseType ct . space + . showsExpression expr . space + . showsList showsAlt alts + . showsString ")" +showsExpression (RecordUpdate spi expr efields) + = showsString "(RecordUpdate " + . showsSpanInfo spi . space + . showsExpression expr . space + . showsList (showsField showsExpression) efields + . showsString ")" +showsExpression (Record spi a qident efields) + = showsString "(Record " + . showsSpanInfo spi . space + . showsPrec 11 a . space + . showsQualIdent qident . space + . showsList (showsField showsExpression) efields + . showsString ")" + +showsInfixOp :: Show a => InfixOp a -> ShowS +showsInfixOp (InfixOp a qident) + = showsString "(InfixOp " + . showsPrec 11 a . space + . showsQualIdent qident + . showsString ")" +showsInfixOp (InfixConstr a qident) + = showsString "(InfixConstr " + . showsPrec 11 a . space + . showsQualIdent qident + . showsString ")" + +showsStatement :: Show a => Statement a -> ShowS +showsStatement (StmtExpr spi expr) + = showsString "(StmtExpr " + . showsSpanInfo spi . space + . showsExpression expr + . showsString ")" +showsStatement (StmtDecl spi li decls) + = showsString "(StmtDecl " + . showsSpanInfo spi . space + . showsLayoutInfo li . space + . showsList showsDecl decls + . showsString ")" +showsStatement (StmtBind spi cons expr) + = showsString "(StmtBind " + . showsSpanInfo spi . space + . showsConsTerm cons . space + . showsExpression expr + . showsString ")" + +showsCaseType :: CaseType -> ShowS +showsCaseType Rigid = showsString "Rigid" +showsCaseType Flex = showsString "Flex" + +showsAlt :: Show a => Alt a -> ShowS +showsAlt (Alt spi cons rhs) + = showsString "(Alt " + . showsSpanInfo spi . space + . showsConsTerm cons . space + . showsRhs rhs + . showsString ")" + +showsField :: (a -> ShowS) -> Field a -> ShowS +showsField sa (Field spi ident a) + = showsString "(Field " + . showsSpanInfo spi . space + . showsQualIdent ident . space + . sa a + . showsString ")" + +showsVar :: Show a => Var a -> ShowS +showsVar (Var a ident) + = showsString "(Var " + . showsPrec 11 a . space + . showsIdent ident + . showsString ")" + +showsPosition :: Position -> ShowS +showsPosition NoPos = showsString "NoPos" +showsPosition Position { line = l, column = c } + = showsString "(Position " + . shows l . space + . shows c + . showsString ")" + +showsSpanInfo :: SpanInfo -> ShowS +showsSpanInfo NoSpanInfo = showsString "NoSpanInfo" +showsSpanInfo SpanInfo { srcSpan = sp, srcInfoPoints = ss } + = showsString "(SpanInfo " + . showsSpan sp . space + . showsList showsSpan ss + . showsString ")" + +showsLayoutInfo :: LayoutInfo -> ShowS +showsLayoutInfo WhitespaceLayout = showsString "WhitespaceLayout" +showsLayoutInfo (ExplicitLayout ss) + = showsString "(ExplicitLayout " + . showsList showsSpan ss + . showsString ")" + +showsSpan :: Span -> ShowS +showsSpan NoSpan = showsString "NoSpan" +showsSpan Span { start = s, end = e } + = showsString "(Span " + . showsPosition s . space + . showsPosition e + . showsString ")" + +showsString :: String -> ShowS +showsString = (++) + +space :: ShowS +space = showsString " " + +newline :: ShowS +newline = showsString "\n" + +showsMaybe :: (a -> ShowS) -> Maybe a -> ShowS +showsMaybe shs = maybe (showsString "Nothing") + (\x -> showsString "(Just " . shs x . showsString ")") + +showsList :: (a -> ShowS) -> [a] -> ShowS +showsList _ [] = showsString "[]" +showsList shs (x:xs) + = showsString "[" + . foldl (\sys y -> sys . showsString "," . shs y) (shs x) xs + . showsString "]" + +showsPair :: (a -> ShowS) -> (b -> ShowS) -> (a,b) -> ShowS +showsPair sa sb (a,b) + = showsString "(" . sa a . showsString "," . sb b . showsString ")" + +showsIdent :: Ident -> ShowS +showsIdent (Ident spi x n) + = showsString "(Ident " . showsSpanInfo spi . space + . shows x . space . shows n . showsString ")" + +showsQualIdent :: QualIdent -> ShowS +showsQualIdent (QualIdent spi mident ident) + = showsString "(QualIdent " + . showsSpanInfo spi . space + . showsMaybe showsModuleIdent mident + . space + . showsIdent ident + . showsString ")" + +showsModuleIdent :: ModuleIdent -> ShowS +showsModuleIdent (ModuleIdent spi ss) + = showsString "(ModuleIdent " + . showsSpanInfo spi . space + . showsList (showsQuotes showsString) ss + . showsString ")" + +showsQuotes :: (a -> ShowS) -> a -> ShowS +showsQuotes sa a + = showsString "\"" . sa a . showsString "\"" diff --git a/src/Curry/Syntax/Type.hs b/src/Curry/Syntax/Type.hs new file mode 100644 index 0000000000000000000000000000000000000000..00bec00ed4a972a61735f85e6b330baecd06e06e --- /dev/null +++ b/src/Curry/Syntax/Type.hs @@ -0,0 +1,1540 @@ +{- | + Module : $Header$ + Description : Abstract syntax for Curry + Copyright : (c) 1999 - 2004 Wolfgang Lux + 2005 Martin Engelke + 2011 - 2015 Björn Peemöller + 2014 Jan Rasmus Tikovsky + 2016 Finn Teegen + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This module provides the necessary data structures to maintain the + parsed representation of a Curry program. +-} + +module Curry.Syntax.Type + ( -- * Module header + Module (..) + -- ** Module pragmas + , ModulePragma (..), Extension (..), KnownExtension (..), Tool (..) + -- ** Export specification + , ExportSpec (..), Export (..) + -- ** Import declarations + , ImportDecl (..), ImportSpec (..), Import (..), Qualified + -- * Interface + , Interface (..), IImportDecl (..), Arity, IDecl (..), KindExpr (..) + , IMethodDecl (..), IMethodImpl + -- * Declarations + , Decl (..), Precedence, Infix (..), ConstrDecl (..), NewConstrDecl (..) + , FieldDecl (..) + , TypeExpr (..), QualTypeExpr (..) + , Equation (..), Lhs (..), Rhs (..), CondExpr (..) + , Literal (..), Pattern (..), Expression (..), InfixOp (..) + , Statement (..), CaseType (..), Alt (..), Field (..), Var (..) + -- * Type classes + , Context, Constraint (..), InstanceType + -- * Goals + , Goal (..) + ) where + +import Data.Binary +import Control.Monad + +import Curry.Base.Ident +import Curry.Base.Position +import Curry.Base.SpanInfo +import Curry.Base.Span +import Curry.Base.Pretty (Pretty(..)) + +import Curry.Syntax.Extension + +import Text.PrettyPrint + +-- --------------------------------------------------------------------------- +-- Modules +-- --------------------------------------------------------------------------- + +-- |Curry module +data Module a = Module SpanInfo LayoutInfo [ModulePragma] ModuleIdent + (Maybe ExportSpec) [ImportDecl] [Decl a] + deriving (Eq, Read, Show) + +-- |Module pragma +data ModulePragma + = LanguagePragma SpanInfo [Extension] -- ^ language pragma + | OptionsPragma SpanInfo (Maybe Tool) String -- ^ options pragma + deriving (Eq, Read, Show) + +-- |Export specification +data ExportSpec = Exporting SpanInfo [Export] + deriving (Eq, Read, Show) + +-- |Single exported entity +data Export + = Export SpanInfo QualIdent -- f/T + | ExportTypeWith SpanInfo QualIdent [Ident] -- T (C1,...,Cn) + | ExportTypeAll SpanInfo QualIdent -- T (..) + | ExportModule SpanInfo ModuleIdent -- module M + deriving (Eq, Read, Show) + +-- |Import declaration +data ImportDecl = ImportDecl SpanInfo ModuleIdent Qualified + (Maybe ModuleIdent) (Maybe ImportSpec) + deriving (Eq, Read, Show) + +-- |Flag to signal qualified import +type Qualified = Bool + +-- |Import specification +data ImportSpec + = Importing SpanInfo [Import] + | Hiding SpanInfo [Import] + deriving (Eq, Read, Show) + +-- |Single imported entity +data Import + = Import SpanInfo Ident -- f/T + | ImportTypeWith SpanInfo Ident [Ident] -- T (C1,...,Cn) + | ImportTypeAll SpanInfo Ident -- T (..) + deriving (Eq, Read, Show) + +-- --------------------------------------------------------------------------- +-- Module interfaces +-- --------------------------------------------------------------------------- + +-- | Module interface +-- +-- Interface declarations are restricted to type declarations and signatures. +-- Note that an interface function declaration additionaly contains the +-- function arity (= number of parameters) in order to generate +-- correct FlatCurry function applications. +data Interface = Interface ModuleIdent [IImportDecl] [IDecl] + deriving (Eq, Read, Show) + +-- |Interface import declaration +data IImportDecl = IImportDecl Position ModuleIdent + deriving (Eq, Read, Show) + +-- |Arity of a function +type Arity = Int + +-- |Interface declaration +data IDecl + = IInfixDecl Position Infix Precedence QualIdent + | HidingDataDecl Position QualIdent (Maybe KindExpr) [Ident] + | IDataDecl Position QualIdent (Maybe KindExpr) [Ident] [ConstrDecl] [Ident] + | INewtypeDecl Position QualIdent (Maybe KindExpr) [Ident] NewConstrDecl [Ident] + | ITypeDecl Position QualIdent (Maybe KindExpr) [Ident] TypeExpr + | IFunctionDecl Position QualIdent (Maybe Ident) Arity QualTypeExpr + | HidingClassDecl Position Context QualIdent (Maybe KindExpr) Ident + | IClassDecl Position Context QualIdent (Maybe KindExpr) Ident [IMethodDecl] [Ident] + | IInstanceDecl Position Context QualIdent InstanceType [IMethodImpl] (Maybe ModuleIdent) + deriving (Eq, Read, Show) + +-- |Class methods +data IMethodDecl = IMethodDecl Position Ident (Maybe Arity) QualTypeExpr + deriving (Eq, Read, Show) + +-- |Class method implementations +type IMethodImpl = (Ident, Arity) + +-- |Kind expressions +data KindExpr + = Star + | ArrowKind KindExpr KindExpr + deriving (Eq, Read, Show) + +-- --------------------------------------------------------------------------- +-- Declarations (local or top-level) +-- --------------------------------------------------------------------------- + +-- |Declaration in a module +data Decl a + = InfixDecl SpanInfo Infix (Maybe Precedence) [Ident] -- infixl 5 (op), `fun` + | DataDecl SpanInfo Ident [Ident] [ConstrDecl] [QualIdent] -- data C a b = C1 a | C2 b deriving (D, ...) + | ExternalDataDecl SpanInfo Ident [Ident] -- external data C a b + | NewtypeDecl SpanInfo Ident [Ident] NewConstrDecl [QualIdent] -- newtype C a b = C a b deriving (D, ...) + | TypeDecl SpanInfo Ident [Ident] TypeExpr -- type C a b = D a b + | TypeSig SpanInfo [Ident] QualTypeExpr -- f, g :: Bool + | FunctionDecl SpanInfo a Ident [Equation a] -- f True = 1 ; f False = 0 + | ExternalDecl SpanInfo [Var a] -- f, g external + | PatternDecl SpanInfo (Pattern a) (Rhs a) -- Just x = ... + | FreeDecl SpanInfo [Var a] -- x, y free + | DefaultDecl SpanInfo [TypeExpr] -- default (Int, Float) + | ClassDecl SpanInfo LayoutInfo Context Ident Ident [Decl a] -- class C a => D a where {TypeSig|InfixDecl|FunctionDecl} + | InstanceDecl SpanInfo LayoutInfo Context QualIdent InstanceType [Decl a] -- instance C a => M.D (N.T a b c) where {FunctionDecl} + deriving (Eq, Read, Show) + +-- --------------------------------------------------------------------------- +-- Infix declaration +-- --------------------------------------------------------------------------- + +-- |Operator precedence +type Precedence = Integer + +-- |Fixity of operators +data Infix + = InfixL -- ^ left-associative + | InfixR -- ^ right-associative + | Infix -- ^ no associativity + deriving (Eq, Read, Show) + +-- |Constructor declaration for algebraic data types +data ConstrDecl + = ConstrDecl SpanInfo Ident [TypeExpr] + | ConOpDecl SpanInfo TypeExpr Ident TypeExpr + | RecordDecl SpanInfo Ident [FieldDecl] + deriving (Eq, Read, Show) + +-- |Constructor declaration for renaming types (newtypes) +data NewConstrDecl + = NewConstrDecl SpanInfo Ident TypeExpr + | NewRecordDecl SpanInfo Ident (Ident, TypeExpr) + deriving (Eq, Read, Show) + +-- |Declaration for labelled fields +data FieldDecl = FieldDecl SpanInfo [Ident] TypeExpr + deriving (Eq, Read, Show) + +-- |Type expressions +data TypeExpr + = ConstructorType SpanInfo QualIdent + | ApplyType SpanInfo TypeExpr TypeExpr + | VariableType SpanInfo Ident + | TupleType SpanInfo [TypeExpr] + | ListType SpanInfo TypeExpr + | ArrowType SpanInfo TypeExpr TypeExpr + | ParenType SpanInfo TypeExpr + | ForallType SpanInfo [Ident] TypeExpr + deriving (Eq, Read, Show) + +-- |Qualified type expressions +data QualTypeExpr = QualTypeExpr SpanInfo Context TypeExpr + deriving (Eq, Read, Show) + +-- --------------------------------------------------------------------------- +-- Type classes +-- --------------------------------------------------------------------------- + +type Context = [Constraint] + +data Constraint = Constraint SpanInfo QualIdent TypeExpr + deriving (Eq, Read, Show) + +type InstanceType = TypeExpr + +-- --------------------------------------------------------------------------- +-- Functions +-- --------------------------------------------------------------------------- + +-- |Function defining equation +data Equation a = Equation SpanInfo (Lhs a) (Rhs a) + deriving (Eq, Read, Show) + +-- |Left-hand-side of an 'Equation' (function identifier and patterns) +data Lhs a + = FunLhs SpanInfo Ident [Pattern a] -- f x y + | OpLhs SpanInfo (Pattern a) Ident (Pattern a) -- x $ y + | ApLhs SpanInfo (Lhs a) [Pattern a] -- ($) x y + deriving (Eq, Read, Show) + +-- |Right-hand-side of an 'Equation' +data Rhs a + = SimpleRhs SpanInfo LayoutInfo (Expression a) [Decl a] -- @expr where decls@ + | GuardedRhs SpanInfo LayoutInfo [CondExpr a] [Decl a] -- @| cond = expr where decls@ + deriving (Eq, Read, Show) + +-- |Conditional expression (expression conditioned by a guard) +data CondExpr a = CondExpr SpanInfo (Expression a) (Expression a) + deriving (Eq, Read, Show) + +-- |Literal +data Literal + = Char Char + | Int Integer + | Float Double + | String String + deriving (Eq, Read, Show) + +-- |Constructor term (used for patterns) +data Pattern a + = LiteralPattern SpanInfo a Literal + | NegativePattern SpanInfo a Literal + | VariablePattern SpanInfo a Ident + | ConstructorPattern SpanInfo a QualIdent [Pattern a] + | InfixPattern SpanInfo a (Pattern a) QualIdent (Pattern a) + | ParenPattern SpanInfo (Pattern a) + | RecordPattern SpanInfo a QualIdent [Field (Pattern a)] -- C { l1 = p1, ..., ln = pn } + | TuplePattern SpanInfo [Pattern a] + | ListPattern SpanInfo a [Pattern a] + | AsPattern SpanInfo Ident (Pattern a) + | LazyPattern SpanInfo (Pattern a) + | FunctionPattern SpanInfo a QualIdent [Pattern a] + | InfixFuncPattern SpanInfo a (Pattern a) QualIdent (Pattern a) + deriving (Eq, Read, Show) + +-- |Expression +data Expression a + = Literal SpanInfo a Literal + | Variable SpanInfo a QualIdent + | Constructor SpanInfo a QualIdent + | Paren SpanInfo (Expression a) + | Typed SpanInfo (Expression a) QualTypeExpr + | Record SpanInfo a QualIdent [Field (Expression a)] -- C {l1 = e1,..., ln = en} + | RecordUpdate SpanInfo (Expression a) [Field (Expression a)] -- e {l1 = e1,..., ln = en} + | Tuple SpanInfo [Expression a] + | List SpanInfo a [Expression a] + | ListCompr SpanInfo (Expression a) [Statement a] -- the ref corresponds to the main list + | EnumFrom SpanInfo (Expression a) + | EnumFromThen SpanInfo (Expression a) (Expression a) + | EnumFromTo SpanInfo (Expression a) (Expression a) + | EnumFromThenTo SpanInfo (Expression a) (Expression a) (Expression a) + | UnaryMinus SpanInfo (Expression a) + | Apply SpanInfo (Expression a) (Expression a) + | InfixApply SpanInfo (Expression a) (InfixOp a) (Expression a) + | LeftSection SpanInfo (Expression a) (InfixOp a) + | RightSection SpanInfo (InfixOp a) (Expression a) + | Lambda SpanInfo [Pattern a] (Expression a) + | Let SpanInfo LayoutInfo [Decl a] (Expression a) + | Do SpanInfo LayoutInfo [Statement a] (Expression a) + | IfThenElse SpanInfo (Expression a) (Expression a) (Expression a) + | Case SpanInfo LayoutInfo CaseType (Expression a) [Alt a] + deriving (Eq, Read, Show) + +-- |Infix operation +data InfixOp a + = InfixOp a QualIdent + | InfixConstr a QualIdent + deriving (Eq, Read, Show) + +-- |Statement (used for do-sequence and list comprehensions) +data Statement a + = StmtExpr SpanInfo (Expression a) + | StmtDecl SpanInfo LayoutInfo [Decl a] + | StmtBind SpanInfo (Pattern a) (Expression a) + deriving (Eq, Read, Show) + +-- |Type of case expressions +data CaseType + = Rigid + | Flex + deriving (Eq, Read, Show) + +-- |Single case alternative +data Alt a = Alt SpanInfo (Pattern a) (Rhs a) + deriving (Eq, Read, Show) + +-- |Record field +data Field a = Field SpanInfo QualIdent a + deriving (Eq, Read, Show) + +-- |Annotated identifier +data Var a = Var a Ident + deriving (Eq, Read, Show) + +-- --------------------------------------------------------------------------- +-- Goals +-- --------------------------------------------------------------------------- + +-- |Goal in REPL (expression to evaluate) +data Goal a = Goal SpanInfo LayoutInfo (Expression a) [Decl a] + deriving (Eq, Read, Show) + +-- --------------------------------------------------------------------------- +-- instances +-- --------------------------------------------------------------------------- + +instance Functor Module where + fmap f (Module sp li ps m es is ds) = Module sp li ps m es is (map (fmap f) ds) + +instance Functor Decl where + fmap _ (InfixDecl sp fix prec ops) = InfixDecl sp fix prec ops + fmap _ (DataDecl sp tc tvs cs clss) = DataDecl sp tc tvs cs clss + fmap _ (ExternalDataDecl sp tc tvs) = ExternalDataDecl sp tc tvs + fmap _ (NewtypeDecl sp tc tvs nc clss) = NewtypeDecl sp tc tvs nc clss + fmap _ (TypeDecl sp tc tvs ty) = TypeDecl sp tc tvs ty + fmap _ (TypeSig sp fs qty) = TypeSig sp fs qty + fmap f (FunctionDecl sp a f' eqs) = FunctionDecl sp (f a) f' (map (fmap f) eqs) + fmap f (ExternalDecl sp vs) = ExternalDecl sp (map (fmap f) vs) + fmap f (PatternDecl sp t rhs) = PatternDecl sp (fmap f t) (fmap f rhs) + fmap f (FreeDecl sp vs) = FreeDecl sp (map (fmap f) vs) + fmap _ (DefaultDecl sp tys) = DefaultDecl sp tys + fmap f (ClassDecl sp li cx cls clsvar ds) = + ClassDecl sp li cx cls clsvar (map (fmap f) ds) + fmap f (InstanceDecl sp li cx qcls inst ds) = + InstanceDecl sp li cx qcls inst (map (fmap f) ds) + +instance Functor Equation where + fmap f (Equation p lhs rhs) = Equation p (fmap f lhs) (fmap f rhs) + +instance Functor Lhs where + fmap f (FunLhs p f' ts) = FunLhs p f' (map (fmap f) ts) + fmap f (OpLhs p t1 op t2) = OpLhs p (fmap f t1) op (fmap f t2) + fmap f (ApLhs p lhs ts) = ApLhs p (fmap f lhs) (map (fmap f) ts) + +instance Functor Rhs where + fmap f (SimpleRhs p li e ds) = SimpleRhs p li (fmap f e) (map (fmap f) ds) + fmap f (GuardedRhs p li cs ds) = GuardedRhs p li (map (fmap f) cs) (map (fmap f) ds) + +instance Functor CondExpr where + fmap f (CondExpr p g e) = CondExpr p (fmap f g) (fmap f e) + +instance Functor Pattern where + fmap f (LiteralPattern p a l) = LiteralPattern p (f a) l + fmap f (NegativePattern p a l) = NegativePattern p (f a) l + fmap f (VariablePattern p a v) = VariablePattern p (f a) v + fmap f (ConstructorPattern p a c ts) = + ConstructorPattern p (f a) c (map (fmap f) ts) + fmap f (InfixPattern p a t1 op t2) = + InfixPattern p (f a) (fmap f t1) op (fmap f t2) + fmap f (ParenPattern p t) = ParenPattern p (fmap f t) + fmap f (RecordPattern p a c fs) = + RecordPattern p (f a) c (map (fmap (fmap f)) fs) + fmap f (TuplePattern p ts) = TuplePattern p (map (fmap f) ts) + fmap f (ListPattern p a ts) = ListPattern p (f a) (map (fmap f) ts) + fmap f (AsPattern p v t) = AsPattern p v (fmap f t) + fmap f (LazyPattern p t) = LazyPattern p (fmap f t) + fmap f (FunctionPattern p a f' ts) = + FunctionPattern p (f a) f' (map (fmap f) ts) + fmap f (InfixFuncPattern p a t1 op t2) = + InfixFuncPattern p (f a) (fmap f t1) op (fmap f t2) + +instance Functor Expression where + fmap f (Literal p a l) = Literal p (f a) l + fmap f (Variable p a v) = Variable p (f a) v + fmap f (Constructor p a c) = Constructor p (f a) c + fmap f (Paren p e) = Paren p (fmap f e) + fmap f (Typed p e qty) = Typed p (fmap f e) qty + fmap f (Record p a c fs) = Record p (f a) c (map (fmap (fmap f)) fs) + fmap f (RecordUpdate p e fs) = RecordUpdate p (fmap f e) (map (fmap (fmap f)) fs) + fmap f (Tuple p es) = Tuple p (map (fmap f) es) + fmap f (List p a es) = List p (f a) (map (fmap f) es) + fmap f (ListCompr p e stms) = ListCompr p (fmap f e) (map (fmap f) stms) + fmap f (EnumFrom p e) = EnumFrom p (fmap f e) + fmap f (EnumFromThen p e1 e2) = EnumFromThen p (fmap f e1) (fmap f e2) + fmap f (EnumFromTo p e1 e2) = EnumFromTo p (fmap f e1) (fmap f e2) + fmap f (EnumFromThenTo p e1 e2 e3) = + EnumFromThenTo p (fmap f e1) (fmap f e2) (fmap f e3) + fmap f (UnaryMinus p e) = UnaryMinus p (fmap f e) + fmap f (Apply p e1 e2) = Apply p (fmap f e1) (fmap f e2) + fmap f (InfixApply p e1 op e2) = + InfixApply p (fmap f e1) (fmap f op) (fmap f e2) + fmap f (LeftSection p e op) = LeftSection p (fmap f e) (fmap f op) + fmap f (RightSection p op e) = RightSection p (fmap f op) (fmap f e) + fmap f (Lambda p ts e) = Lambda p (map (fmap f) ts) (fmap f e) + fmap f (Let p li ds e) = Let p li (map (fmap f) ds) (fmap f e) + fmap f (Do p li stms e) = Do p li (map (fmap f) stms) (fmap f e) + fmap f (IfThenElse p e1 e2 e3) = + IfThenElse p (fmap f e1) (fmap f e2) (fmap f e3) + fmap f (Case p li ct e as) = Case p li ct (fmap f e) (map (fmap f) as) + +instance Functor InfixOp where + fmap f (InfixOp a op) = InfixOp (f a) op + fmap f (InfixConstr a op) = InfixConstr (f a) op + +instance Functor Statement where + fmap f (StmtExpr p e) = StmtExpr p (fmap f e) + fmap f (StmtDecl p li ds) = StmtDecl p li (map (fmap f) ds) + fmap f (StmtBind p t e) = StmtBind p (fmap f t) (fmap f e) + +instance Functor Alt where + fmap f (Alt p t rhs) = Alt p (fmap f t) (fmap f rhs) + +instance Functor Field where + fmap f (Field p l x) = Field p l (f x) + +instance Functor Var where + fmap f (Var a v) = Var (f a) v + +instance Functor Goal where + fmap f (Goal p li e ds) = Goal p li (fmap f e) (map (fmap f) ds) + +instance Pretty Infix where + pPrint InfixL = text "infixl" + pPrint InfixR = text "infixr" + pPrint Infix = text "infix" + +instance HasSpanInfo (Module a) where + getSpanInfo (Module sp _ _ _ _ _ _) = sp + + setSpanInfo sp (Module _ li ps m es is ds) = Module sp li ps m es is ds + + updateEndPos m@(Module _ _ _ _ _ _ (d:ds)) = + setEndPosition (getSrcSpanEnd (last (d:ds))) m + updateEndPos m@(Module _ _ _ _ _ (i:is) _) = + setEndPosition (getSrcSpanEnd (last (i:is))) m + updateEndPos m@(Module (SpanInfo _ (s:ss)) _ _ _ _ _ _) = + setEndPosition (end (last (s:ss))) m + updateEndPos m@(Module _ _ (p:ps) _ _ _ _) = + setEndPosition (getSrcSpanEnd (last (p:ps))) m + updateEndPos m = m + + getLayoutInfo (Module _ li _ _ _ _ _) = li + +instance HasSpanInfo (Decl a) where + getSpanInfo (InfixDecl sp _ _ _) = sp + getSpanInfo (DataDecl sp _ _ _ _) = sp + getSpanInfo (ExternalDataDecl sp _ _) = sp + getSpanInfo (NewtypeDecl sp _ _ _ _) = sp + getSpanInfo (TypeDecl sp _ _ _) = sp + getSpanInfo (TypeSig sp _ _) = sp + getSpanInfo (FunctionDecl sp _ _ _) = sp + getSpanInfo (ExternalDecl sp _) = sp + getSpanInfo (PatternDecl sp _ _) = sp + getSpanInfo (FreeDecl sp _) = sp + getSpanInfo (DefaultDecl sp _) = sp + getSpanInfo (ClassDecl sp _ _ _ _ _) = sp + getSpanInfo (InstanceDecl sp _ _ _ _ _) = sp + + setSpanInfo sp (InfixDecl _ fix prec ops) = InfixDecl sp fix prec ops + setSpanInfo sp (DataDecl _ tc tvs cs clss) = DataDecl sp tc tvs cs clss + setSpanInfo sp (ExternalDataDecl _ tc tvs) = ExternalDataDecl sp tc tvs + setSpanInfo sp (NewtypeDecl _ tc tvs nc clss) = NewtypeDecl sp tc tvs nc clss + setSpanInfo sp (TypeDecl _ tc tvs ty) = TypeDecl sp tc tvs ty + setSpanInfo sp (TypeSig _ fs qty) = TypeSig sp fs qty + setSpanInfo sp (FunctionDecl _ a f' eqs) = FunctionDecl sp a f' eqs + setSpanInfo sp (ExternalDecl _ vs) = ExternalDecl sp vs + setSpanInfo sp (PatternDecl _ t rhs) = PatternDecl sp t rhs + setSpanInfo sp (FreeDecl _ vs) = FreeDecl sp vs + setSpanInfo sp (DefaultDecl _ tys) = DefaultDecl sp tys + setSpanInfo sp (ClassDecl _ li cx cls clsvar ds) = ClassDecl sp li cx cls clsvar ds + setSpanInfo sp (InstanceDecl _ li cx qcls inst ds) = InstanceDecl sp li cx qcls inst ds + + updateEndPos d@(InfixDecl _ _ _ ops) = + let i' = last ops + in setEndPosition (incr (getPosition i') (identLength i' - 1)) d + updateEndPos d@(DataDecl _ _ _ _ (c:cs)) = + let i' = last (c:cs) + in setEndPosition (incr (getPosition i') (qIdentLength i' - 1)) d + updateEndPos d@(DataDecl _ _ _ (c:cs) _) = + setEndPosition (getSrcSpanEnd (last (c:cs))) d + updateEndPos d@(DataDecl _ _ (i:is) _ _) = + let i' = last (i:is) + in setEndPosition (incr (getPosition i') (identLength i' - 1)) d + updateEndPos d@(DataDecl _ i _ _ _) = + setEndPosition (incr (getPosition i) (identLength i - 1)) d + updateEndPos d@(ExternalDataDecl _ _ (i:is)) = + let i' = last (i:is) + in setEndPosition (incr (getPosition i') (identLength i' - 1)) d + updateEndPos d@(ExternalDataDecl _ i _) = + setEndPosition (incr (getPosition i) (identLength i - 1)) d + updateEndPos d@(NewtypeDecl _ _ _ _ (c:cs)) = + let i' = last (c:cs) + in setEndPosition (incr (getPosition i') (qIdentLength i' - 1)) d + updateEndPos d@(NewtypeDecl _ _ _ c _) = + setEndPosition (getSrcSpanEnd c) d + updateEndPos d@(TypeDecl _ _ _ ty) = + setEndPosition (getSrcSpanEnd ty) d + updateEndPos d@(TypeSig _ _ qty) = + setEndPosition (getSrcSpanEnd qty) d + updateEndPos d@(FunctionDecl _ _ _ eqs) = + setEndPosition (getSrcSpanEnd (last eqs)) d + updateEndPos d@(ExternalDecl (SpanInfo _ ss) _) = + setEndPosition (end (last ss)) d + updateEndPos d@(ExternalDecl _ _) = d + updateEndPos d@(PatternDecl _ _ rhs) = + setEndPosition (getSrcSpanEnd rhs) d + updateEndPos d@(FreeDecl (SpanInfo _ ss) _) = + setEndPosition (end (last ss)) d + updateEndPos d@(FreeDecl _ _) = d + updateEndPos d@(DefaultDecl (SpanInfo _ ss) _) = + setEndPosition (end (last ss)) d + updateEndPos d@(DefaultDecl _ _) = d + updateEndPos d@(ClassDecl _ _ _ _ _ (d':ds)) = + setEndPosition (getSrcSpanEnd (last (d':ds))) d + updateEndPos d@(ClassDecl (SpanInfo _ ss) _ _ _ _ _) = + setEndPosition (end (last ss)) d + updateEndPos d@(ClassDecl _ _ _ _ _ _) = d + updateEndPos d@(InstanceDecl _ _ _ _ _ (d':ds)) = + setEndPosition (getSrcSpanEnd (last (d':ds))) d + updateEndPos d@(InstanceDecl (SpanInfo _ ss) _ _ _ _ _) = + setEndPosition (end (last ss)) d + updateEndPos d@(InstanceDecl _ _ _ _ _ _) = d + + getLayoutInfo (ClassDecl _ li _ _ _ _) = li + getLayoutInfo (InstanceDecl _ li _ _ _ _) = li + getLayoutInfo _ = WhitespaceLayout + +instance HasSpanInfo (Equation a) where + getSpanInfo (Equation spi _ _) = spi + setSpanInfo spi (Equation _ lhs rhs) = Equation spi lhs rhs + updateEndPos e@(Equation _ _ rhs) = + setEndPosition (getSrcSpanEnd rhs) e + +instance HasSpanInfo ModulePragma where + getSpanInfo (LanguagePragma sp _ ) = sp + getSpanInfo (OptionsPragma sp _ _) = sp + + setSpanInfo sp (LanguagePragma _ ex ) = LanguagePragma sp ex + setSpanInfo sp (OptionsPragma _ t a) = OptionsPragma sp t a + + updateEndPos p@(LanguagePragma (SpanInfo _ ss) _) = + setEndPosition (end (last ss)) p + updateEndPos p@(LanguagePragma _ _) = p + updateEndPos p@(OptionsPragma (SpanInfo _ ss) _ _) = + setEndPosition (end (last ss)) p + updateEndPos p@(OptionsPragma _ _ _) = p + +instance HasSpanInfo ExportSpec where + getSpanInfo (Exporting sp _) = sp + setSpanInfo sp (Exporting _ ex) = Exporting sp ex + + updateEndPos e@(Exporting (SpanInfo _ ss) _) = + setEndPosition (end (last ss)) e + updateEndPos e@(Exporting _ _) = e + +instance HasSpanInfo Export where + getSpanInfo (Export sp _) = sp + getSpanInfo (ExportTypeWith sp _ _) = sp + getSpanInfo (ExportTypeAll sp _) = sp + getSpanInfo (ExportModule sp _) = sp + + setSpanInfo sp (Export _ qid) = Export sp qid + setSpanInfo sp (ExportTypeWith _ qid cs) = ExportTypeWith sp qid cs + setSpanInfo sp (ExportTypeAll _ qid) = ExportTypeAll sp qid + setSpanInfo sp (ExportModule _ mid) = ExportModule sp mid + + updateEndPos e@(Export _ idt) = + setEndPosition (incr (getPosition idt) (qIdentLength idt - 1)) e + updateEndPos e@(ExportTypeWith (SpanInfo _ ss) _ _) = + setEndPosition (end (last ss)) e + updateEndPos e@(ExportTypeWith _ _ _) = e + updateEndPos e@(ExportTypeAll (SpanInfo _ ss) _) = + setEndPosition (end (last ss)) e + updateEndPos e@(ExportTypeAll _ _) = e + updateEndPos e@(ExportModule _ mid) = + setEndPosition (incr (getPosition mid) (mIdentLength mid - 1)) e + +instance HasSpanInfo ImportDecl where + getSpanInfo (ImportDecl sp _ _ _ _) = sp + setSpanInfo sp (ImportDecl _ mid q as spec) = ImportDecl sp mid q as spec + + updateEndPos i@(ImportDecl _ _ _ _ (Just spec)) = + setEndPosition (getSrcSpanEnd spec) i + updateEndPos i@(ImportDecl _ _ _ (Just mid) _) = + setEndPosition (incr (getPosition mid) (mIdentLength mid - 1)) i + updateEndPos i@(ImportDecl _ mid _ _ _) = + setEndPosition (incr (getPosition mid) (mIdentLength mid - 1)) i + +instance HasSpanInfo ImportSpec where + getSpanInfo (Importing sp _) = sp + getSpanInfo (Hiding sp _) = sp + + setSpanInfo sp (Importing _ im) = Importing sp im + setSpanInfo sp (Hiding _ im) = Hiding sp im + + updateEndPos i@(Importing (SpanInfo _ ss) _) = + setEndPosition (end (last ss)) i + updateEndPos i@(Importing _ _) = i + updateEndPos i@(Hiding (SpanInfo _ ss) _) = + setEndPosition (end (last ss)) i + updateEndPos i@(Hiding _ _) = i + +instance HasSpanInfo Import where + getSpanInfo (Import sp _) = sp + getSpanInfo (ImportTypeWith sp _ _) = sp + getSpanInfo (ImportTypeAll sp _) = sp + + setSpanInfo sp (Import _ qid) = Import sp qid + setSpanInfo sp (ImportTypeWith _ qid cs) = ImportTypeWith sp qid cs + setSpanInfo sp (ImportTypeAll _ qid) = ImportTypeAll sp qid + + updateEndPos i@(Import _ idt) = + setEndPosition (incr (getPosition idt) (identLength idt - 1)) i + updateEndPos i@(ImportTypeWith (SpanInfo _ ss) _ _) = + setEndPosition (end (last ss)) i + updateEndPos i@(ImportTypeWith _ _ _) = i + updateEndPos i@(ImportTypeAll (SpanInfo _ ss) _) = + setEndPosition (end (last ss)) i + updateEndPos i@(ImportTypeAll _ _) = i + +instance HasSpanInfo ConstrDecl where + getSpanInfo (ConstrDecl sp _ _) = sp + getSpanInfo (ConOpDecl sp _ _ _) = sp + getSpanInfo (RecordDecl sp _ _) = sp + + setSpanInfo sp (ConstrDecl _ idt ty) = ConstrDecl sp idt ty + setSpanInfo sp (ConOpDecl _ ty1 idt ty2) = ConOpDecl sp ty1 idt ty2 + setSpanInfo sp (RecordDecl _ idt fd) = RecordDecl sp idt fd + + updateEndPos c@(ConstrDecl _ _ (t:ts)) = + setEndPosition (getSrcSpanEnd (last (t:ts))) c + updateEndPos c@(ConstrDecl _ idt _) = + setEndPosition (incr (getPosition idt) (identLength idt - 1)) c + updateEndPos c@(ConOpDecl _ _ _ ty) = + setEndPosition (getSrcSpanEnd ty) c + updateEndPos c@(RecordDecl (SpanInfo _ ss) _ _) = + setEndPosition (end (last ss)) c + updateEndPos c@(RecordDecl _ _ _) = c + +instance HasSpanInfo NewConstrDecl where + getSpanInfo (NewConstrDecl sp _ _) = sp + getSpanInfo (NewRecordDecl sp _ _) = sp + + setSpanInfo sp (NewConstrDecl _ idt ty) = NewConstrDecl sp idt ty + setSpanInfo sp (NewRecordDecl _ idt fty) = NewRecordDecl sp idt fty + + updateEndPos c@(NewConstrDecl _ _ ty) = + setEndPosition (getSrcSpanEnd ty) c + updateEndPos c@(NewRecordDecl (SpanInfo _ ss) _ _) = + setEndPosition (end (last ss)) c + updateEndPos c@(NewRecordDecl _ _ _) = c + +instance HasSpanInfo FieldDecl where + getSpanInfo (FieldDecl sp _ _) = sp + setSpanInfo sp (FieldDecl _ idt ty) = FieldDecl sp idt ty + updateEndPos d@(FieldDecl _ _ ty) = + setEndPosition (getSrcSpanEnd ty) d + +instance HasSpanInfo TypeExpr where + getSpanInfo (ConstructorType sp _) = sp + getSpanInfo (ApplyType sp _ _) = sp + getSpanInfo (VariableType sp _) = sp + getSpanInfo (TupleType sp _) = sp + getSpanInfo (ListType sp _) = sp + getSpanInfo (ArrowType sp _ _) = sp + getSpanInfo (ParenType sp _) = sp + getSpanInfo (ForallType sp _ _) = sp + + setSpanInfo sp (ConstructorType _ qid) = ConstructorType sp qid + setSpanInfo sp (ApplyType _ ty1 ty2) = ApplyType sp ty1 ty2 + setSpanInfo sp (VariableType _ idt) = VariableType sp idt + setSpanInfo sp (TupleType _ tys) = TupleType sp tys + setSpanInfo sp (ListType _ ty) = ListType sp ty + setSpanInfo sp (ArrowType _ ty1 ty2) = ArrowType sp ty1 ty2 + setSpanInfo sp (ParenType _ ty) = ParenType sp ty + setSpanInfo sp (ForallType _ idt ty) = ForallType sp idt ty + + updateEndPos t@(ConstructorType _ qid) = + setEndPosition (incr (getPosition qid) (qIdentLength qid - 1)) t + updateEndPos t@(ApplyType _ _ t2) = + setEndPosition (getSrcSpanEnd t2) t + updateEndPos t@(VariableType _ idt) = + setEndPosition (incr (getPosition idt) (identLength idt - 1)) t + updateEndPos t@(ListType (SpanInfo _ (s:ss)) _) = + setEndPosition (end (last (s:ss))) t + updateEndPos t@(ListType _ _) = t + updateEndPos t@(TupleType _ tys) = + setEndPosition (getSrcSpanEnd (last tys)) t + updateEndPos t@(ArrowType _ _ t2) = + setEndPosition (getSrcSpanEnd t2) t + updateEndPos t@(ParenType (SpanInfo _ (s:ss)) _) = + setEndPosition (end (last (s:ss))) t + updateEndPos t@(ParenType _ _) = t + updateEndPos t@(ForallType _ _ _) = t -- not a parseable type + +instance HasSpanInfo QualTypeExpr where + getSpanInfo (QualTypeExpr sp _ _) = sp + setSpanInfo sp (QualTypeExpr _ cx ty) = QualTypeExpr sp cx ty + updateEndPos t@(QualTypeExpr _ _ ty) = + setEndPosition (getSrcSpanEnd ty) t + +instance HasSpanInfo Constraint where + getSpanInfo (Constraint sp _ _) = sp + setSpanInfo sp (Constraint _ qid ty) = Constraint sp qid ty + updateEndPos c@(Constraint (SpanInfo _ (s:ss)) _ _) = + setEndPosition (end (last (s:ss))) c + updateEndPos c@(Constraint _ _ ty) = + setEndPosition (getSrcSpanEnd ty) c + +instance HasSpanInfo (Lhs a) where + getSpanInfo (FunLhs sp _ _) = sp + getSpanInfo (OpLhs sp _ _ _) = sp + getSpanInfo (ApLhs sp _ _) = sp + + setSpanInfo sp (FunLhs _ idt ps) = FunLhs sp idt ps + setSpanInfo sp (OpLhs _ p1 idt p2) = OpLhs sp p1 idt p2 + setSpanInfo sp (ApLhs _ lhs ps) = ApLhs sp lhs ps + + updateEndPos l@(FunLhs _ _ (p:ps)) = + setEndPosition (getSrcSpanEnd (last (p:ps))) l + updateEndPos l@(FunLhs _ idt _) = + setEndPosition (incr (getPosition idt) (identLength idt - 1)) l + updateEndPos l@(OpLhs _ _ _ p) = + setEndPosition (getSrcSpanEnd p) l + updateEndPos l@(ApLhs _ _ (p:ps)) = + setEndPosition (getSrcSpanEnd (last (p:ps))) l + updateEndPos l@(ApLhs (SpanInfo _ [_,s]) _ _) = + setEndPosition (end s) l + updateEndPos l@(ApLhs _ _ _) = l + + +instance HasSpanInfo (Rhs a) where + getSpanInfo (SimpleRhs sp _ _ _) = sp + getSpanInfo (GuardedRhs sp _ _ _) = sp + + setSpanInfo sp (SimpleRhs _ li ex ds) = SimpleRhs sp li ex ds + setSpanInfo sp (GuardedRhs _ li cs ds) = GuardedRhs sp li cs ds + + updateEndPos r@(SimpleRhs (SpanInfo _ [_,_]) _ _ (d:ds)) = + setEndPosition (getSrcSpanEnd (last (d:ds))) r + updateEndPos r@(SimpleRhs (SpanInfo _ [_,s]) _ _ _) = + setEndPosition (end s) r + updateEndPos r@(SimpleRhs _ _ e _) = + setEndPosition (getSrcSpanEnd e) r + updateEndPos r@(GuardedRhs (SpanInfo _ [_,_]) _ _ (d:ds)) = + setEndPosition (getSrcSpanEnd (last (d:ds))) r + updateEndPos r@(GuardedRhs (SpanInfo _ [_,s]) _ _ _) = + setEndPosition (end s) r + updateEndPos r@(GuardedRhs _ _ cs _) = + setEndPosition (getSrcSpanEnd (last cs)) r + + getLayoutInfo (SimpleRhs _ li _ _) = li + getLayoutInfo (GuardedRhs _ li _ _) = li + +instance HasSpanInfo (CondExpr a) where + getSpanInfo (CondExpr sp _ _) = sp + setSpanInfo sp (CondExpr _ e1 e2) = CondExpr sp e1 e2 + updateEndPos ce@(CondExpr _ _ e) = + setEndPosition (getSrcSpanEnd e) ce + +instance HasSpanInfo (Pattern a) where + getSpanInfo (LiteralPattern sp _ _) = sp + getSpanInfo (NegativePattern sp _ _) = sp + getSpanInfo (VariablePattern sp _ _) = sp + getSpanInfo (ConstructorPattern sp _ _ _) = sp + getSpanInfo (InfixPattern sp _ _ _ _) = sp + getSpanInfo (ParenPattern sp _) = sp + getSpanInfo (RecordPattern sp _ _ _) = sp + getSpanInfo (TuplePattern sp _) = sp + getSpanInfo (ListPattern sp _ _) = sp + getSpanInfo (AsPattern sp _ _) = sp + getSpanInfo (LazyPattern sp _) = sp + getSpanInfo (FunctionPattern sp _ _ _) = sp + getSpanInfo (InfixFuncPattern sp _ _ _ _) = sp + + setSpanInfo sp (LiteralPattern _ a l) = LiteralPattern sp a l + setSpanInfo sp (NegativePattern _ a l) = NegativePattern sp a l + setSpanInfo sp (VariablePattern _ a v) = VariablePattern sp a v + setSpanInfo sp (ConstructorPattern _ a c ts) = ConstructorPattern sp a c ts + setSpanInfo sp (InfixPattern _ a t1 op t2) = InfixPattern sp a t1 op t2 + setSpanInfo sp (ParenPattern _ t) = ParenPattern sp t + setSpanInfo sp (RecordPattern _ a c fs) = RecordPattern sp a c fs + setSpanInfo sp (TuplePattern _ ts) = TuplePattern sp ts + setSpanInfo sp (ListPattern _ a ts) = ListPattern sp a ts + setSpanInfo sp (AsPattern _ v t) = AsPattern sp v t + setSpanInfo sp (LazyPattern _ t) = LazyPattern sp t + setSpanInfo sp (FunctionPattern _ a f' ts) = FunctionPattern sp a f' ts + setSpanInfo sp (InfixFuncPattern _ a t1 op t2) = InfixFuncPattern sp a t1 op t2 + + updateEndPos p@(LiteralPattern _ _ _) = p + updateEndPos p@(NegativePattern _ _ _) = p + updateEndPos p@(VariablePattern _ _ v) = + setEndPosition (incr (getPosition v) (identLength v - 1)) p + updateEndPos p@(ConstructorPattern _ _ _ (t:ts)) = + setEndPosition (getSrcSpanEnd (last (t:ts))) p + updateEndPos p@(ConstructorPattern _ _ c _) = + setEndPosition (incr (getPosition c) (qIdentLength c - 1)) p + updateEndPos p@(InfixPattern _ _ _ _ t2) = + setEndPosition (getSrcSpanEnd t2) p + updateEndPos p@(ParenPattern (SpanInfo _ (s:ss)) _) = + setEndPosition (end (last (s:ss))) p + updateEndPos p@(ParenPattern _ _) = p + updateEndPos p@(RecordPattern (SpanInfo _ (s:ss)) _ _ _) = + setEndPosition (end (last (s:ss))) p + updateEndPos p@(RecordPattern _ _ _ _) = p + updateEndPos p@(TuplePattern (SpanInfo _ (s:ss)) _) = + setEndPosition (end (last (s:ss))) p + updateEndPos p@(TuplePattern _ _) = p + updateEndPos p@(ListPattern (SpanInfo _ (s:ss)) _ _) = + setEndPosition (end (last (s:ss))) p + updateEndPos p@(ListPattern _ _ _) = p + updateEndPos p@(AsPattern _ _ t) = + setEndPosition (getSrcSpanEnd t) p + updateEndPos p@(LazyPattern _ t) = + setEndPosition (getSrcSpanEnd t) p + updateEndPos p@(FunctionPattern _ _ _ _) = p + updateEndPos p@(InfixFuncPattern _ _ _ _ _) = p + +instance HasSpanInfo (Expression a) where + getSpanInfo (Literal sp _ _) = sp + getSpanInfo (Variable sp _ _) = sp + getSpanInfo (Constructor sp _ _) = sp + getSpanInfo (Paren sp _) = sp + getSpanInfo (Typed sp _ _) = sp + getSpanInfo (Record sp _ _ _) = sp + getSpanInfo (RecordUpdate sp _ _) = sp + getSpanInfo (Tuple sp _) = sp + getSpanInfo (List sp _ _) = sp + getSpanInfo (ListCompr sp _ _) = sp + getSpanInfo (EnumFrom sp _) = sp + getSpanInfo (EnumFromThen sp _ _) = sp + getSpanInfo (EnumFromTo sp _ _) = sp + getSpanInfo (EnumFromThenTo sp _ _ _) = sp + getSpanInfo (UnaryMinus sp _) = sp + getSpanInfo (Apply sp _ _) = sp + getSpanInfo (InfixApply sp _ _ _) = sp + getSpanInfo (LeftSection sp _ _) = sp + getSpanInfo (RightSection sp _ _) = sp + getSpanInfo (Lambda sp _ _) = sp + getSpanInfo (Let sp _ _ _) = sp + getSpanInfo (Do sp _ _ _) = sp + getSpanInfo (IfThenElse sp _ _ _) = sp + getSpanInfo (Case sp _ _ _ _) = sp + + setSpanInfo sp (Literal _ a l) = Literal sp a l + setSpanInfo sp (Variable _ a v) = Variable sp a v + setSpanInfo sp (Constructor _ a c) = Constructor sp a c + setSpanInfo sp (Paren _ e) = Paren sp e + setSpanInfo sp (Typed _ e qty) = Typed sp e qty + setSpanInfo sp (Record _ a c fs) = Record sp a c fs + setSpanInfo sp (RecordUpdate _ e fs) = RecordUpdate sp e fs + setSpanInfo sp (Tuple _ es) = Tuple sp es + setSpanInfo sp (List _ a es) = List sp a es + setSpanInfo sp (ListCompr _ e stms) = ListCompr sp e stms + setSpanInfo sp (EnumFrom _ e) = EnumFrom sp e + setSpanInfo sp (EnumFromThen _ e1 e2) = EnumFromThen sp e1 e2 + setSpanInfo sp (EnumFromTo _ e1 e2) = EnumFromTo sp e1 e2 + setSpanInfo sp (EnumFromThenTo _ e1 e2 e3) = EnumFromThenTo sp e1 e2 e3 + setSpanInfo sp (UnaryMinus _ e) = UnaryMinus sp e + setSpanInfo sp (Apply _ e1 e2) = Apply sp e1 e2 + setSpanInfo sp (InfixApply _ e1 op e2) = InfixApply sp e1 op e2 + setSpanInfo sp (LeftSection _ e op) = LeftSection sp e op + setSpanInfo sp (RightSection _ op e) = RightSection sp op e + setSpanInfo sp (Lambda _ ts e) = Lambda sp ts e + setSpanInfo sp (Let _ li ds e) = Let sp li ds e + setSpanInfo sp (Do _ li stms e) = Do sp li stms e + setSpanInfo sp (IfThenElse _ e1 e2 e3) = IfThenElse sp e1 e2 e3 + setSpanInfo sp (Case _ li ct e as) = Case sp li ct e as + + updateEndPos e@(Literal _ _ _) = e + updateEndPos e@(Variable _ _ v) = + setEndPosition (incr (getPosition v) (qIdentLength v - 1)) e + updateEndPos e@(Constructor _ _ c) = + setEndPosition (incr (getPosition c) (qIdentLength c - 1)) e + updateEndPos e@(Paren (SpanInfo _ [_,s]) _) = + setEndPosition (end s) e + updateEndPos e@(Paren _ _) = e + updateEndPos e@(Typed _ _ qty) = + setEndPosition (getSrcSpanEnd qty) e + updateEndPos e@(Record (SpanInfo _ (s:ss)) _ _ _) = + setEndPosition (end (last (s:ss))) e + updateEndPos e@(Record _ _ _ _) = e + updateEndPos e@(RecordUpdate (SpanInfo _ (s:ss)) _ _) = + setEndPosition (end (last (s:ss))) e + updateEndPos e@(RecordUpdate _ _ _) = e + updateEndPos e@(Tuple (SpanInfo _ [_,s]) _) = + setEndPosition (end s) e + updateEndPos e@(Tuple _ _) = e + updateEndPos e@(List (SpanInfo _ (s:ss)) _ _) = + setEndPosition (end (last (s:ss))) e + updateEndPos e@(List _ _ _) = e + updateEndPos e@(ListCompr (SpanInfo _ (s:ss)) _ _) = + setEndPosition (end (last (s:ss))) e + updateEndPos e@(ListCompr _ _ _) = e + updateEndPos e@(EnumFrom (SpanInfo _ [_,_,s]) _) = + setEndPosition (end s) e + updateEndPos e@(EnumFrom _ _) = e + updateEndPos e@(EnumFromTo (SpanInfo _ [_,_,s]) _ _) = + setEndPosition (end s) e + updateEndPos e@(EnumFromTo _ _ _) = e + updateEndPos e@(EnumFromThen (SpanInfo _ [_,_,_,s]) _ _) = + setEndPosition (end s) e + updateEndPos e@(EnumFromThen _ _ _) = e + updateEndPos e@(EnumFromThenTo (SpanInfo _ [_,_,_,s]) _ _ _) = + setEndPosition (end s) e + updateEndPos e@(EnumFromThenTo _ _ _ _) = e + updateEndPos e@(UnaryMinus _ e') = + setEndPosition (getSrcSpanEnd e') e + updateEndPos e@(Apply _ _ e') = + setEndPosition (getSrcSpanEnd e') e + updateEndPos e@(InfixApply _ _ _ e') = + setEndPosition (getSrcSpanEnd e') e + updateEndPos e@(LeftSection (SpanInfo _ [_,s]) _ _) = + setEndPosition (end s) e + updateEndPos e@(LeftSection _ _ _) = e + updateEndPos e@(RightSection (SpanInfo _ [_,s]) _ _) = + setEndPosition (end s) e + updateEndPos e@(RightSection _ _ _) = e + updateEndPos e@(Lambda _ _ e') = + setEndPosition (getSrcSpanEnd e') e + updateEndPos e@(Let _ _ _ e') = + setEndPosition (getSrcSpanEnd e') e + updateEndPos e@(Do _ _ _ e') = + setEndPosition (getSrcSpanEnd e') e + updateEndPos e@(IfThenElse _ _ _ e') = + setEndPosition (getSrcSpanEnd e') e + updateEndPos e@(Case _ _ _ _ (a:as)) = + setEndPosition (getSrcSpanEnd (last (a:as))) e + updateEndPos e@(Case (SpanInfo _ (s:ss)) _ _ _ _) = + setEndPosition (end (last (s:ss))) e + updateEndPos e@(Case _ _ _ _ _) = e + + getLayoutInfo (Let _ li _ _) = li + getLayoutInfo (Do _ li _ _) = li + getLayoutInfo (Case _ li _ _ _) = li + getLayoutInfo _ = WhitespaceLayout + +instance HasSpanInfo (Statement a) where + getSpanInfo (StmtExpr sp _) = sp + getSpanInfo (StmtDecl sp _ _) = sp + getSpanInfo (StmtBind sp _ _) = sp + + setSpanInfo sp (StmtExpr _ ex) = StmtExpr sp ex + setSpanInfo sp (StmtDecl _ li ds) = StmtDecl sp li ds + setSpanInfo sp (StmtBind _ p ex) = StmtBind sp p ex + + updateEndPos s@(StmtExpr _ e) = + setEndPosition (getSrcSpanEnd e) s + updateEndPos s@(StmtBind _ _ e) = + setEndPosition (getSrcSpanEnd e) s + updateEndPos s@(StmtDecl _ _ (d:ds)) = + setEndPosition (getSrcSpanEnd (last (d:ds))) s + updateEndPos s@(StmtDecl (SpanInfo _ [s']) _ _) = -- empty let + setEndPosition (end s') s + updateEndPos s@(StmtDecl _ _ _) = s + + getLayoutInfo (StmtDecl _ li _) = li + getLayoutInfo _ = WhitespaceLayout + +instance HasSpanInfo (Alt a) where + getSpanInfo (Alt sp _ _) = sp + setSpanInfo sp (Alt _ p rhs) = Alt sp p rhs + updateEndPos a@(Alt _ _ rhs) = + setEndPosition (getSrcSpanEnd rhs) a + +instance HasSpanInfo (Field a) where + getSpanInfo (Field sp _ _) = sp + setSpanInfo sp (Field _ qid a) = Field sp qid a + updateEndPos f@(Field (SpanInfo _ ss) _ _) = + setEndPosition (end (last ss)) f + updateEndPos f@ (Field _ _ _) = f + +instance HasSpanInfo (Goal a) where + getSpanInfo (Goal sp _ _ _) = sp + setSpanInfo sp (Goal _ li e ds) = Goal sp li e ds + + updateEndPos g@(Goal (SpanInfo _ [_]) _ _ (d:ds)) = + setEndPosition (getSrcSpanEnd (last (d:ds))) g + updateEndPos g@(Goal (SpanInfo _ [s]) _ _ _) = + setEndPosition (end s) g + updateEndPos g@(Goal _ _ _ _) = g + + getLayoutInfo (Goal _ li _ _) = li + +instance HasPosition (Module a) where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition (Decl a) where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition (Equation a) where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition ModulePragma where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition ExportSpec where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition ImportDecl where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition ImportSpec where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition Export where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition Import where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition ConstrDecl where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition TypeExpr where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition QualTypeExpr where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition NewConstrDecl where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition Constraint where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition FieldDecl where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition (Lhs a) where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition (Rhs a) where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition (CondExpr a) where + getPosition = getStartPosition + +instance HasPosition (Pattern a) where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition (Expression a) where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition (Alt a) where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition (Goal a) where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition (Field a) where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition (Statement a) where + getPosition = getStartPosition + setPosition = setStartPosition + +instance HasPosition (InfixOp a) where + getPosition (InfixOp _ q) = getPosition q + getPosition (InfixConstr _ q) = getPosition q + + setPosition p (InfixOp a q) = InfixOp a (setPosition p q) + setPosition p (InfixConstr a q) = InfixConstr a (setPosition p q) + +instance Binary a => Binary (Module a) where + put (Module spi li ps mid ex im ds) = put spi >> put li >> put ps >> + put mid >> put ex >> put im >> put ds + get = Module <$> get <*> get <*> get <*> get <*> get <*> get <*> get + +instance Binary ModulePragma where + put (LanguagePragma spi ex ) = putWord8 0 >> put spi >> put ex + put (OptionsPragma spi t s) = putWord8 1 >> put spi >> put t >> put s + + get = do + x <- getWord8 + case x of + 0 -> liftM2 LanguagePragma get get + 1 -> liftM3 OptionsPragma get get get + _ -> fail "Invalid encoding for ModulePragma" + +instance Binary ExportSpec where + put (Exporting spi es) = put spi >> put es + get = liftM2 Exporting get get + +instance Binary Export where + put (Export spi qid ) = putWord8 0 >> put spi >> put qid + put (ExportTypeWith spi qid is) = putWord8 1 >> put spi >> put qid >> put is + put (ExportTypeAll spi qid ) = putWord8 2 >> put spi >> put qid + put (ExportModule spi mid ) = putWord8 3 >> put spi >> put mid + + get = do + x <- getWord8 + case x of + 0 -> liftM2 Export get get + 1 -> liftM3 ExportTypeWith get get get + 2 -> liftM2 ExportTypeAll get get + 3 -> liftM2 ExportModule get get + _ -> fail "Invalid encoding for Export" + +instance Binary ImportDecl where + put (ImportDecl spi mid q al im) = put spi >> put mid >> put q >> + put al >> put im + get = ImportDecl <$> get <*> get <*> get <*> get <*> get + +instance Binary ImportSpec where + put (Importing spi im) = putWord8 0 >> put spi >> put im + put (Hiding spi im) = putWord8 1 >> put spi >> put im + + get = do + x <- getWord8 + case x of + 0 -> liftM2 Importing get get + 1 -> liftM2 Hiding get get + _ -> fail "Invalid encoding for ImportSpec" + +instance Binary Import where + put (Import spi idt ) = putWord8 0 >> put spi >> put idt + put (ImportTypeWith spi idt is) = putWord8 1 >> put spi >> put idt >> put is + put (ImportTypeAll spi idt ) = putWord8 2 >> put spi >> put idt + + get = do + x <- getWord8 + case x of + 0 -> liftM2 Import get get + 1 -> liftM3 ImportTypeWith get get get + 2 -> liftM2 ImportTypeAll get get + _ -> fail "Invalid encoding for Import" + +instance Binary a => Binary (Decl a) where + put (InfixDecl spi i pr is) = + putWord8 0 >> put spi >> put i >> put pr >> put is + put (DataDecl spi idt vs cns cls) = + putWord8 1 >> put spi >> put idt >> put vs >> put cns >> put cls + put (ExternalDataDecl spi idt vs) = + putWord8 2 >> put spi >> put idt >> put vs + put (NewtypeDecl spi idt vs cn cls) = + putWord8 3 >> put spi >> put idt >> put vs >> put cn >> put cls >> put cls + put (TypeDecl spi idt vs ty) = + putWord8 4 >> put spi >> put idt >> put vs >> put ty + put (TypeSig spi fs ty) = + putWord8 5 >> put spi >> put fs >> put ty + put (FunctionDecl spi a f eqs) = + putWord8 6 >> put spi >> put a >> put f >> put eqs + put (ExternalDecl spi vs) = + putWord8 7 >> put spi >> put vs + put (PatternDecl spi p rhs) = + putWord8 8 >> put spi >> put p >> put rhs + put (FreeDecl spi vs) = + putWord8 9 >> put spi >> put vs + put (DefaultDecl spi tys) = + putWord8 10 >> put spi >> put tys + put (ClassDecl spi li cx cls v ds) = + putWord8 11 >> put spi >> put li >> put cx >> put cls >> put v >> put ds + put (InstanceDecl spi li cx cls ty ds) = + putWord8 12 >> put spi >> put li >> put cx >> put cls >> put ty >> put ds + + get = do + x <- getWord8 + case x of + 0 -> InfixDecl <$> get <*> get <*> get <*> get + 1 -> DataDecl <$> get <*> get <*> get <*> get <*> get + 2 -> ExternalDataDecl <$> get <*> get <*> get + 3 -> NewtypeDecl <$> get <*> get <*> get <*> get <*> get + 4 -> TypeDecl <$> get <*> get <*> get <*> get + 5 -> TypeSig <$> get <*> get <*> get + 6 -> FunctionDecl <$> get <*> get <*> get <*> get + 7 -> ExternalDecl <$> get <*> get + 8 -> PatternDecl <$> get <*> get <*> get + 9 -> FreeDecl <$> get <*> get + 10 -> DefaultDecl <$> get <*> get + 11 -> ClassDecl <$> get <*> get <*> get <*> get <*> get <*> get + 12 -> InstanceDecl <$> get <*> get <*> get <*> get <*> get <*> get + _ -> fail "Invalid encoding for Decl" + +instance Binary Infix where + put InfixL = putWord8 0 + put InfixR = putWord8 1 + put Infix = putWord8 2 + + get = do + x <- getWord8 + case x of + 0 -> return InfixL + 1 -> return InfixR + 2 -> return Infix + _ -> fail "Invalid encoding for Infix" + +instance Binary ConstrDecl where + put (ConstrDecl spi idt tys) = + putWord8 0 >> put spi >> put idt >> put tys + put (ConOpDecl spi ty1 idt ty2) = + putWord8 1 >> put spi >> put ty1 >> put idt >> put ty2 + put (RecordDecl spi idt fs) = + putWord8 2 >> put spi >> put idt >> put fs + + get = do + x <- getWord8 + case x of + 0 -> liftM3 ConstrDecl get get get + 1 -> ConOpDecl <$> get <*> get <*> get <*> get + 2 -> liftM3 RecordDecl get get get + _ -> fail "Invalid encoding for ConstrDecl" + +instance Binary NewConstrDecl where + put (NewConstrDecl spi c ty) = + putWord8 0 >> put spi >> put c >> put ty + put (NewRecordDecl spi c fs) = + putWord8 1 >> put spi >> put c >> put fs + + get = do + x <- getWord8 + case x of + 0 -> liftM3 NewConstrDecl get get get + 1 -> liftM3 NewRecordDecl get get get + _ -> fail "Invalid encoding for NewConstrDecl" + +instance Binary FieldDecl where + put (FieldDecl spi is ty) = put spi >> put is >> put ty + get = liftM3 FieldDecl get get get + +instance Binary QualTypeExpr where + put (QualTypeExpr spi ctx te) = put spi >> put ctx >> put te + get = liftM3 QualTypeExpr get get get + +instance Binary TypeExpr where + put (ConstructorType spi qid) = + putWord8 0 >> put spi >> put qid + put (ApplyType spi ty1 ty2) = + putWord8 1 >> put spi >> put ty1 >> put ty2 + put (VariableType spi idt) = + putWord8 2 >> put spi >> put idt + put (TupleType spi tys) = + putWord8 3 >> put spi >> put tys + put (ListType spi ty) = + putWord8 4 >> put spi >> put ty + put (ArrowType spi ty1 ty2) = + putWord8 5 >> put spi >> put ty1 >> put ty2 + put (ParenType spi ty) = + putWord8 6 >> put spi >> put ty + put (ForallType spi is ty) = + putWord8 7 >> put spi >> put is >> put ty + + get = do + x <- getWord8 + case x of + 0 -> liftM2 ConstructorType get get + 1 -> liftM3 ApplyType get get get + 2 -> liftM2 VariableType get get + 3 -> liftM2 TupleType get get + 4 -> liftM2 ListType get get + 5 -> liftM3 ArrowType get get get + 6 -> liftM2 ParenType get get + 7 -> liftM3 ForallType get get get + _ -> fail "Invalid encoding for TypeExpr" + +instance Binary Constraint where + put (Constraint spi cls ty) = put spi >> put cls >> put ty + get = liftM3 Constraint get get get + +instance Binary a => Binary (Equation a) where + put (Equation spi lhs rhs) = put spi >> put lhs >> put rhs + get = liftM3 Equation get get get + +instance Binary a => Binary (Lhs a) where + put (FunLhs spi f ps) = + putWord8 0 >> put spi >> put f >> put ps + put (OpLhs spi p1 op p2) = + putWord8 1 >> put spi >> put p1 >> put op >> put p2 + put (ApLhs spi lhs ps) = + putWord8 2 >> put spi >> put lhs >> put ps + + get = do + x <- getWord8 + case x of + 0 -> liftM3 FunLhs get get get + 1 -> OpLhs <$> get <*> get <*> get <*> get + 2 -> liftM3 ApLhs get get get + _ -> fail "Invalid encoding for Lhs" + +instance Binary a => Binary (Rhs a) where + put (SimpleRhs spi li e ds) = + putWord8 0 >> put spi >> put li >> put e >> put ds + put (GuardedRhs spi li gs ds) = + putWord8 1 >> put spi >> put li >> put gs >> put ds + + get = do + x <- getWord8 + case x of + 0 -> SimpleRhs <$> get <*> get <*> get <*> get + 1 -> GuardedRhs <$> get <*> get <*> get <*> get + _ -> fail "Invalid encoding for Rhs" + +instance Binary a => Binary (CondExpr a) where + put (CondExpr spi g e) = put spi >> put g >> put e + get = liftM3 CondExpr get get get + +instance Binary Literal where + put (Char c) = putWord8 0 >> put c + put (Int i) = putWord8 1 >> put i + put (Float f) = putWord8 2 >> put (show f) + put (String s) = putWord8 3 >> put s + + get = do + x <- getWord8 + case x of + 0 -> fmap Char get + 1 -> fmap Int get + 2 -> fmap (Float . read) get + 3 -> fmap String get + _ -> fail "Invalid encoding for Literal" + +instance Binary a => Binary (Pattern a) where + put (LiteralPattern spi a l) = + putWord8 0 >> put spi >> put a >> put l + put (NegativePattern spi a l) = + putWord8 1 >> put spi >> put a >> put l + put (VariablePattern spi a idt) = + putWord8 2 >> put spi >> put a >> put idt + put (ConstructorPattern spi a qid ps) = + putWord8 3 >> put spi >> put a >> put qid >> put ps + put (InfixPattern spi a p1 qid p2) = + putWord8 4 >> put spi >> put a >> put p1 >> put qid >> put p2 + put (ParenPattern spi p) = + putWord8 5 >> put spi >> put p + put (RecordPattern spi a qid fs) = + putWord8 6 >> put spi >> put a >> put qid >> put fs + put (TuplePattern spi ps) = + putWord8 7 >> put spi >> put ps + put (ListPattern spi a ps) = + putWord8 8 >> put spi >> put a >> put ps + put (AsPattern spi idt p) = + putWord8 9 >> put spi >> put idt >> put p + put (LazyPattern spi p) = + putWord8 10 >> put spi >> put p + put (FunctionPattern spi a qid ps) = + putWord8 11 >> put spi >> put a >> put qid >> put ps + put (InfixFuncPattern spi a p1 qid p2) = + putWord8 12 >> put spi >> put a >> put p1 >> put qid >> put p2 + + get = do + x <- getWord8 + case x of + 0 -> liftM3 LiteralPattern get get get + 1 -> liftM3 NegativePattern get get get + 2 -> liftM3 VariablePattern get get get + 3 -> ConstructorPattern <$> get <*> get <*> get <*> get + 4 -> InfixPattern <$> get <*> get <*> get <*> get <*> get + 5 -> liftM2 ParenPattern get get + 6 -> RecordPattern <$> get <*> get <*> get <*> get + 7 -> liftM2 TuplePattern get get + 8 -> liftM3 ListPattern get get get + 9 -> liftM3 AsPattern get get get + 10 -> liftM2 LazyPattern get get + 11 -> FunctionPattern <$> get <*> get <*> get <*> get + 12 -> InfixFuncPattern <$> get <*> get <*> get <*> get <*> get + _ -> fail "Invalid encoding for Pattern" + +instance Binary a => Binary (Expression a) where + put (Literal spi a l) = + putWord8 0 >> put spi >> put a >> put l + put (Variable spi a qid) = + putWord8 1 >> put spi >> put a >> put qid + put (Constructor spi a qid) = + putWord8 2 >> put spi >> put a >> put qid + put (Paren spi e) = + putWord8 3 >> put spi >> put e + put (Typed spi e ty) = + putWord8 4 >> put spi >> put e >> put ty + put (Record spi a qid fs) = + putWord8 5 >> put spi >> put a >> put qid >> put fs + put (RecordUpdate spi e fs) = + putWord8 6 >> put spi >> put e >> put fs + put (Tuple spi es) = + putWord8 7 >> put spi >> put es + put (List spi a es) = + putWord8 8 >> put spi >> put a >> put es + put (ListCompr spi e stms) = + putWord8 9 >> put spi >> put e >> put stms + put (EnumFrom spi e1) = + putWord8 10 >> put spi >> put e1 + put (EnumFromThen spi e1 e2) = + putWord8 11 >> put spi >> put e1 >> put e2 + put (EnumFromTo spi e1 e2) = + putWord8 12 >> put spi >> put e1 >> put e2 + put (EnumFromThenTo spi e1 e2 e3) = + putWord8 13 >> put spi >> put e1 >> put e2 >> put e3 + put (UnaryMinus spi e) = + putWord8 14 >> put spi >> put e + put (Apply spi e1 e2) = + putWord8 15 >> put spi >> put e1 >> put e2 + put (InfixApply spi e1 op e2) = + putWord8 16 >> put spi >> put e1 >> put op >> put e2 + put (LeftSection spi e op) = + putWord8 17 >> put spi >> put e >> put op + put (RightSection spi op e) = + putWord8 18 >> put spi >> put op >> put e + put (Lambda spi ps e) = + putWord8 19 >> put spi >> put ps >> put e + put (Let spi li ds e) = + putWord8 20 >> put spi >> put li >> put ds >> put e + put (Do spi li stms e) = + putWord8 21 >> put spi >> put li >> put stms >> put e + put (IfThenElse spi e1 e2 e3) = + putWord8 22 >> put spi >> put e1 >> put e2 >> put e3 + put (Case spi li cty e as) = + putWord8 23 >> put spi >> put li >> put cty >> put e >> put as + + get = do + x <- getWord8 + case x of + 0 -> liftM3 Literal get get get + 1 -> liftM3 Variable get get get + 2 -> liftM3 Constructor get get get + 3 -> liftM2 Paren get get + 4 -> liftM3 Typed get get get + 5 -> Record <$> get <*> get <*> get <*> get + 6 -> RecordUpdate <$> get <*> get <*> get + 7 -> liftM2 Tuple get get + 8 -> liftM3 List get get get + 9 -> liftM3 ListCompr get get get + 10 -> liftM2 EnumFrom get get + 11 -> liftM3 EnumFromThen get get get + 12 -> liftM3 EnumFromTo get get get + 13 -> EnumFromThenTo <$> get <*> get <*> get <*> get + 14 -> liftM2 UnaryMinus get get + 15 -> liftM3 Apply get get get + 16 -> InfixApply <$> get <*> get <*> get <*> get + 17 -> liftM3 LeftSection get get get + 18 -> liftM3 RightSection get get get + 19 -> liftM3 Lambda get get get + 20 -> Let <$> get <*> get <*> get <*> get + 21 -> Do <$> get <*> get <*> get <*> get + 22 -> IfThenElse <$> get <*> get <*> get <*> get + 23 -> Case <$> get <*> get <*> get <*> get <*> get + _ -> fail "Invalid encoding for Expression" + +instance Binary a => Binary (InfixOp a) where + put (InfixOp a qid) = putWord8 0 >> put a >> put qid + put (InfixConstr a qid) = putWord8 1 >> put a >> put qid + + get = do + x <- getWord8 + case x of + 0 -> liftM2 InfixOp get get + 1 -> liftM2 InfixConstr get get + _ -> fail "Invalid encoding for InfixOp" + +instance Binary a => Binary (Statement a) where + put (StmtExpr spi e) = putWord8 0 >> put spi >> put e + put (StmtDecl spi li ds) = putWord8 1 >> put spi >> put li >> put ds + put (StmtBind spi p e) = putWord8 2 >> put spi >> put p >> put e + + get = do + x <- getWord8 + case x of + 0 -> liftM2 StmtExpr get get + 1 -> liftM3 StmtDecl get get get + 2 -> liftM3 StmtBind get get get + _ -> fail "Invalid encoding for Statement" + +instance Binary CaseType where + put Rigid = putWord8 0 + put Flex = putWord8 1 + + get = do + x <- getWord8 + case x of + 0 -> return Rigid + 1 -> return Flex + _ -> fail "Invalid encoding for CaseType" + +instance Binary a => Binary (Alt a) where + put (Alt spi p rhs) = put spi >> put p >> put rhs + get = liftM3 Alt get get get + +instance Binary a => Binary (Field a) where + put (Field spi qid a) = put spi >> put qid >> put a + get = liftM3 Field get get get + +instance Binary a => Binary (Var a) where + put (Var a idt) = put a >> put idt + get = liftM2 Var get get + +{- HLINT ignore "Use record patterns"-} diff --git a/src/Curry/Syntax/Utils.hs b/src/Curry/Syntax/Utils.hs new file mode 100644 index 0000000000000000000000000000000000000000..e5f76174296411c89c07c648def31d6420edfe5f --- /dev/null +++ b/src/Curry/Syntax/Utils.hs @@ -0,0 +1,325 @@ +{- | + Module : $Header$ + Description : Utility functions for Curry's abstract syntax + Copyright : (c) 1999 - 2004 Wolfgang Lux + 2005 Martin Engelke + 2011 - 2014 Björn Peemöller + 2015 Jan Tikovsky + 2016 Finn Teegen + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This module provides some utility functions for working with the + abstract syntax tree of Curry. +-} + +module Curry.Syntax.Utils + ( hasLanguageExtension, knownExtensions + , isTopDecl, isBlockDecl + , isTypeSig, infixOp, isTypeDecl, isValueDecl, isInfixDecl + , isDefaultDecl, isClassDecl, isTypeOrClassDecl, isInstanceDecl + , isFunctionDecl, isExternalDecl, patchModuleId + , isVariablePattern + , isVariableType, isSimpleType + , typeConstr, typeVariables, varIdent + , flatLhs, eqnArity, fieldLabel, fieldTerm, field2Tuple, opName + , funDecl, mkEquation, simpleRhs, patDecl, varDecl, constrPattern, caseAlt + , mkLet, mkVar, mkCase, mkLambda + , apply, unapply + , constrId, nconstrId + , nconstrType + , recordLabels, nrecordLabels + , methods, impls, imethod, imethodArity + , shortenModuleAST + ) where + +import Control.Monad.State + +import Curry.Base.Ident +import Curry.Base.SpanInfo +import Curry.Files.Filenames (takeBaseName) +import Curry.Syntax.Extension +import Curry.Syntax.Type + +-- |Check whether a 'Module' has a specific 'KnownExtension' enabled by a pragma +hasLanguageExtension :: Module a -> KnownExtension -> Bool +hasLanguageExtension mdl ext = ext `elem` knownExtensions mdl + +-- |Extract all known extensions from a 'Module' +knownExtensions :: Module a -> [KnownExtension] +knownExtensions (Module _ _ ps _ _ _ _) = + [ e | LanguagePragma _ exts <- ps, KnownExtension _ e <- exts] + +-- |Replace the generic module name @main@ with the module name derived +-- from the 'FilePath' of the module. +patchModuleId :: FilePath -> Module a -> Module a +patchModuleId fn m@(Module spi li ps mid es is ds) + | mid == mainMIdent = Module spi li ps (mkMIdent [takeBaseName fn]) es is ds + | otherwise = m + +-- |Is the declaration a top declaration? +isTopDecl :: Decl a -> Bool +isTopDecl = not . isBlockDecl + +-- |Is the declaration a block declaration? +isBlockDecl :: Decl a -> Bool +isBlockDecl = liftM3 ((.) (||) . (||)) isInfixDecl isTypeSig isValueDecl + +-- |Is the declaration an infix declaration? +isInfixDecl :: Decl a -> Bool +isInfixDecl (InfixDecl _ _ _ _) = True +isInfixDecl _ = False + +-- |Is the declaration a type declaration? +isTypeDecl :: Decl a -> Bool +isTypeDecl (DataDecl _ _ _ _ _) = True +isTypeDecl (ExternalDataDecl _ _ _) = True +isTypeDecl (NewtypeDecl _ _ _ _ _) = True +isTypeDecl (TypeDecl _ _ _ _) = True +isTypeDecl _ = False + +-- |Is the declaration a default declaration? +isDefaultDecl :: Decl a -> Bool +isDefaultDecl (DefaultDecl _ _) = True +isDefaultDecl _ = False + +-- |Is the declaration a class declaration? +isClassDecl :: Decl a -> Bool +isClassDecl (ClassDecl _ _ _ _ _ _) = True +isClassDecl _ = False + +-- |Is the declaration a type or a class declaration? +isTypeOrClassDecl :: Decl a -> Bool +isTypeOrClassDecl = liftM2 (||) isTypeDecl isClassDecl + +-- |Is the declaration an instance declaration? +isInstanceDecl :: Decl a -> Bool +isInstanceDecl (InstanceDecl _ _ _ _ _ _) = True +isInstanceDecl _ = False + +-- |Is the declaration a type signature? +isTypeSig :: Decl a -> Bool +isTypeSig (TypeSig _ _ _) = True +isTypeSig _ = False + +-- |Is the declaration a value declaration? +isValueDecl :: Decl a -> Bool +isValueDecl (FunctionDecl _ _ _ _) = True +isValueDecl (ExternalDecl _ _) = True +isValueDecl (PatternDecl _ _ _) = True +isValueDecl (FreeDecl _ _) = True +isValueDecl _ = False + +-- |Is the declaration a function declaration? +isFunctionDecl :: Decl a -> Bool +isFunctionDecl (FunctionDecl _ _ _ _) = True +isFunctionDecl _ = False + +-- |Is the declaration an external declaration? +isExternalDecl :: Decl a -> Bool +isExternalDecl (ExternalDecl _ _) = True +isExternalDecl _ = False + +-- |Is the pattern semantically equivalent to a variable pattern? +isVariablePattern :: Pattern a -> Bool +isVariablePattern (VariablePattern _ _ _) = True +isVariablePattern (ParenPattern _ t) = isVariablePattern t +isVariablePattern (AsPattern _ _ t) = isVariablePattern t +isVariablePattern (LazyPattern _ _) = True +isVariablePattern _ = False + +-- |Is a type expression a type variable? +isVariableType :: TypeExpr -> Bool +isVariableType (VariableType _ _) = True +isVariableType _ = False + +-- |Is a type expression simple, i.e., is it of the form T u_1 ... u_n, +-- where T is a type constructor and u_1 ... u_n are type variables? +isSimpleType :: TypeExpr -> Bool +isSimpleType (ConstructorType _ _) = True +isSimpleType (ApplyType _ ty1 ty2) = isSimpleType ty1 && isVariableType ty2 +isSimpleType (VariableType _ _) = False +isSimpleType (TupleType _ tys) = all isVariableType tys +isSimpleType (ListType _ ty) = isVariableType ty +isSimpleType (ArrowType _ ty1 ty2) = isVariableType ty1 && isVariableType ty2 +isSimpleType (ParenType _ ty) = isSimpleType ty +isSimpleType (ForallType _ _ _) = False + +-- |Return the qualified type constructor of a type expression. +typeConstr :: TypeExpr -> QualIdent +typeConstr (ConstructorType _ tc) = tc +typeConstr (ApplyType _ ty _) = typeConstr ty +typeConstr (TupleType _ tys) = qTupleId (length tys) +typeConstr (ListType _ _) = qListId +typeConstr (ArrowType _ _ _) = qArrowId +typeConstr (ParenType _ ty) = typeConstr ty +typeConstr (VariableType _ _) = + error "Curry.Syntax.Utils.typeConstr: variable type" +typeConstr (ForallType _ _ _) = + error "Curry.Syntax.Utils.typeConstr: forall type" + +-- |Return the list of variables occuring in a type expression. +typeVariables :: TypeExpr -> [Ident] +typeVariables (ConstructorType _ _) = [] +typeVariables (ApplyType _ ty1 ty2) = typeVariables ty1 ++ typeVariables ty2 +typeVariables (VariableType _ tv) = [tv] +typeVariables (TupleType _ tys) = concatMap typeVariables tys +typeVariables (ListType _ ty) = typeVariables ty +typeVariables (ArrowType _ ty1 ty2) = typeVariables ty1 ++ typeVariables ty2 +typeVariables (ParenType _ ty) = typeVariables ty +typeVariables (ForallType _ vs ty) = vs ++ typeVariables ty + +-- |Return the identifier of a variable. +varIdent :: Var a -> Ident +varIdent (Var _ v) = v + +-- |Convert an infix operator into an expression +infixOp :: InfixOp a -> Expression a +infixOp (InfixOp a op) = Variable NoSpanInfo a op +infixOp (InfixConstr a op) = Constructor NoSpanInfo a op + +-- |flatten the left-hand-side to the identifier and all constructor terms +flatLhs :: Lhs a -> (Ident, [Pattern a]) +flatLhs lhs = flat lhs [] + where flat (FunLhs _ f ts) ts' = (f, ts ++ ts') + flat (OpLhs _ t1 op t2) ts' = (op, t1 : t2 : ts') + flat (ApLhs _ lhs' ts) ts' = flat lhs' (ts ++ ts') + +-- |Return the arity of an equation. +eqnArity :: Equation a -> Int +eqnArity (Equation _ lhs _) = length $ snd $ flatLhs lhs + +-- |Select the label of a field +fieldLabel :: Field a -> QualIdent +fieldLabel (Field _ l _) = l + +-- |Select the term of a field +fieldTerm :: Field a -> a +fieldTerm (Field _ _ t) = t + +-- |Select the label and term of a field +field2Tuple :: Field a -> (QualIdent, a) +field2Tuple (Field _ l t) = (l, t) + +-- |Get the operator name of an infix operator +opName :: InfixOp a -> QualIdent +opName (InfixOp _ op) = op +opName (InfixConstr _ c ) = c + +-- | Get the identifier of a constructor declaration +constrId :: ConstrDecl -> Ident +constrId (ConstrDecl _ c _) = c +constrId (ConOpDecl _ _ op _) = op +constrId (RecordDecl _ c _) = c + +-- | Get the identifier of a newtype constructor declaration +nconstrId :: NewConstrDecl -> Ident +nconstrId (NewConstrDecl _ c _) = c +nconstrId (NewRecordDecl _ c _) = c + +-- | Get the type of a newtype constructor declaration +nconstrType :: NewConstrDecl -> TypeExpr +nconstrType (NewConstrDecl _ _ ty) = ty +nconstrType (NewRecordDecl _ _ (_, ty)) = ty + +-- | Get record label identifiers of a constructor declaration +recordLabels :: ConstrDecl -> [Ident] +recordLabels (ConstrDecl _ _ _) = [] +recordLabels (ConOpDecl _ _ _ _) = [] +recordLabels (RecordDecl _ _ fs) = [l | FieldDecl _ ls _ <- fs, l <- ls] + +-- | Get record label identifier of a newtype constructor declaration +nrecordLabels :: NewConstrDecl -> [Ident] +nrecordLabels (NewConstrDecl _ _ _ ) = [] +nrecordLabels (NewRecordDecl _ _ (l, _)) = [l] + +-- | Get the declared method identifiers of a type class method declaration +methods :: Decl a -> [Ident] +methods (TypeSig _ fs _) = fs +methods _ = [] + +-- | Get the method identifiers of a type class method implementations +impls :: Decl a -> [Ident] +impls (FunctionDecl _ _ f _) = [f] +impls _ = [] + +-- | Get the declared method identifier of an interface method declaration +imethod :: IMethodDecl -> Ident +imethod (IMethodDecl _ f _ _) = f + +-- | Get the arity of an interface method declaration +imethodArity :: IMethodDecl -> Maybe Int +imethodArity (IMethodDecl _ _ a _) = a + +-------------------------------------------------------- +-- constructing elements of the abstract syntax tree +-------------------------------------------------------- + +funDecl :: SpanInfo -> a -> Ident -> [Pattern a] -> Expression a -> Decl a +funDecl spi a f ts e = FunctionDecl spi a f [mkEquation spi f ts e] + +mkEquation :: SpanInfo -> Ident -> [Pattern a] -> Expression a -> Equation a +mkEquation spi f ts e = Equation spi (FunLhs NoSpanInfo f ts) (simpleRhs NoSpanInfo e) + +simpleRhs :: SpanInfo -> Expression a -> Rhs a +simpleRhs spi e = SimpleRhs spi WhitespaceLayout e [] + +patDecl :: SpanInfo -> Pattern a -> Expression a -> Decl a +patDecl spi t e = PatternDecl spi t (SimpleRhs spi WhitespaceLayout e []) + +varDecl :: SpanInfo -> a -> Ident -> Expression a -> Decl a +varDecl p ty = patDecl p . VariablePattern NoSpanInfo ty + +constrPattern :: a -> QualIdent -> [(a, Ident)] -> Pattern a +constrPattern ty c = ConstructorPattern NoSpanInfo ty c + . map (uncurry (VariablePattern NoSpanInfo)) + +caseAlt :: SpanInfo -> Pattern a -> Expression a -> Alt a +caseAlt spi t e = Alt spi t (SimpleRhs spi WhitespaceLayout e []) + +mkLet :: [Decl a] -> Expression a -> Expression a +mkLet ds e = if null ds then e else Let NoSpanInfo WhitespaceLayout ds e + +mkVar :: a -> Ident -> Expression a +mkVar ty = Variable NoSpanInfo ty . qualify + +mkCase :: CaseType -> Expression a -> [Alt a] -> Expression a +mkCase = Case NoSpanInfo WhitespaceLayout + +mkLambda :: [Pattern a] -> Expression a -> Expression a +mkLambda = Lambda NoSpanInfo + +apply :: Expression a -> [Expression a] -> Expression a +apply = foldl (Apply NoSpanInfo) + +unapply :: Expression a -> [Expression a] -> (Expression a, [Expression a]) +unapply (Apply _ e1 e2) es = unapply e1 (e2 : es) +unapply e es = (e, es) + + +-------------------------------------------------------- +-- Shorten Module +-- Module Pragmas and Equations will be removed +-------------------------------------------------------- + +shortenModuleAST :: Module () -> Module () +shortenModuleAST = shortenAST + +class ShortenAST a where + shortenAST :: a -> a + +instance ShortenAST (Module a) where + shortenAST (Module spi li _ mid ex im ds) = + Module spi li [] mid ex im (map shortenAST ds) + +instance ShortenAST (Decl a) where + shortenAST (FunctionDecl spi a idt _) = + FunctionDecl spi a idt [] + shortenAST (ClassDecl spi li cx cls tyv ds) = + ClassDecl spi li cx cls tyv (map shortenAST ds) + shortenAST (InstanceDecl spi li cx cls tyv ds) = + InstanceDecl spi li cx cls tyv (map shortenAST ds) + shortenAST d = d diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000000000000000000000000000000000000..fecdf1d2d29b4c2da81f2827d46c3076254dc9c4 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,5 @@ +resolver: lts-14.7 +packages: + - . +extra-deps: + - set-extra-1.4.1 diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000000000000000000000000000000000000..925196184b388b4c8941071dec32bbb9c2ed30a7 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,19 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: set-extra-1.4.1@sha256:c58aa620704f609f289953e7c1f9c1653fd1498f0984b0f03a3f8f38f7ed5a84,533 + pantry-tree: + size: 268 + sha256: 3b6f94160b9d868f341d841de0e3e9f354ae90b5817b171e2bb68fd67cf2790c + original: + hackage: set-extra-1.4.1 +snapshots: +- completed: + size: 523700 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/7.yaml + sha256: 8e3f3c894be74d71fa4bf085e0a8baae7e4d7622d07ea31a52736b80f8b9bb1a + original: lts-14.7 diff --git a/test/TestFrontend.hs b/test/TestFrontend.hs index a8568f61bc2a0c3e63179e8d843a69b2efbc15c8..d93f0ec97901fec03b9d381eddc8649edb349f0c 100644 --- a/test/TestFrontend.hs +++ b/test/TestFrontend.hs @@ -173,6 +173,7 @@ failInfos = map (uncurry mkFailTest) , "Functional patterns are not supported inside a do sequence" ] ) + , ("HaskellRecordsFail", ["Unexpected token `,'"]) , ("FP_NonGlobal", ["Function `f1' in functional pattern is not global"]) , ("ImportError", [ "Module Prelude does not export foo" @@ -249,6 +250,7 @@ passInfos = map mkPassTest , "FP_NonLinearity" , "FunctionalPatterns" , "HaskellRecords" + , "HaskellRecordsPass" , "Hierarchical" , "ImportRestricted" , "ImportRestricted2" diff --git a/test/fail/HaskellRecordsFail.curry b/test/fail/HaskellRecordsFail.curry new file mode 100644 index 0000000000000000000000000000000000000000..2d827af39d6d5d24d806e8d207eaa9fac4aa6a67 --- /dev/null +++ b/test/fail/HaskellRecordsFail.curry @@ -0,0 +1,5 @@ +-- newtype +-- should NOT be parsed +newtype RN = RN { x,y :: Int } +newtype RN = RN { x :: Int, y :: Bool } +newtype RN = RN { } diff --git a/test/pass/HaskellRecordsPass.curry b/test/pass/HaskellRecordsPass.curry new file mode 100644 index 0000000000000000000000000000000000000000..83de3f5f0a384e3f7071c1263681ff21fd208c4e --- /dev/null +++ b/test/pass/HaskellRecordsPass.curry @@ -0,0 +1,27 @@ +-- data +data D = C1 Int + | C2 String + | C3 Bool +data RD1 = RD1 {} +data RD2 = RD2 { x,y,z :: Int, a :: Bool, r :: RD1 } +data RD3 a = RD3 { f :: a } + +-- newtype +newtype RN = RN { x' :: Int } + +-- record construction +r1 = RD1 { } +r2 = RD2 { x = 12, y = 24, z = 34, a = False, r = r1 } +r3 = RD3 { f = r2 } + +-- record selection +i = x r2 + +-- record update +r2' = r2 { x = 12, y = 72 } +r3' = (f r3) { x = 12, y = 72 } + +-- record pattern +f' RD2 { x = 45 } = True +f' RD2 { x = 45, a = False } = True +f' RD2 { } = True diff --git a/test/pass/Pragmas.curry b/test/pass/Pragmas.curry new file mode 100644 index 0000000000000000000000000000000000000000..4410787b5b108fe4d87634bd94e3ac45626442a1 --- /dev/null +++ b/test/pass/Pragmas.curry @@ -0,0 +1,6 @@ +{-# LANGUAGE Records #-} +{-# OPTIONS_KICS2 -v2 #-} +module Pragmas where + +f :: a -> a +f x = x diff --git a/util/canonfint.hs b/util/canonfint.hs new file mode 100644 index 0000000000000000000000000000000000000000..ab8b7cf68cf127c873e06829a6b77078596fda8c --- /dev/null +++ b/util/canonfint.hs @@ -0,0 +1,77 @@ +{- | + 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) + ] diff --git a/util/lex.hs b/util/lex.hs new file mode 100644 index 0000000000000000000000000000000000000000..b0e2256595ecb0428c4a6430a1a19cb3f3d7f80f --- /dev/null +++ b/util/lex.hs @@ -0,0 +1,20 @@ +module 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 diff --git a/util/parse.hs b/util/parse.hs new file mode 100644 index 0000000000000000000000000000000000000000..f2db2f649f54498e1a6fc62d8abc596e478eeee1 --- /dev/null +++ b/util/parse.hs @@ -0,0 +1,21 @@ +module 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