diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,16 @@ Change log for curry-frontend ============================= +Version 2.0.0 +============= + + * Implemented the "MonadFail-Proposal" for curry + (see ) + * Data class (see ) + * Fixed bug with partially imported Typeclasses + * Fixed bug with parsing of empty blocks + * Fixed bug with re-export of record labels + Version 1.0.4 ============= @@ -314,3 +324,4 @@ * All compiler warnings removed. * Fixed various implementation bugs (#9, #16, #19, #29, #289). + diff --git a/LIESMICH b/LIESMICH deleted file mode 100644 --- a/LIESMICH +++ /dev/null @@ -1,172 +0,0 @@ -=============================================================================== -== -== Münster-Curry-Compiler -== Distribution zur Anwendung als Frontend in PAKCS -== -== Letztes Update: 27.10.05 - -Diese Distribution enthält die modifizierte Version des -Münster-Curry-Compilers (MCC) für die Verwendung als Frontend in PAKCS. Dieses -System ist u.a. in der Lage aus Curry-Programmen (entwickelt nach -PAKCS-Standard) Flat-Darstellungen (FlatCurry ".fcy", FlatInterface ".fint" -und FlatXML "_flat.xml"), sowie Abstract-Darstellungen (AbstractCurry ".acy" -und untyped AbstractCurry ".uacy") zu generieren. - - - -1. Installation ---------------- - -1.1 Installation der Binary-Distribution - -Die Binary-Distribution befindet sich in einem tar-Archiv und wird -durch folgendes Kommando entpackt: - - tar zxvf .tar.gz - -Danach steht der Compiler im Verzeichnis 'mcc' zur Verfügung. - - -1.2 Installation der Source-Distribution - -Nach dem Entpacken des tar-Archivs mittels - - tar zxvf .tar.gz - -kann der Compiler durch Aufruf von 'make' im Verzeichnis 'mcc' installiert -werden. Bei Recompilierung (z.B. nach Änderungen in der Quelldateien) -wird empfohlen vor einer erneuten Installation 'make clean' auszuführen. - - - -Nach erfolgreicher Installation befindet sich in beiden Fällen im Verzeichnis -'mcc/bin/' folgende ausführbare Datei: - - cymake - der Curry-Programm-Builder - -Dieses Tool übersetzt Curry-Programme unter Berücksichtigung der Import- -abhängigkeiten. - - - -2. Kommandoübersicht --------------------- - -In der folgenden Tabelle sind die Optionen zur Generierung der jeweiligen -Darstellungen für das Kommando 'cymake' aufgelistet: - - --flat : Erzeugt FlatCurry- und FlatInterface-Datei - --xml : Erzeugt FlatXML-Datei - --acy : Erzeugt (typinferierte) AbstractCurry-Datei - --uacy : Erzeugt ungetypte AbstractCurry-Datei - - - -3. Erzeugung von FlatCurry- und FlatXML-Programmen --------------------------------------------------- - -Die Übersetzung eines Curry-Programms 'file.curry', sowie sämtlicher -importierter Module nach FlatCurry bzw. FlatInterface, bewirkt folgendes -Kommando: - - cymake --flat - -Hierdurch werden die Dateien mit den entsprechenden Endungen ".fcy" und -".fint" generiert. Der Dateiname kann hierbei mit oder ohne -Endung ".curry" bzw. ".lcurry" angegeben werden. - -Die analogen Übersetzungen in die FlatXML-Darstellung bewirkt folgendes -Kommando: - - cymake --xml - -Die hierdurch generierte Flat-XML-Datei hat die Endung '_flat.xml'. - - - -4. Erzeugung von AbstractCurry-Programmen ------------------------------------------ - -Die Übersetzung eines Curry-Programms 'file.curry' nach (typgeprüftem) -AbstractCurry bewirkt folgendes Kommando: - - cymake --acy - -Hierdurch wird die entsprechende Datei (mit der Endung ".acy") generiert. -Der Dateiname kann hierbei mit oder ohne Endung ".curry" bzw. -".lcurry" angegeben werden. - -Ungetypte, bzw. typsignierte AbstractCurry-Programme werden mit folgendem -Kommando generiert: - - cymake --uacy - -Die hierdurch generierte Datei besitzt die Endung ".uacy". - -Die Generierung des ungetypten AbstractCurry-Programms findet ohne -Typüberprüfung statt (d.h. auch Programme mit Typfehlern werden übersetzt). -Alle Funktionen besitzen entweder die im Quellprogramm angegebenen Typsignatur, -oder, sofern diese nicht vorhanden ist, den Dummy-Typ "prelude.untyped". - -In beiden Fällen werden für die Übersetzung FlatCurry-Dateien -für alle importierten Module erzeugt. Dies ist notwendig, da die -entsprechenden Interfaces für die Typinferenz (nur im Fall der getypten -AbstractCurry-Generierung) und die statisch-semantische Analyse benötigt -werden. - - - -5. Anmerkungen --------------- - -- Um die PAKCS-Bibliotheken (insbesondere die Prelude) für Übersetzungen - nutzen zu können muß die Umgebungsvariable 'PAKCS_LIB' auf die - entsprechenden Pfade verweisen, z.B. mittels - - export PAKCS_LIB=/pacs/lib:/pacs/lib/meta:... - - wobei das Verzeichnis ist, das die PAKCS-Distribution - enthält. - -- Im Gegensatz zu PAKCS erlaubt das Frontend die Verwendung anonymer - Variablen (dargestellt durch dem Unterstrich '_') in Typdeklarationen, - z.B. - - data T _ = C - - - -Bekannte Probleme ------------------- - -- Lambda-, do-, if-, case-, oder let-Ausdrücke, die in Argumenten von - Funktionsaufrufen verwendet werden, müssen immer geklammert werden. - -- 'let'-Anweisungen dürfen nicht folgendes Layout besitzen: - - let x = - in ... - -- Die Regeln einer Funktionsdeklaration müssen immer zusammenstehen, d.h. - nicht durch andere Deklarationen unterbrochen werden. - -- Es ist bislang nicht möglich, den Konstruktor für leere Listen [], sowie - den Unit-Konstruktor () zu qualifizieren (z.B. führt 'prelude.[]' zu - einem Fehler). Der Listenkonstruktor (:), sowie Tupel-Konstruktoren - dagegen sind qualifizierbar. - -- FlatXML-Übersetzungen können derzeit mittels der Funktionen aus dem - PAKCS-Modul "FlatXML" noch nicht eingelesen werden, da es Unstimmigkeiten - zwischen dem generierten und den erforderlichen Formaten gibt. - -- Bei der Erzeugung von typgeprüftem AbstractCurry können die im Quelltext - verwendeten Bezeichner für Typvariablen nicht ins AbstractCurry-Programm - übernommen werden. Stattdessen generiert der Übersetzer neue - Bezeichner. - -- Bei der Erzeugung von ungetyptem AbstractCurry werden Typsynonyme in - Typsignaturen von Funktionen nicht dereferenziert. - -- Das Frontend gibt derzeit noch keinerlei Warnungen aus. - - diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,65 @@ +# Curry Frontend + +The frontend lexes, parses, type-checks and transforms Curry source files into a variety of intermediate formats, including + +* **FlatCurry** for program analyzers and backends +* **AbstractCurry** for program manipulation tools +* **HTML** for documentation + +It is used by the two major Curry compilers, [PAKCS](https://git.ps.informatik.uni-kiel.de/curry/pakcs) and +[KiCS2](https://git.ps.informatik.uni-kiel.de/curry/kics2). + +## Requirements + +* Make sure that a recent version of Haskell Stack is installed on your computer + +## Building + +* To build the project, run `make`. +* To test the project, run `make runtests`. + +The built executable will be located at `bin/curry-frontend`. + +## Usage + +For a detailed overview of the available options, you can use the following command: + +`curry-frontend --help` + +### Available Formats + +``` +--flat : Generate a FlatCurry (.fcy) and FlatInterface (.fint) file +--xml : Generate a FlatXML (_flat.xml) file +--acy : Generate a (type-inferred) AbstractCurry (.acy) file +--uacy : Generate an untyped AbstractCurry (.uacy) file +``` + +The generation of an untyped AbstractCurry program is performed without +type checking (i.e. programs with type checks will compile). All functions +will either have the type signature specified in the source or, if not +available, the dummy type `prelude.untyped`. + +FlatCurry files will always be generated for the imported modules, +since the interfaces are required for static-semantic analysis and type +inference (only for typed AbstractCurry). + +## Remarks + +- To use the PAKCS libraries (especially for the `Prelude`), the environment + variable `PAKCS_LIB` has to point to the correct paths, e.g. using + + `export PAKCS_LIB=[pakcs path]/pacs/lib:[pakcs path]/pacs/lib/meta:...` + + where `[pakcs path]` is the directory containing the PAKCS distribution. + +- In contrast to PAKCS, the frontend allow use of anonymous variables + (denoted by an underscore `_`) in type declarations, e.g. + + ```curry + data T _ = c + ``` + +## Known Issues + +[See GitLab](https://git.ps.informatik.uni-kiel.de/curry/curry-frontend/-/issues) diff --git a/app/cymake.hs b/app/cymake.hs new file mode 100644 --- /dev/null +++ b/app/cymake.hs @@ -0,0 +1,57 @@ +{- | + Module : $Header$ + Description : Main module + Copyright : (c) 2005 Martin Engelke + 2011 - 2016 Björn Peemöller + License : BSD-3-clause + + Maintainer : bjp@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + Command line tool for generating Curry representations (e.g. FlatCurry, + AbstractCurry) for a Curry source file including all imported modules. +-} +module Main (main) where + +import Curry.Base.Monad (runCYIO) + +import Base.Messages +import Files.CymakePath (cymakeGreeting, cymakeVersion) + +import CurryBuilder (buildCurry) +import CompilerOpts (Options (..), CymakeMode (..), getCompilerOpts, usage) + +-- |The command line tool cymake +main :: IO () +main = getCompilerOpts >>= cymake + +-- |Invoke the curry builder w.r.t the command line arguments +cymake :: (String, Options, [String], [String]) -> IO () +cymake (prog, opts, files, errs) = case optMode opts of + ModeHelp -> printUsage prog + ModeVersion -> printVersion + ModeNumericVersion -> printNumericVersion + ModeMake | not (null errs) -> badUsage prog errs + | null files -> badUsage prog ["No input files"] + | otherwise -> runCYIO (mapM_ (buildCurry opts) files) >>= + either abortWithMessages continueWithMessages + where continueWithMessages = warnOrAbort (optWarnOpts opts) . snd + +-- |Print the usage information of the command line tool +printUsage :: String -> IO () +printUsage prog = putStrLn $ usage prog + +-- |Print the program version +printVersion :: IO () +printVersion = putStrLn cymakeGreeting + +-- |Print the numeric program version +printNumericVersion :: IO () +printNumericVersion = putStrLn cymakeVersion + +-- |Print errors and abort execution on bad parameters +badUsage :: String -> [String] -> IO () +badUsage prog errs = do + putErrsLn $ map (\ err -> prog ++ ": " ++ err) errs + abortWith ["Try '" ++ prog ++ " --help' for more information"] diff --git a/curry-frontend.cabal b/curry-frontend.cabal --- a/curry-frontend.cabal +++ b/curry-frontend.cabal @@ -1,9 +1,9 @@ -Name: curry-frontend -Version: 1.0.4 -Cabal-Version: >= 1.10 -Synopsis: Compile the functional logic language Curry to several +name: curry-frontend +version: 2.0.0 +cabal-version: 2.0 +synopsis: Compile the functional logic language Curry to several intermediate formats -Description: The Curry front end consists of the executable program +description: The Curry front end consists of the executable program "curry-frontend". It is used by various backends to compile Curry programs to an intermediate representation. @@ -14,52 +14,49 @@ representations. For further information, please check -Category: Language -License: BSD3 -License-File: LICENSE -Author: Wolfgang Lux, Martin Engelke, Bernd Brassel, Holger Siegel, +category: Language +license: BSD3 +license-file: LICENSE +author: Wolfgang Lux, Martin Engelke, Bernd Brassel, Holger Siegel, Bjoern Peemoeller, Finn Teegen -Maintainer: fte@informatik.uni-kiel.de -Homepage: http://curry-language.org -Build-Type: Simple -Stability: experimental +maintainer: fte@informatik.uni-kiel.de +homepage: http://curry-language.org +build-type: Simple +stability: experimental -Extra-Source-Files: LIESMICH CHANGELOG.md +extra-source-files: README.md CHANGELOG.md -Data-Dir: data -Data-Files: currysource.css +data-dir: data +data-files: currysource.css source-repository head type: git location: https://git.ps.informatik.uni-kiel.de/curry/curry-frontend.git -Flag network-uri - description: Get Network.URI from the network-uri package - default: True - -Library +library hs-source-dirs: src - default-language: Haskell2010 - Build-Depends: - base == 4.* - , containers - , curry-base == 1.1.1 - , directory - , template-haskell >= 2.10 && < 3 - , bytestring >= 0.10 && < 0.11 - , extra >= 1.4.6 - , filepath - , mtl - , pretty - , process - , file-embed - , set-extra - , transformers - if flag(network-uri) - build-depends: network-uri >= 2.6 - else - build-depends: network < 2.6 - Exposed-Modules: + default-language: Haskell2010 + other-extensions: CPP, TemplateHaskell + ghc-options: -Wall + build-depends: + base >= 4.11 && < 4.15 + , template-haskell >= 2.10 && < 2.16 + , extra >= 1.4.6 && < 1.8 + , transformers >= 0.5 && < 0.6 + , mtl >= 2.2 && < 2.3 + , directory >= 1.2 && < 1.4 + , filepath >= 1.4 && < 1.5 + , file-embed >= 0.0 && < 0.1 + , containers >= 0.6 && < 0.7 + , set-extra >= 1.4 && < 1.5 + , bytestring >= 0.10 && < 0.11 + , process >= 1.6 && < 1.7 + , network-uri >= 2.6 && < 2.7 + , pretty >= 1.1 && < 1.2 + , binary >= 0.8 && < 0.9 + , time >= 1.9 && < 2.0 + , parsec >= 3.1 && < 3.2 + exposed-modules: Base.AnnotExpr , Base.CurryKinds , Base.CurryTypes @@ -92,6 +89,44 @@ , Checks.TypeCheck , Checks.TypeSyntaxCheck , Checks.WarnCheck + , Curry.AbstractCurry + , Curry.AbstractCurry.Files + , Curry.AbstractCurry.Type + , Curry.Base.Ident + , Curry.Base.LexComb + , Curry.Base.LLParseComb + , Curry.Base.Message + , Curry.Base.Monad + , Curry.Base.Position + , Curry.Base.Pretty + , Curry.Base.Span + , Curry.Base.SpanInfo + , Curry.CondCompile.Parser + , Curry.CondCompile.Transform + , Curry.CondCompile.Type + , Curry.Files.Filenames + , Curry.Files.PathUtils + , Curry.Files.Unlit + , Curry.FlatCurry + , Curry.FlatCurry.Files + , Curry.FlatCurry.Goodies + , Curry.FlatCurry.InterfaceEquivalence + , Curry.FlatCurry.Pretty + , Curry.FlatCurry.Type + , Curry.FlatCurry.Typeable + , Curry.FlatCurry.Annotated.Goodies + , Curry.FlatCurry.Annotated.Type + , Curry.FlatCurry.Typed.Goodies + , Curry.FlatCurry.Typed.Type + , Curry.Syntax + , Curry.Syntax.Extension + , Curry.Syntax.InterfaceEquivalence + , Curry.Syntax.Lexer + , Curry.Syntax.Parser + , Curry.Syntax.Pretty + , Curry.Syntax.ShowModule + , Curry.Syntax.Type + , Curry.Syntax.Utils , CompilerEnv , CompilerOpts , CondCompile @@ -111,7 +146,7 @@ , Generators.GenAbstractCurry , Generators.GenFlatCurry , Generators.GenTypedFlatCurry - , Generators.GenTypeAnnotatedFlatCurry + , Generators.GenAnnotatedFlatCurry , Html.CurryHtml , Html.SyntaxColoring , IL @@ -133,42 +168,40 @@ , Transformations.Newtypes , Transformations.Qual , Transformations.Simplify - other-modules: - Paths_curry_frontend + , Paths_curry_frontend autogen-modules: - Paths_curry_frontend - ghc-options: -Wall + Paths_curry_frontend -Executable curry-frontend - hs-source-dirs: src - Main-is: cymake.hs - default-language: Haskell2010 - Build-Depends: - base == 4.* - , containers - , curry-base == 1.1.1 +executable curry-frontend + hs-source-dirs: app + main-is: cymake.hs + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >= 4.11 , curry-frontend - , directory - , template-haskell >= 2.10 && < 3 - , bytestring >= 0.10 && < 0.11 + +test-suite test-frontend + type: detailed-0.9 + hs-source-dirs: test + test-module: TestFrontend + default-language: Haskell2010 + other-extensions: CPP, TemplateHaskell + ghc-options: -Wall + build-depends: + base >= 4.11 + , Cabal >= 1.20 + , template-haskell >= 2.10 , extra >= 1.4.6 - , filepath + , transformers , mtl - , pretty - , process + , directory >= 1.2.0.1 + , filepath , file-embed + , containers , set-extra - , transformers - if flag(network-uri) - build-depends: network-uri >= 2.6 - else - build-depends: network < 2.6 - ghc-options: -Wall - -Test-Suite test-frontend - type: detailed-0.9 - hs-source-dirs: test - default-language: Haskell2010 - test-module: TestFrontend - build-depends: base == 4.*, Cabal >= 1.20, curry-base == 1.1.1 - , curry-frontend, filepath + , bytestring >= 0.10 + , process + , network-uri >= 2.6 + , pretty + , curry-frontend diff --git a/data/currysource.css b/data/currysource.css --- a/data/currysource.css +++ b/data/currysource.css @@ -1,7 +1,23 @@ -/* Use always white background. */ +:root { + --link-bg-color: lightyellow; + --line-number-color: grey; + --pragma-color: green; + --comment-color: green; + --keyword-color: blue; + --symbol-color: red; + --type-color: orange; + --cons-color: magenta; + --label-color: darkgreen; + --func-color: purple; + --ident-color: black; + --module-color: brown; + --number-color: teal; + --string-color: maroon; + --char-color: maroon; + color-scheme: light dark; +} + body { - background: white; - color: black; font-family: monospace; text-size-adjust: none; -moz-text-size-adjust: none; @@ -13,18 +29,18 @@ border-collapse: collapse; } -/* Show hyperlinks without text decoration, but in light yellow. */ +/* Hyperlinks */ a:link, a:visited, a:active { - background: lightyellow; + background: var(--link-bg-color); text-decoration: none; } /* Line numbers */ .line-numbers { - border-right: 1px solid grey; - color: grey; + border-right: 1px solid var(--line-number-color); + color: var(--line-number-color); min-width: 5ch; padding-right: 1em; text-align: right; @@ -36,16 +52,44 @@ } /* Code highlighting */ -.pragma { color: green } -.comment { color: green } -.keyword { color: blue } -.symbol { color: red } -.type { color: orange } -.cons { color: magenta } -.label { color: darkgreen } -.func { color: purple } -.ident { color: black } -.module { color: brown } -.number { color: teal } -.string { color: maroon } -.char { color: maroon } +.pragma { color: var(--pragma-color) } +.comment { color: var(--comment-color) } +.keyword { color: var(--keyword-color) } +.symbol { color: var(--symbol-color) } +.type { color: var(--type-color) } +.cons { color: var(--cons-color) } +.label { color: var(--label-color) } +.func { color: var(--func-color) } +.ident { color: var(--ident-color) } +.module { color: var(--module-color) } +.number { color: var(--number-color) } +.string { color: var(--string-color) } +.char { color: var(--char-color) } + +@supports not (color-scheme: light dark) { + @media (prefers-color-scheme: dark) { + html { + background: hsl(0, 0%, 12%); + color: white; + } + } +} + +@media (prefers-color-scheme: dark) { + :root { + --link-bg-color: hsl(0, 0%, 17%); + --pragma-color: hsl(0, 0%, 60%); + --comment-color: hsl(0, 0%, 60%); + --keyword-color: hsl(300, 66%, 70%); + --symbol-color: hsl(0, 66%, 70%); + --type-color: hsl(60, 66%, 70%); + --cons-color: hsl(330, 66%, 70%); + --label-color: hsl(240, 66%, 70%); + --func-color: hsl(200, 66%, 70%); + --ident-color: hsl(0, 0%, 85%); + --module-color: hsl(20, 66%, 70%); + --number-color: hsl(180, 66%, 70%); + --string-color: hsl(120, 66%, 70%); + --char-color: hsl(120, 66%, 70%); + } +} diff --git a/src/Base/AnnotExpr.hs b/src/Base/AnnotExpr.hs --- a/src/Base/AnnotExpr.hs +++ b/src/Base/AnnotExpr.hs @@ -33,11 +33,11 @@ -- variables cannot be computed independently for each declaration. instance QualAnnotExpr Decl where - qafv m (FunctionDecl _ _ _ eqs) = concatMap (qafv m) eqs - qafv m (PatternDecl _ _ rhs) = qafv m rhs - qafv m (ClassDecl _ _ _ _ ds) = concatMap (qafv m) ds - qafv m (InstanceDecl _ _ _ _ ds) = concatMap (qafv m) ds - qafv _ _ = [] + qafv m (FunctionDecl _ _ _ eqs) = concatMap (qafv m) eqs + qafv m (PatternDecl _ _ rhs) = qafv m rhs + qafv m (ClassDecl _ _ _ _ _ ds) = concatMap (qafv m) ds + qafv m (InstanceDecl _ _ _ _ _ ds) = concatMap (qafv m) ds + qafv _ _ = [] instance QualAnnotExpr Equation where qafv m (Equation _ lhs rhs) = filterBv lhs $ qafv m lhs ++ qafv m rhs @@ -46,8 +46,8 @@ qafv m = concatMap (qafv m) . snd . flatLhs instance QualAnnotExpr Rhs where - qafv m (SimpleRhs _ e ds) = filterBv ds $ qafv m e ++ concatMap (qafv m) ds - qafv m (GuardedRhs _ es ds) = + qafv m (SimpleRhs _ _ e ds) = filterBv ds $ qafv m e ++ concatMap (qafv m) ds + qafv m (GuardedRhs _ _ es ds) = filterBv ds $ concatMap (qafv m) es ++ concatMap (qafv m) ds instance QualAnnotExpr CondExpr where @@ -75,11 +75,11 @@ qafv m (LeftSection _ e op) = qafv m op ++ qafv m e qafv m (RightSection _ op e) = qafv m op ++ qafv m e qafv m (Lambda _ ts e) = filterBv ts $ qafv m e - qafv m (Let _ ds e) = + qafv m (Let _ _ ds e) = filterBv ds $ concatMap (qafv m) ds ++ qafv m e - qafv m (Do _ sts e) = foldr (qafvStmt m) (qafv m e) sts + qafv m (Do _ _ sts e) = foldr (qafvStmt m) (qafv m e) sts qafv m (IfThenElse _ e1 e2 e3) = qafv m e1 ++ qafv m e2 ++ qafv m e3 - qafv m (Case _ _ e alts) = qafv m e ++ concatMap (qafv m) alts + qafv m (Case _ _ _ e alts) = qafv m e ++ concatMap (qafv m) alts qafvField :: QualAnnotExpr e => ModuleIdent -> Field (e Type) -> [(Type, Ident)] qafvField m (Field _ _ t) = qafv m t @@ -88,9 +88,9 @@ qafvStmt m st fvs = qafv m st ++ filterBv st fvs instance QualAnnotExpr Statement where - qafv m (StmtExpr _ e) = qafv m e - qafv m (StmtDecl _ ds) = filterBv ds $ concatMap (qafv m) ds - qafv m (StmtBind _ _ e) = qafv m e + qafv m (StmtExpr _ e) = qafv m e + qafv m (StmtDecl _ _ ds) = filterBv ds $ concatMap (qafv m) ds + qafv m (StmtBind _ _ e) = qafv m e instance QualAnnotExpr Alt where qafv m (Alt _ t rhs) = filterBv t $ qafv m rhs diff --git a/src/Base/CurryKinds.hs b/src/Base/CurryKinds.hs --- a/src/Base/CurryKinds.hs +++ b/src/Base/CurryKinds.hs @@ -20,7 +20,7 @@ ) where import Curry.Base.Pretty (Doc) -import Curry.Syntax.Pretty (ppKindExpr) +import Curry.Syntax.Pretty (pPrintPrec) import Curry.Syntax.Type (KindExpr (..)) import Base.Kinds @@ -42,4 +42,4 @@ | otherwise = Just (fromKind k) ppKind :: Kind -> Doc -ppKind = ppKindExpr 0 . fromKind +ppKind = pPrintPrec 0 . fromKind diff --git a/src/Base/CurryTypes.hs b/src/Base/CurryTypes.hs --- a/src/Base/CurryTypes.hs +++ b/src/Base/CurryTypes.hs @@ -41,7 +41,7 @@ import Curry.Base.Pretty (Doc) import Curry.Base.SpanInfo import qualified Curry.Syntax as CS -import Curry.Syntax.Pretty (ppConstraint, ppTypeExpr, ppQualTypeExpr) +import Curry.Syntax.Pretty (pPrint, pPrintPrec) import Base.Expr import Base.Messages (internalError) @@ -201,13 +201,13 @@ -- The following functions implement pretty-printing for types. ppType :: ModuleIdent -> Type -> Doc -ppType m = ppTypeExpr 0 . fromQualType m identSupply +ppType m = pPrintPrec 0 . fromQualType m identSupply ppPred :: ModuleIdent -> Pred -> Doc -ppPred m = ppConstraint . fromQualPred m identSupply +ppPred m = pPrint . fromQualPred m identSupply ppPredType :: ModuleIdent -> PredType -> Doc -ppPredType m = ppQualTypeExpr . fromQualPredType m identSupply +ppPredType m = pPrint . fromQualPredType m identSupply ppTypeScheme :: ModuleIdent -> TypeScheme -> Doc ppTypeScheme m (ForAll _ pty) = ppPredType m pty diff --git a/src/Base/Expr.hs b/src/Base/Expr.hs --- a/src/Base/Expr.hs +++ b/src/Base/Expr.hs @@ -58,20 +58,20 @@ -- variables cannot be computed independently for each declaration. instance QualExpr (Decl a) where - qfv m (FunctionDecl _ _ _ eqs) = qfv m eqs - qfv m (PatternDecl _ _ rhs) = qfv m rhs - qfv m (ClassDecl _ _ _ _ ds) = qfv m ds - qfv m (InstanceDecl _ _ _ _ ds) = qfv m ds - qfv _ _ = [] + qfv m (FunctionDecl _ _ _ eqs) = qfv m eqs + qfv m (PatternDecl _ _ rhs) = qfv m rhs + qfv m (ClassDecl _ _ _ _ _ ds) = qfv m ds + qfv m (InstanceDecl _ _ _ _ _ ds) = qfv m ds + qfv _ _ = [] instance QuantExpr (Decl a) where - bv (TypeSig _ vs _) = vs - bv (FunctionDecl _ _ f _) = [f] - bv (ExternalDecl _ vs) = bv vs - bv (PatternDecl _ t _) = bv t - bv (FreeDecl _ vs) = bv vs - bv (ClassDecl _ _ _ _ ds) = concatMap methods ds - bv _ = [] + bv (TypeSig _ vs _) = vs + bv (FunctionDecl _ _ f _) = [f] + bv (ExternalDecl _ vs) = bv vs + bv (PatternDecl _ t _) = bv t + bv (FreeDecl _ vs) = bv vs + bv (ClassDecl _ _ _ _ _ ds) = concatMap methods ds + bv _ = [] instance QualExpr (Equation a) where qfv m (Equation _ lhs rhs) = filterBv lhs $ qfv m lhs ++ qfv m rhs @@ -83,8 +83,8 @@ qfv m lhs = qfv m $ snd $ flatLhs lhs instance QualExpr (Rhs a) where - qfv m (SimpleRhs _ e ds) = filterBv ds $ qfv m e ++ qfv m ds - qfv m (GuardedRhs _ es ds) = filterBv ds $ qfv m es ++ qfv m ds + qfv m (SimpleRhs _ _ e ds) = filterBv ds $ qfv m e ++ qfv m ds + qfv m (GuardedRhs _ _ es ds) = filterBv ds $ qfv m es ++ qfv m ds instance QualExpr (CondExpr a) where qfv m (CondExpr _ g e) = qfv m g ++ qfv m e @@ -110,18 +110,18 @@ qfv m (LeftSection _ e op) = qfv m op ++ qfv m e qfv m (RightSection _ op e) = qfv m op ++ qfv m e qfv m (Lambda _ ts e) = filterBv ts $ qfv m e - qfv m (Let _ ds e) = filterBv ds $ qfv m ds ++ qfv m e - qfv m (Do _ sts e) = foldr (qfvStmt m) (qfv m e) sts + qfv m (Let _ _ ds e) = filterBv ds $ qfv m ds ++ qfv m e + qfv m (Do _ _ sts e) = foldr (qfvStmt m) (qfv m e) sts qfv m (IfThenElse _ e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3 - qfv m (Case _ _ e alts) = qfv m e ++ qfv m alts + qfv m (Case _ _ _ e alts) = qfv m e ++ qfv m alts qfvStmt :: ModuleIdent -> (Statement a) -> [Ident] -> [Ident] qfvStmt m st fvs = qfv m st ++ filterBv st fvs instance QualExpr (Statement a) where - qfv m (StmtExpr _ e) = qfv m e - qfv m (StmtDecl _ ds) = filterBv ds $ qfv m ds - qfv m (StmtBind _ _ e) = qfv m e + qfv m (StmtExpr _ e) = qfv m e + qfv m (StmtDecl _ _ ds) = filterBv ds $ qfv m ds + qfv m (StmtBind _ _ e) = qfv m e instance QualExpr (Alt a) where qfv m (Alt _ t rhs) = filterBv t $ qfv m rhs @@ -136,9 +136,9 @@ qfv m (Field _ _ t) = qfv m t instance QuantExpr (Statement a) where - bv (StmtExpr _ _) = [] - bv (StmtBind _ t _) = bv t - bv (StmtDecl _ ds) = bv ds + bv (StmtExpr _ _) = [] + bv (StmtBind _ t _) = bv t + bv (StmtDecl _ _ ds) = bv ds instance QualExpr (InfixOp a) where qfv m (InfixOp a op) = qfv m $ Variable NoSpanInfo a op diff --git a/src/Base/Kinds.hs b/src/Base/Kinds.hs --- a/src/Base/Kinds.hs +++ b/src/Base/Kinds.hs @@ -53,3 +53,10 @@ -- |The function 'isSimpleKind' returns whether a kind is simple or not. isSimpleKind :: Kind -> Bool isSimpleKind k = k == simpleKind (kindArity k) + +-- |Fetches a kind's 'arguments', i.e. everything before an +-- arrow at the top-level. For example: A kind k1 -> k2 -> k3 +-- would have the arguments [k1, k2]. +kindArgs :: Kind -> [Kind] +kindArgs (KindArrow k k') = k : kindArgs k' +kindArgs _ = [] diff --git a/src/Base/Messages.hs b/src/Base/Messages.hs --- a/src/Base/Messages.hs +++ b/src/Base/Messages.hs @@ -17,7 +17,7 @@ -- * program abortion , abortWith, abortWithMessage, abortWithMessages, warnOrAbort, internalError -- * creating messages - , Message, message, posMessage + , Message, message, posMessage, spanInfoMessage ) where import Control.Monad (unless, when) @@ -26,8 +26,8 @@ import System.IO (hFlush, hPutStrLn, stderr, stdout) import System.Exit (exitFailure) -import Curry.Base.Message ( Message, message, posMessage, ppWarning - , ppMessages, ppError) +import Curry.Base.Message ( Message, message, posMessage, spanInfoMessage + , ppWarning, ppMessagesWithPreviews, ppError) import Curry.Base.Pretty (Doc, text) import CompilerOpts (Options (..), WarnOpts (..), Verbosity (..)) @@ -71,7 +71,7 @@ -- |Print a list of messages on 'stderr' printMessages :: (Message -> Doc) -> [Message] -> IO () printMessages msgType msgs - = unless (null msgs) $ putErrLn (show $ ppMessages msgType $ sort msgs) + = unless (null msgs) $ putErrLn =<< (fmap show $ ppMessagesWithPreviews msgType $ sort msgs) -- |Raise an internal error internalError :: String -> a diff --git a/src/Base/PrettyTypes.hs b/src/Base/PrettyTypes.hs --- a/src/Base/PrettyTypes.hs +++ b/src/Base/PrettyTypes.hs @@ -23,22 +23,21 @@ import Curry.Base.Ident (identSupply) import Curry.Base.Pretty -import Curry.Syntax.Pretty import Base.CurryTypes import Base.Types instance Pretty Type where - pPrint = ppTypeExpr 0 . fromType identSupply + pPrint = pPrintPrec 0 . fromType identSupply instance Pretty Pred where - pPrint = ppConstraint . fromPred identSupply + pPrint = pPrint . fromPred identSupply instance Pretty a => Pretty (Set.Set a) where pPrint = parens . list . map pPrint . Set.toAscList instance Pretty PredType where - pPrint = ppQualTypeExpr . fromPredType identSupply + pPrint = pPrint . fromPredType identSupply instance Pretty DataConstr where pPrint (DataConstr i tys) = pPrint i <+> hsep (map pPrint tys) diff --git a/src/Base/Types.hs b/src/Base/Types.hs --- a/src/Base/Types.hs +++ b/src/Base/Types.hs @@ -216,8 +216,13 @@ deriving (Eq, Show) -- We provide a custom 'Ord' instance for predicates here where we consider --- the type component of the predicate before the class component (see predicate --- sets below for more information). +-- the type component of the predicate before the class component. This way, +-- we ensure that a class method's implicit class constraint is always the +-- minimum w.r.t. this order, because the type expression for that constraint +-- is a type variable with index 0 and there are no other class constraints +-- in a predicate set that constraint the same type variable as restrictions +-- on class variables are not allowed (see predicate sets below for more +-- information why this order is relevant). instance Ord Pred where Pred qcls1 ty1 `compare` Pred qcls2 ty2 = case ty1 `compare` ty2 of diff --git a/src/Base/Typing.hs b/src/Base/Typing.hs --- a/src/Base/Typing.hs +++ b/src/Base/Typing.hs @@ -46,8 +46,8 @@ typeOf = unpredType instance Typeable a => Typeable (Rhs a) where - typeOf (SimpleRhs _ e _ ) = typeOf e - typeOf (GuardedRhs _ es _) = head [typeOf e | CondExpr _ _ e <- es] + typeOf (SimpleRhs _ _ e _ ) = typeOf e + typeOf (GuardedRhs _ _ es _) = head [typeOf e | CondExpr _ _ e <- es] instance Typeable a => Typeable (Pattern a) where typeOf (LiteralPattern _ a _) = typeOf a @@ -93,10 +93,10 @@ TypeArrow ty1 (TypeArrow _ ty2) -> TypeArrow ty1 ty2 _ -> internalError "Base.Typing.typeOf: right section" typeOf (Lambda _ ts e) = foldr (TypeArrow . typeOf) (typeOf e) ts - typeOf (Let _ _ e) = typeOf e - typeOf (Do _ _ e) = typeOf e + typeOf (Let _ _ _ e) = typeOf e + typeOf (Do _ _ _ e) = typeOf e typeOf (IfThenElse _ _ e _) = typeOf e - typeOf (Case _ _ _ as) = typeOf $ head as + typeOf (Case _ _ _ _ as) = typeOf $ head as instance Typeable a => Typeable (Alt a) where typeOf (Alt _ _ rhs) = typeOf rhs diff --git a/src/Checks.hs b/src/Checks.hs --- a/src/Checks.hs +++ b/src/Checks.hs @@ -69,10 +69,9 @@ -- * Environment: remains unchanged typeSyntaxCheck :: Monad m => Check m (Module a) typeSyntaxCheck _ (env, mdl) - | null msgs = ok (env { extensions = exts }, mdl') + | null msgs = ok (env, mdl') | otherwise = failMessages msgs - where ((mdl', exts), msgs) = TSC.typeSyntaxCheck (extensions env) - (tyConsEnv env) mdl + where (mdl', msgs) = TSC.typeSyntaxCheck (tyConsEnv env) mdl -- |Check the kinds of type definitions and signatures. -- @@ -103,8 +102,8 @@ -- precedences -- * Environment: The operator precedence environment is updated precCheck :: Monad m => Check m (Module a) -precCheck _ (env, Module spi ps m es is ds) - | null msgs = ok (env { opPrecEnv = pEnv' }, Module spi ps m es is ds') +precCheck _ (env, Module spi li ps m es is ds) + | null msgs = ok (env { opPrecEnv = pEnv' }, Module spi li ps m es is ds') | otherwise = failMessages msgs where (ds', pEnv', msgs) = PC.precCheck (moduleIdent env) (opPrecEnv env) ds @@ -122,8 +121,8 @@ -- * Declarations: remain unchanged -- * Environment: The instance environment is updated instanceCheck :: Monad m => Check m (Module a) -instanceCheck _ (env, Module spi ps m es is ds) - | null msgs = ok (env { instEnv = inEnv' }, Module spi ps m es is ds) +instanceCheck _ (env, Module spi li ps m es is ds) + | null msgs = ok (env { instEnv = inEnv' }, Module spi li ps m es is ds) | otherwise = failMessages msgs where (inEnv', msgs) = INC.instanceCheck (moduleIdent env) (tyConsEnv env) (classEnv env) (instEnv env) ds @@ -134,8 +133,8 @@ -- * Environment: The value environment is updated. typeCheck :: Monad m => Options -> CompEnv (Module a) -> CYT m (CompEnv (Module PredType)) -typeCheck _ (env, Module spi ps m es is ds) - | null msgs = ok (env { valueEnv = vEnv' }, Module spi ps m es is ds') +typeCheck _ (env, Module spi li ps m es is ds) + | null msgs = ok (env { valueEnv = vEnv' }, Module spi li ps m es is ds') | otherwise = failMessages msgs where (ds', vEnv', msgs) = TC.typeCheck (moduleIdent env) (tyConsEnv env) (valueEnv env) (classEnv env) @@ -143,7 +142,7 @@ -- |Check the export specification exportCheck :: Monad m => Check m (Module a) -exportCheck _ (env, mdl@(Module _ _ _ es _ _)) +exportCheck _ (env, mdl@(Module _ _ _ _ es _ _)) | null msgs = ok (env, mdl) | otherwise = failMessages msgs where msgs = EC.exportCheck (moduleIdent env) (aliasEnv env) @@ -151,8 +150,8 @@ -- |Check the export specification expandExports :: Monad m => Options -> CompEnv (Module a) -> m (CompEnv (Module a)) -expandExports _ (env, Module spi ps m es is ds) - = return (env, Module spi ps m (Just es') is ds) +expandExports _ (env, Module spi li ps m es is ds) + = return (env, Module spi li ps m (Just es') is ds) where es' = EC.expandExports (moduleIdent env) (aliasEnv env) (tyConsEnv env) (valueEnv env) es diff --git a/src/Checks/DeriveCheck.hs b/src/Checks/DeriveCheck.hs --- a/src/Checks/DeriveCheck.hs +++ b/src/Checks/DeriveCheck.hs @@ -15,16 +15,16 @@ module Checks.DeriveCheck (deriveCheck) where import Curry.Base.Ident -import Curry.Base.Position import Curry.Base.Pretty +import Curry.Base.SpanInfo (HasSpanInfo) import Curry.Syntax -import Base.Messages (Message, posMessage) +import Base.Messages (Message, spanInfoMessage) import Env.TypeConstructor deriveCheck :: TCEnv -> Module a -> [Message] -deriveCheck tcEnv (Module _ _ m _ _ ds) = concatMap (checkDecl m tcEnv) ds +deriveCheck tcEnv (Module _ _ _ m _ _ ds) = concatMap (checkDecl m tcEnv) ds -- No instances can be derived for abstract data types as well as for -- existential data types. @@ -42,18 +42,19 @@ checkDerivable m tcEnv cs cls | ocls == qEnumId && not (isEnum cs) = [errNotEnum cls] | ocls == qBoundedId && not (isBounded cs) = [errNotBounded cls] - | ocls `notElem` derivableClasses = [errNotDerivable ocls] + | ocls `notElem` derivableClasses = [errNotDerivable cls] + | ocls == qDataId = [errNoDataDerive cls] | otherwise = [] where ocls = getOrigName m cls tcEnv derivableClasses :: [QualIdent] -derivableClasses = [qEqId, qOrdId, qEnumId, qBoundedId, qReadId, qShowId] +derivableClasses = [qEqId, qOrdId, qEnumId, qBoundedId, qReadId, qShowId, qDataId] -- Instances of 'Enum' can be derived only for enumeration types, i.e., types -- where all data constructors are constants. isEnum :: [ConstrDecl] -> Bool -isEnum cs = all ((0 ==) . constrArity) cs +isEnum = all ((0 ==) . constrArity) -- Instances of 'Bounded' can be derived only for enumerations and for single -- constructor types. @@ -79,20 +80,32 @@ -- Error messages -- --------------------------------------------------------------------------- -errNoAbstractDerive :: HasPosition a => a -> Message -errNoAbstractDerive p = posMessage p $ +errNoAbstractDerive :: HasSpanInfo a => a -> Message +errNoAbstractDerive s = spanInfoMessage s $ text "Instances can only be derived for data types with" <+> text "at least one constructor" errNotDerivable :: QualIdent -> Message -errNotDerivable cls = posMessage cls $ hsep $ map text +errNotDerivable cls = spanInfoMessage cls $ hsep $ map text ["Instances of type class", escQualName cls, "cannot be derived"] -errNotEnum :: HasPosition a => a -> Message -errNotEnum p = posMessage p $ - text "Instances for Enum can be derived only for enumeration types" +errNoDataDerive :: QualIdent -> Message +errNoDataDerive qcls = spanInfoMessage qcls $ hsep $ map text + [ "Instances of type class" + , escQualName qcls + , "are automatically derived if possible" + ] -errNotBounded :: HasPosition a => a -> Message -errNotBounded p = posMessage p $ - text "Instances of Bounded can be derived only for enumeration" <+> - text "and single constructor types" +errNotEnum :: QualIdent -> Message +errNotEnum qcls = spanInfoMessage qcls $ hsep $ map text + [ "Instances of type class" + , escQualName qcls + , "can be derived only for enumeration types" + ] + +errNotBounded :: QualIdent -> Message +errNotBounded qcls = spanInfoMessage qcls $ hsep $ map text + [ "Instances of type class" + , escQualName qcls + , "can be derived only for enumeration and single constructor types" + ] diff --git a/src/Checks/ExportCheck.hs b/src/Checks/ExportCheck.hs --- a/src/Checks/ExportCheck.hs +++ b/src/Checks/ExportCheck.hs @@ -48,12 +48,12 @@ import Curry.Base.Pretty import Curry.Syntax -import Base.Messages (Message, internalError, posMessage) +import Base.Messages (Message, internalError, spanInfoMessage) import Base.TopEnv (allEntities, origName, localBindings, moduleImports) import Base.Types ( Type (..), unapplyType, arrowBase, PredType (..) , DataConstr (..), constrIdent, recLabels , ClassMethod, methodName - , TypeScheme (..) ) + , TypeScheme (..), rawType, rootOfType ) import Base.Utils (findMultiples) import Env.ModuleAlias (AliasEnv) @@ -325,26 +325,32 @@ tcEnv <- getTyConsEnv tyEnv <- getValueEnv return $ - [ exportType t | (_, t) <- localBindings tcEnv ] + [ exportType t + | (_, t) <- localBindings tcEnv ] + ++ [ exportLabel l' ty + | (l, Label l' _ ty) <- localBindings tyEnv, hasGlobalScope l ] ++ [ Export NoSpanInfo f' | (f, Value f' _ _ _) <- localBindings tyEnv, hasGlobalScope f ] - ++ [ Export NoSpanInfo l' - | (l, Label l' _ _) <- localBindings tyEnv, hasGlobalScope l ] -- |Expand a module export expandImportedModule :: ModuleIdent -> ECM [Export] expandImportedModule m = do tcEnv <- getTyConsEnv tyEnv <- getValueEnv - return $ [exportType t | (_, t) <- moduleImports m tcEnv] + return $ [exportType t | (_, t) <- moduleImports m tcEnv] + ++ [exportLabel l ty | (_, Label l _ ty) <- moduleImports m tyEnv] ++ [Export NoSpanInfo f | (_, Value f _ _ _) <- moduleImports m tyEnv] - ++ [Export NoSpanInfo l | (_, Label l _ _) <- moduleImports m tyEnv] exportType :: TypeInfo -> Export exportType t = ExportTypeWith NoSpanInfo tc xs where tc = origName t xs = elements t +exportLabel :: QualIdent -> TypeScheme -> Export +exportLabel qid ty = case rawType ty of + TypeArrow a _ -> ExportTypeWith NoSpanInfo (rootOfType a) [qidIdent qid] + _ -> internalError $ "ExportCheck.exportLabel: " ++ show (qid, ty) + -- ----------------------------------------------------------------------------- -- Canonicalization and joining of exports -- ----------------------------------------------------------------------------- @@ -435,13 +441,13 @@ errAmbiguousType tc tcs = errAmbiguous "type" tc (map origName tcs) errAmbiguous :: String -> QualIdent -> [QualIdent] -> Message -errAmbiguous what qn qns = posMessage qn +errAmbiguous what qn qns = spanInfoMessage qn $ text "Ambiguous" <+> text what <+> text (escQualName qn) $+$ text "It could refer to:" $+$ nest 2 (vcat (map (text . escQualName) qns)) errModuleNotImported :: ModuleIdent -> Message -errModuleNotImported m = posMessage m $ hsep $ map text +errModuleNotImported m = spanInfoMessage m $ hsep $ map text ["Module", escModuleName m, "not imported"] errMultipleName :: [Ident] -> Message @@ -453,13 +459,13 @@ errMultiple :: String -> [Ident] -> Message errMultiple _ [] = internalError $ currentModuleName ++ ".errMultiple: empty list" -errMultiple what (i:is) = posMessage i $ +errMultiple what (i:is) = spanInfoMessage i $ text "Multiple exports of" <+> text what <+> text (escName i) <+> text "at:" $+$ nest 2 (vcat (map showPos (i:is))) where showPos = text . showLine . getPosition errNonDataTypeOrTypeClass :: QualIdent -> Message -errNonDataTypeOrTypeClass tc = posMessage tc $ hsep $ map text +errNonDataTypeOrTypeClass tc = spanInfoMessage tc $ hsep $ map text [escQualName tc, "is not a data type or type class"] errOutsideTypeConstructor :: QualIdent -> QualIdent -> Message @@ -469,18 +475,18 @@ errOutsideTypeLabel l tc = errOutsideTypeExport "Label" l tc errOutsideTypeExport :: String -> QualIdent -> QualIdent -> Message -errOutsideTypeExport what q tc = posMessage q +errOutsideTypeExport what q tc = spanInfoMessage q $ text what <+> text (escQualName q) <+> text "outside type export in export list" $+$ text "Use `" <> text (qualName tc) <+> parens (text (qualName q)) <> text "' instead" errUndefinedElement :: QualIdent -> Ident -> Message -errUndefinedElement tc c = posMessage c $ hsep $ map text +errUndefinedElement tc c = spanInfoMessage c $ hsep $ map text [ escName c, "is not a constructor or label of type", escQualName tc ] errUndefinedMethod :: QualIdent -> Ident -> Message -errUndefinedMethod cls f = posMessage f $ hsep $ map text +errUndefinedMethod cls f = spanInfoMessage f $ hsep $ map text [ escName f, "is not a method of class", escQualName cls ] errUndefinedName :: QualIdent -> Message @@ -490,5 +496,5 @@ errUndefinedTypeOrClass = errUndefined "type or class" errUndefined :: String -> QualIdent -> Message -errUndefined what tc = posMessage tc $ hsep $ map text +errUndefined what tc = spanInfoMessage tc $ hsep $ map text ["Undefined", what, escQualName tc, "in export list"] diff --git a/src/Checks/ExtensionCheck.hs b/src/Checks/ExtensionCheck.hs --- a/src/Checks/ExtensionCheck.hs +++ b/src/Checks/ExtensionCheck.hs @@ -15,11 +15,11 @@ import qualified Control.Monad.State as S (State, execState, modify) -import Curry.Base.Position +import Curry.Base.SpanInfo import Curry.Base.Pretty import Curry.Syntax -import Base.Messages (Message, posMessage) +import Base.Messages (Message, spanInfoMessage) import CompilerOpts @@ -53,7 +53,7 @@ -- if an extension is unknown. checkModule :: Module a -> EXCM () -checkModule (Module _ ps _ _ _ _) = mapM_ checkPragma ps +checkModule (Module _ _ ps _ _ _ _) = mapM_ checkPragma ps checkPragma :: ModulePragma -> EXCM () checkPragma (LanguagePragma _ exts) = mapM_ checkExtension exts @@ -67,6 +67,6 @@ -- Error messages -- --------------------------------------------------------------------------- -errUnknownExtension :: Position -> String -> Message -errUnknownExtension p e = posMessage p $ +errUnknownExtension :: SpanInfo -> String -> Message +errUnknownExtension p e = spanInfoMessage p $ text "Unknown language extension:" <+> text e diff --git a/src/Checks/ImportSyntaxCheck.hs b/src/Checks/ImportSyntaxCheck.hs --- a/src/Checks/ImportSyntaxCheck.hs +++ b/src/Checks/ImportSyntaxCheck.hs @@ -259,21 +259,21 @@ -- error messages errUndefinedElement :: Ident -> Ident -> Message -errUndefinedElement tc c = posMessage c $ hsep $ map text +errUndefinedElement tc c = spanInfoMessage c $ hsep $ map text [ idName c, "is not a constructor or label of type ", idName tc ] errUndefinedMethod :: Ident -> Ident -> Message -errUndefinedMethod cls f = posMessage f $ hsep $ map text +errUndefinedMethod cls f = spanInfoMessage f $ hsep $ map text [ idName f, "is not a method of class", idName cls ] errUndefinedEntity :: ModuleIdent -> Ident -> Message -errUndefinedEntity m x = posMessage x $ hsep $ map text +errUndefinedEntity m x = spanInfoMessage x $ hsep $ map text [ "Module", moduleName m, "does not export", idName x ] errNonDataTypeOrTypeClass :: Ident -> Message -errNonDataTypeOrTypeClass tc = posMessage tc $ hsep $ map text +errNonDataTypeOrTypeClass tc = spanInfoMessage tc $ hsep $ map text [ idName tc, "is not a data type or type class" ] errImportDataConstr :: ModuleIdent -> Ident -> Message -errImportDataConstr _ c = posMessage c $ hsep $ map text +errImportDataConstr _ c = spanInfoMessage c $ hsep $ map text [ "Explicit import for data constructor", idName c ] diff --git a/src/Checks/InstanceCheck.hs b/src/Checks/InstanceCheck.hs --- a/src/Checks/InstanceCheck.hs +++ b/src/Checks/InstanceCheck.hs @@ -19,21 +19,20 @@ -} module Checks.InstanceCheck (instanceCheck) where -import Control.Monad.Extra (concatMapM, whileM) +import Control.Monad.Extra (concatMapM, whileM, unless) import qualified Control.Monad.State as S (State, execState, gets, modify) import Data.List (nub, partition, sortBy) import qualified Data.Map as Map import qualified Data.Set.Extra as Set import Curry.Base.Ident -import Curry.Base.Position import Curry.Base.Pretty import Curry.Base.SpanInfo import Curry.Syntax hiding (impls) import Curry.Syntax.Pretty import Base.CurryTypes -import Base.Messages (Message, posMessage, message, internalError) +import Base.Messages (Message, spanInfoMessage, message, internalError) import Base.SCC (scc) import Base.TypeExpansion import Base.Types @@ -52,7 +51,7 @@ iss -> (inEnv, map (errMultipleInstances tcEnv) iss) where local = map (flip InstSource m) $ concatMap (genInstIdents m tcEnv) ds - imported = map (uncurry InstSource) $ map (fmap fst3) $ Map.toList inEnv + imported = map (uncurry InstSource . fmap fst3) $ Map.toList inEnv state = INCState m inEnv [] -- In order to provide better error messages, we use the following data type @@ -95,6 +94,8 @@ checkDecls :: TCEnv -> ClassEnv -> [Decl a] -> INCM () checkDecls tcEnv clsEnv ds = do mapM_ (bindInstance tcEnv clsEnv) ids + mapM (declDeriveDataInfo tcEnv clsEnv) (filter isDataDecl tds) >>= + mapM_ (bindDerivedInstances clsEnv) . groupDeriveInfos mapM (declDeriveInfo tcEnv clsEnv) (filter hasDerivedInstances tds) >>= mapM_ (bindDerivedInstances clsEnv) . groupDeriveInfos mapM_ (checkInstance tcEnv clsEnv) ids @@ -102,12 +103,15 @@ where (tds, ods) = partition isTypeDecl ds ids = filter isInstanceDecl ods dds = filter isDefaultDecl ods + isDataDecl (DataDecl _ _ _ _ _) = True + isDataDecl (NewtypeDecl _ _ _ _ _) = True + isDataDecl _ = False -- First, the compiler adds all explicit instance declarations to the -- instance environment. bindInstance :: TCEnv -> ClassEnv -> Decl a -> INCM () -bindInstance tcEnv clsEnv (InstanceDecl _ cx qcls inst ds) = do +bindInstance tcEnv clsEnv (InstanceDecl _ _ cx qcls inst ds) = do m <- getModuleIdent let PredType ps _ = expandPolyType m tcEnv clsEnv $ QualTypeExpr NoSpanInfo cx inst @@ -136,7 +140,7 @@ -- derived classes with respect to the super class hierarchy so that subclass -- instances are added to the instance environment after their super classes. -data DeriveInfo = DeriveInfo Position QualIdent PredType [Type] [QualIdent] +data DeriveInfo = DeriveInfo SpanInfo QualIdent PredType [Type] [QualIdent] declDeriveInfo :: TCEnv -> ClassEnv -> Decl a -> INCM DeriveInfo declDeriveInfo tcEnv clsEnv (DataDecl p tc tvs cs clss) = @@ -151,45 +155,70 @@ declDeriveInfo _ _ _ = internalError "InstanceCheck.declDeriveInfo: no data or newtype declaration" -mkDeriveInfo :: TCEnv -> ClassEnv -> SpanInfo -> Ident -> [Ident] -> [TypeExpr] - -> [QualIdent] -> INCM DeriveInfo +declDeriveDataInfo :: TCEnv -> ClassEnv -> Decl a -> INCM DeriveInfo +declDeriveDataInfo tcEnv clsEnv (DataDecl p tc tvs cs _) = + mkDeriveDataInfo tcEnv clsEnv p tc tvs (concat tyss) + where tyss = map constrDeclTypes cs + constrDeclTypes (ConstrDecl _ _ tys) = tys + constrDeclTypes (ConOpDecl _ ty1 _ ty2) = [ty1, ty2] + constrDeclTypes (RecordDecl _ _ fs) = tys + where tys = [ty | FieldDecl _ ls ty <- fs, _ <- ls] +declDeriveDataInfo tcEnv clsEnv (NewtypeDecl p tc tvs nc _) = + mkDeriveDataInfo tcEnv clsEnv p tc tvs [nconstrType nc] +declDeriveDataInfo _ _ _ = internalError + "InstanceCheck.declDeriveDataInfo: no data or newtype declaration" + +mkDeriveInfo :: TCEnv -> ClassEnv -> SpanInfo -> Ident -> [Ident] + -> [TypeExpr] -> [QualIdent] -> INCM DeriveInfo mkDeriveInfo tcEnv clsEnv spi tc tvs tys clss = do m <- getModuleIdent let otc = qualifyWith m tc oclss = map (flip (getOrigName m) tcEnv) clss PredType ps ty = expandConstrType m tcEnv clsEnv otc tvs tys (tys', ty') = arrowUnapply ty - return $ DeriveInfo p otc (PredType ps ty') tys' $ sortClasses clsEnv oclss - where p = spanInfo2Pos spi + return $ DeriveInfo spi otc (PredType ps ty') tys' $ sortClasses clsEnv oclss +mkDeriveDataInfo :: TCEnv -> ClassEnv -> SpanInfo -> Ident -> [Ident] + -> [TypeExpr] -> INCM DeriveInfo +mkDeriveDataInfo tcEnv clsEnv spi tc tvs tys = do + m <- getModuleIdent + let otc = qualifyWith m tc + PredType ps ty = expandConstrType m tcEnv clsEnv otc tvs tys + (tys', ty') = arrowUnapply ty + return $ DeriveInfo spi otc (PredType ps ty') tys' [qDataId] + sortClasses :: ClassEnv -> [QualIdent] -> [QualIdent] sortClasses clsEnv clss = map fst $ sortBy compareDepth $ map adjoinDepth clss where (_, d1) `compareDepth` (_, d2) = d1 `compare` d2 adjoinDepth cls = (cls, length $ allSuperClasses cls clsEnv) groupDeriveInfos :: [DeriveInfo] -> [[DeriveInfo]] -groupDeriveInfos ds = scc bound free ds +groupDeriveInfos = scc bound free where bound (DeriveInfo _ tc _ _ _) = [tc] free (DeriveInfo _ _ _ tys _) = concatMap typeConstrs tys bindDerivedInstances :: ClassEnv -> [DeriveInfo] -> INCM () -bindDerivedInstances clsEnv dis = do +bindDerivedInstances clsEnv dis = unless (any hasDataFunType dis) $ do mapM_ (enterInitialPredSet clsEnv) dis whileM $ concatMapM (inferPredSets clsEnv) dis >>= updatePredSets + where + hasDataFunType (DeriveInfo _ _ _ tys clss) = + clss == [qDataId] && any isFunType tys enterInitialPredSet :: ClassEnv -> DeriveInfo -> INCM () -enterInitialPredSet clsEnv (DeriveInfo p tc pty _ clss) = - mapM_ (bindDerivedInstance clsEnv p tc pty []) clss +enterInitialPredSet clsEnv (DeriveInfo spi tc pty _ clss) = + mapM_ (bindDerivedInstance clsEnv spi tc pty) clss -- Note: The methods and arities entered into the instance environment have -- to match methods and arities of the later generated instance declarations. +-- TODO: Add remark about value environment entry -bindDerivedInstance :: ClassEnv -> Position -> QualIdent -> PredType -> [Type] - -> QualIdent -> INCM () -bindDerivedInstance clsEnv p tc pty tys cls = do +bindDerivedInstance :: HasSpanInfo s => ClassEnv -> s -> QualIdent -> PredType -> QualIdent + -> INCM () +bindDerivedInstance clsEnv p tc pty cls = do m <- getModuleIdent - (i, ps) <- inferPredSet clsEnv p tc pty tys cls - modifyInstEnv $ bindInstInfo i (m, ps, impls) + ((i, ps), _) <- inferPredSet clsEnv p tc pty [] cls + modifyInstEnv (bindInstInfo i (m, ps, impls)) where impls | cls == qEqId = [(eqOpId, 2)] | cls == qOrdId = [(leqOpId, 2)] | cls == qEnumId = [ (succId, 1), (predId, 1), (toEnumId, 1) @@ -199,15 +228,16 @@ | cls == qBoundedId = [(maxBoundId, 0), (minBoundId, 0)] | cls == qReadId = [(readsPrecId, 2)] | cls == qShowId = [(showsPrecId, 2)] + | cls == qDataId = [(dataEqId, 2), (aValueId, 0)] | otherwise = internalError "InstanceCheck.bindDerivedInstance.impls" -inferPredSets :: ClassEnv -> DeriveInfo -> INCM [(InstIdent, PredSet)] -inferPredSets clsEnv (DeriveInfo p tc pty tys clss) = - mapM (inferPredSet clsEnv p tc pty tys) clss +inferPredSets :: ClassEnv -> DeriveInfo -> INCM [((InstIdent, PredSet), Bool)] +inferPredSets clsEnv (DeriveInfo spi tc pty tys clss) = + mapM (inferPredSet clsEnv spi tc pty tys) clss -inferPredSet :: ClassEnv -> Position -> QualIdent -> PredType -> [Type] - -> QualIdent -> INCM (InstIdent, PredSet) +inferPredSet :: HasSpanInfo s => ClassEnv -> s -> QualIdent -> PredType -> [Type] + -> QualIdent -> INCM ((InstIdent, PredSet), Bool) inferPredSet clsEnv p tc (PredType ps inst) tys cls = do m <- getModuleIdent let doc = ppPred m $ Pred cls inst @@ -215,25 +245,34 @@ ps' = Set.fromList [Pred cls ty | ty <- tys] ps'' = Set.fromList [Pred scls inst | scls <- sclss] ps''' = ps `Set.union` ps' `Set.union` ps'' - ps'''' <- reducePredSet p "derived instance" doc clsEnv ps''' - mapM_ (reportUndecidable p "derived instance" doc) $ Set.toList ps'''' - return ((cls, tc), ps'''') + (ps4, novarps) <- + reducePredSet (cls == qDataId) p "derived instance" doc clsEnv ps''' + let ps5 = filter noPolyPred $ Set.toList ps4 + if any (isDataPred m) (Set.toList novarps ++ ps5) && cls == qDataId + then return (((cls, tc), ps4), False) + else mapM_ (reportUndecidable p "derived instance" doc) ps5 + >> return (((cls, tc), ps4), True) + where + noPolyPred (Pred _ (TypeVariable _)) = False + noPolyPred (Pred _ _ ) = True + isDataPred _ (Pred qid _) = qid == qDataId -updatePredSets :: [(InstIdent, PredSet)] -> INCM Bool -updatePredSets = (=<<) (return . or) . mapM (uncurry updatePredSet) +updatePredSets :: [((InstIdent, PredSet), Bool)] -> INCM Bool +updatePredSets = fmap or . mapM (uncurry updatePredSet) -updatePredSet :: InstIdent -> PredSet -> INCM Bool -updatePredSet i ps = do +updatePredSet :: (InstIdent, PredSet) -> Bool -> INCM Bool +updatePredSet (i, ps) enter = do inEnv <- getInstEnv case lookupInstInfo i inEnv of Just (m, ps', is) + | not enter -> modifyInstEnv (removeInstInfo i) >> return False | ps == ps' -> return False | otherwise -> do modifyInstEnv $ bindInstInfo i (m, ps, is) return True Nothing -> internalError "InstanceCheck.updatePredSet" -reportUndecidable :: Position -> String -> Doc -> Pred -> INCM () +reportUndecidable :: HasSpanInfo s => s -> String -> Doc -> Pred -> INCM () reportUndecidable p what doc predicate@(Pred _ ty) = do m <- getModuleIdent case ty of @@ -251,7 +290,7 @@ -- satisfied by cx. checkInstance :: TCEnv -> ClassEnv -> Decl a -> INCM () -checkInstance tcEnv clsEnv (InstanceDecl spi cx cls inst _) = do +checkInstance tcEnv clsEnv (InstanceDecl _ _ cx cls inst _) = do m <- getModuleIdent let PredType ps ty = expandPolyType m tcEnv clsEnv $ QualTypeExpr NoSpanInfo cx inst @@ -259,10 +298,9 @@ ps' = Set.fromList [ Pred scls ty | scls <- superClasses ocls clsEnv ] doc = ppPred m $ Pred cls ty what = "instance declaration" - ps'' <- reducePredSet p what doc clsEnv ps' - Set.mapM_ (report . errMissingInstance m p what doc) $ - ps'' `Set.difference` (maxPredSet clsEnv ps) - where p = spanInfo2Pos spi + (ps'', _) <- reducePredSet False inst what doc clsEnv ps' + Set.mapM_ (report . errMissingInstance m inst what doc) $ + ps'' `Set.difference` maxPredSet clsEnv ps checkInstance _ _ _ = ok -- All types specified in the optional default declaration of a module @@ -271,17 +309,18 @@ -- must be empty. checkDefault :: TCEnv -> ClassEnv -> Decl a -> INCM () -checkDefault tcEnv clsEnv (DefaultDecl p tys) = - mapM_ (checkDefaultType (spanInfo2Pos p) tcEnv clsEnv) tys +checkDefault tcEnv clsEnv (DefaultDecl _ tys) = + mapM_ (checkDefaultType tcEnv clsEnv) tys checkDefault _ _ _ = ok -checkDefaultType :: Position -> TCEnv -> ClassEnv -> TypeExpr -> INCM () -checkDefaultType p tcEnv clsEnv ty = do +checkDefaultType :: TCEnv -> ClassEnv -> TypeExpr -> INCM () +checkDefaultType tcEnv clsEnv ty = do m <- getModuleIdent let PredType _ ty' = expandPolyType m tcEnv clsEnv $ QualTypeExpr NoSpanInfo [] ty - ps <- reducePredSet p what empty clsEnv (Set.singleton $ Pred qNumId ty') - Set.mapM_ (report . errMissingInstance m p what empty) ps + (ps, _) <- reducePredSet False ty what empty clsEnv + (Set.singleton $ Pred qNumId ty') + Set.mapM_ (report . errMissingInstance m ty what empty) ps where what = "default declaration" -- The function 'reducePredSet' simplifies a predicate set of the form @@ -290,16 +329,20 @@ -- a type variable. An error is reported if the predicate set cannot -- be transformed into this form. In addition, we remove all predicates -- that are implied by others within the same set. +-- When the flag is set, all missing Data preds are ignored -reducePredSet :: Position -> String -> Doc -> ClassEnv -> PredSet - -> INCM PredSet -reducePredSet p what doc clsEnv ps = do +reducePredSet :: HasSpanInfo s => Bool -> s -> String -> Doc -> ClassEnv -> PredSet + -> INCM (PredSet, PredSet) +reducePredSet b p what doc clsEnv ps = do m <- getModuleIdent inEnv <- getInstEnv let (ps1, ps2) = partitionPredSet $ minPredSet clsEnv $ reducePreds inEnv ps - Set.mapM_ (report . errMissingInstance m p what doc) ps2 - return ps1 + ps2' = if b then Set.filter (isNotDataPred m) ps2 else ps2 + Set.mapM_ (reportMissing m) ps2' >> return (ps1, ps2) where + isNotDataPred _ (Pred qid _) = qid /= qDataId + reportMissing m pr@(Pred _ _) = + report $ errMissingInstance m p what doc pr reducePreds inEnv = Set.concatMap $ reducePred inEnv reducePred inEnv predicate = maybe (Set.singleton predicate) (reducePreds inEnv) @@ -323,7 +366,7 @@ genInstIdents m tcEnv (NewtypeDecl _ tc _ _ qclss) = map (flip (genInstIdent m tcEnv) $ ConstructorType NoSpanInfo $ qualify tc) qclss -genInstIdents m tcEnv (InstanceDecl _ _ qcls ty _) = +genInstIdents m tcEnv (InstanceDecl _ _ _ qcls ty _) = [genInstIdent m tcEnv qcls ty] genInstIdents _ _ _ = [] @@ -344,6 +387,13 @@ where unqual = head . flip reverseLookupByOrigName tcEnv +isFunType :: Type -> Bool +isFunType (TypeArrow _ _) = True +isFunType (TypeApply t1 t2) = isFunType t1 || isFunType t2 +isFunType (TypeForall _ ty) = isFunType ty +isFunType (TypeConstrained tys _) = any isFunType tys +isFunType _ = False + -- --------------------------------------------------------------------------- -- Error messages -- --------------------------------------------------------------------------- @@ -356,9 +406,9 @@ ppInstSource (InstSource i m) = ppInstIdent (unqualInstIdent tcEnv i) <+> parens (text "defined in" <+> ppMIdent m) -errMissingInstance :: ModuleIdent -> Position -> String -> Doc -> Pred +errMissingInstance :: HasSpanInfo s => ModuleIdent -> s -> String -> Doc -> Pred -> Message -errMissingInstance m p what doc predicate = posMessage p $ vcat +errMissingInstance m p what doc predicate = spanInfoMessage (getSpanInfo p) $ vcat [ text "Missing instance for" <+> ppPred m predicate , text "in" <+> text what <+> doc ] diff --git a/src/Checks/InterfaceCheck.hs b/src/Checks/InterfaceCheck.hs --- a/src/Checks/InterfaceCheck.hs +++ b/src/Checks/InterfaceCheck.hs @@ -51,17 +51,16 @@ import Control.Monad (unless) import qualified Control.Monad.State as S import Data.List (sort) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust, isNothing) import Curry.Base.Ident -import Curry.Base.Position import Curry.Base.SpanInfo import Curry.Base.Pretty import Curry.Syntax import Base.CurryKinds (toKind') import Base.CurryTypes -import Base.Messages (Message, posMessage, internalError) +import Base.Messages (Message, spanInfoMessage, internalError) import Base.TopEnv import Base.Types @@ -110,22 +109,23 @@ interfaceCheck :: OpPrecEnv -> TCEnv -> ClassEnv -> InstEnv -> ValueEnv -> Interface -> [Message] -interfaceCheck pEnv tcEnv clsEnv inEnv tyEnv (Interface m _ ds) = reverse (errors s) +interfaceCheck pEnv tcEnv clsEnv inEnv tyEnv (Interface m _ ds) = + reverse (errors s) where s = S.execState (mapM_ checkImport ds) initState initState = ICState m pEnv tcEnv clsEnv inEnv tyEnv [] checkImport :: IDecl -> IC () -checkImport (IInfixDecl p fix pr op) = checkPrecInfo check p op +checkImport (IInfixDecl _ fix pr op) = checkPrecInfo check op op where check (PrecInfo op' (OpPrec fix' pr')) = op == op' && fix == fix' && pr == pr' -checkImport (HidingDataDecl p tc k tvs) = - checkTypeInfo "hidden data type" check p tc +checkImport (HidingDataDecl _ tc k tvs) = + checkTypeInfo "hidden data type" check tc tc where check (DataType tc' k' _) | tc == tc' && toKind' k (length tvs) == k' = Just ok check (RenamingType tc' k' _) | tc == tc' && toKind' k (length tvs) == k' = Just ok check _ = Nothing -checkImport (IDataDecl p tc k tvs cs _) = checkTypeInfo "data type" check p tc +checkImport (IDataDecl _ tc k tvs cs _) = checkTypeInfo "data type" check tc tc where check (DataType tc' k' cs') | tc == tc' && toKind' k (length tvs) == k' && (null cs || map constrId cs == map constrIdent cs') @@ -134,41 +134,43 @@ | tc == tc' && toKind' k (length tvs) == k' && null cs = Just ok check _ = Nothing -checkImport (INewtypeDecl p tc k tvs nc _) = checkTypeInfo "newtype" check p tc +checkImport (INewtypeDecl _ tc k tvs nc _) = checkTypeInfo "newtype" check tc tc where check (RenamingType tc' k' nc') | tc == tc' && toKind' k (length tvs) == k' && nconstrId nc == constrIdent nc' = Just (checkNewConstrImport tc tvs nc) check _ = Nothing -checkImport (ITypeDecl p tc k tvs ty) = do +checkImport (ITypeDecl _ tc k tvs ty) = do m <- getModuleIdent let check (AliasType tc' k' n' ty') | tc == tc' && toKind' k (length tvs) == k' && length tvs == n' && toQualType m tvs ty == ty' = Just ok check _ = Nothing - checkTypeInfo "synonym type" check p tc -checkImport (IFunctionDecl p f (Just tv) n ty) = do + checkTypeInfo "synonym type" check tc tc +checkImport (IFunctionDecl _ f (Just tv) n ty) = do m <- getModuleIdent let check (Value f' cm' n' (ForAll _ ty')) = - f == f' && cm' && n' == n && toQualPredType m [tv] ty == ty' + f == f' && isJust cm' && n' == n && + toQualPredType m [tv] ty == ty' check _ = False - checkValueInfo "method" check p f -checkImport (IFunctionDecl p f Nothing n ty) = do + checkValueInfo "method" check f f +checkImport (IFunctionDecl _ f Nothing n ty) = do m <- getModuleIdent let check (Value f' cm' n' (ForAll _ ty')) = - f == f' && not cm' && n' == n && toQualPredType m [] ty == ty' + f == f' && isNothing cm' && n' == n && + toQualPredType m [] ty == ty' check _ = False - checkValueInfo "function" check p f -checkImport (HidingClassDecl p cx cls k _) = do + checkValueInfo "function" check f f +checkImport (HidingClassDecl _ cx cls k _) = do clsEnv <- getClassEnv let check (TypeClass cls' k' _) | cls == cls' && toKind' k 0 == k' && [cls'' | Constraint _ cls'' _ <- cx] == superClasses cls' clsEnv = Just ok check _ = Nothing - checkTypeInfo "hidden type class" check p cls -checkImport (IClassDecl p cx cls k clsvar ms _) = do + checkTypeInfo "hidden type class" check cls cls +checkImport (IClassDecl _ cx cls k clsvar ms _) = do clsEnv <- getClassEnv let check (TypeClass cls' k' fs) | cls == cls' && toKind' k 0 == k' && @@ -177,30 +179,30 @@ map (\f -> (methodName f, methodArity f)) fs = Just $ mapM_ (checkMethodImport cls clsvar) ms check _ = Nothing - checkTypeInfo "type class" check p cls -checkImport (IInstanceDecl p cx cls ty is m) = - checkInstInfo check p (cls, typeConstr ty) m + checkTypeInfo "type class" check cls cls +checkImport (IInstanceDecl _ cx cls ty is m) = + checkInstInfo check cls (cls, typeConstr ty) m where PredType ps _ = toPredType [] $ QualTypeExpr NoSpanInfo cx ty check ps' is' = ps == ps' && sort is == sort is' checkConstrImport :: QualIdent -> [Ident] -> ConstrDecl -> IC () -checkConstrImport tc tvs (ConstrDecl p c tys) = do +checkConstrImport tc tvs (ConstrDecl _ c tys) = do m <- getModuleIdent let qc = qualifyLike tc c check (DataConstructor c' _ _ (ForAll uqvs pty)) = qc == c' && length tvs == uqvs && qualifyPredType m (toConstrType tc tvs tys) == pty check _ = False - checkValueInfo "data constructor" check p qc -checkConstrImport tc tvs (ConOpDecl p ty1 op ty2) = do + checkValueInfo "data constructor" check c qc +checkConstrImport tc tvs (ConOpDecl _ ty1 op ty2) = do m <- getModuleIdent let qc = qualifyLike tc op check (DataConstructor c' _ _ (ForAll uqvs pty)) = qc == c' && length tvs == uqvs && qualifyPredType m (toConstrType tc tvs [ty1, ty2]) == pty check _ = False - checkValueInfo "data constructor" check p qc -checkConstrImport tc tvs (RecordDecl p c fs) = do + checkValueInfo "data constructor" check op qc +checkConstrImport tc tvs (RecordDecl _ c fs) = do m <- getModuleIdent let qc = qualifyLike tc c (ls, tys) = unzip [(l, ty) | FieldDecl _ labels ty <- fs, l <- labels] @@ -208,34 +210,35 @@ qc == c' && length tvs == uqvs && ls == ls' && qualifyPredType m (toConstrType tc tvs tys) == pty check _ = False - checkValueInfo "data constructor" check p qc + checkValueInfo "data constructor" check c qc checkNewConstrImport :: QualIdent -> [Ident] -> NewConstrDecl -> IC () -checkNewConstrImport tc tvs (NewConstrDecl p c ty) = do +checkNewConstrImport tc tvs (NewConstrDecl _ c ty) = do m <- getModuleIdent let qc = qualifyLike tc c check (NewtypeConstructor c' _ (ForAll uqvs (PredType _ ty'))) = - qc == c' && length tvs == uqvs &&toQualType m tvs ty == head (arrowArgs ty') + qc == c' && length tvs == uqvs && toQualType m tvs ty == head (arrowArgs ty') check _ = False - checkValueInfo "newtype constructor" check p qc -checkNewConstrImport tc tvs (NewRecordDecl p c (l, ty)) = do + checkValueInfo "newtype constructor" check c qc +checkNewConstrImport tc tvs (NewRecordDecl _ c (l, ty)) = do m <- getModuleIdent let qc = qualifyLike tc c check (NewtypeConstructor c' l' (ForAll uqvs (PredType _ ty'))) = qc == c' && length tvs == uqvs && l == l' && toQualType m tvs ty == head (arrowArgs ty') check _ = False - checkValueInfo "newtype constructor" check p qc + checkValueInfo "newtype constructor" check c qc checkMethodImport :: QualIdent -> Ident -> IMethodDecl -> IC () -checkMethodImport qcls clsvar (IMethodDecl p f _ qty) = - checkValueInfo "method" check p qf +checkMethodImport qcls clsvar (IMethodDecl _ f _ qty) = + checkValueInfo "method" check f qf where qf = qualifyLike qcls f check (Value f' cm' _ (ForAll _ pty)) = - qf == f' && cm' && toMethodType qcls clsvar qty == pty + qf == f' && isJust cm' && + toMethodType qcls clsvar qty == pty check _ = False -checkPrecInfo :: (PrecInfo -> Bool) -> Position -> QualIdent -> IC () +checkPrecInfo :: HasSpanInfo s => (PrecInfo -> Bool) -> s -> QualIdent -> IC () checkPrecInfo check p op = do pEnv <- getPrecEnv let checkInfo m op' = case qualLookupTopEnv op pEnv of @@ -245,7 +248,7 @@ _ -> internalError "checkPrecInfo" checkImported checkInfo op -checkTypeInfo :: String -> (TypeInfo -> Maybe (IC ())) -> Position +checkTypeInfo :: HasSpanInfo s => String -> (TypeInfo -> Maybe (IC ())) -> s -> QualIdent -> IC () checkTypeInfo what check p tc = do tcEnv <- getTyConsEnv @@ -255,7 +258,7 @@ _ -> internalError "checkTypeInfo" checkImported checkInfo tc -checkInstInfo :: (PredSet -> [(Ident, Int)] -> Bool) -> Position -> InstIdent +checkInstInfo :: HasSpanInfo s => (PredSet -> [(Ident, Int)] -> Bool) -> s -> InstIdent -> Maybe ModuleIdent -> IC () checkInstInfo check p i mm = do inEnv <- getInstEnv @@ -267,7 +270,7 @@ Nothing -> report $ errNoInstance p m i checkImported checkInfo (maybe qualify qualifyWith mm anonId) -checkValueInfo :: HasPosition a => String -> (ValueInfo -> Bool) -> a +checkValueInfo :: HasSpanInfo a => String -> (ValueInfo -> Bool) -> a -> QualIdent -> IC () checkValueInfo what check p x = do tyEnv <- getValueEnv @@ -277,7 +280,7 @@ (report $ errImportConflict p' what m x') _ -> internalError "checkValueInfo" checkImported checkInfo x - where p' = getPosition p + where p' = getSpanInfo p checkImported :: (ModuleIdent -> Ident -> IC ()) -> QualIdent -> IC () checkImported _ (QualIdent _ Nothing _) = ok @@ -287,32 +290,32 @@ -- Error messages -- --------------------------------------------------------------------------- -errNotExported :: Position -> String -> ModuleIdent -> Ident -> Message -errNotExported p what m x = posMessage p $ +errNotExported :: HasSpanInfo s => s -> String -> ModuleIdent -> Ident -> Message +errNotExported p what m x = spanInfoMessage p $ text "Inconsistent module interfaces" $+$ text "Module" <+> text (moduleName m) <+> text "does not export"<+> text what <+> text (escName x) -errNoPrecedence :: Position -> ModuleIdent -> Ident -> Message -errNoPrecedence p m x = posMessage p $ +errNoPrecedence :: HasSpanInfo s => s -> ModuleIdent -> Ident -> Message +errNoPrecedence p m x = spanInfoMessage p $ text "Inconsistent module interfaces" $+$ text "Module" <+> text (moduleName m) <+> text "does not define a precedence for" <+> text (escName x) -errNoInstance :: Position -> ModuleIdent -> InstIdent -> Message -errNoInstance p m i = posMessage p $ +errNoInstance :: HasSpanInfo s => s -> ModuleIdent -> InstIdent -> Message +errNoInstance p m i = spanInfoMessage p $ text "Inconsistent module interfaces" $+$ text "Module" <+> text (moduleName m) <+> text "does not define an instance for" <+> ppInstIdent i -errImportConflict :: Position -> String -> ModuleIdent -> Ident -> Message -errImportConflict p what m x = posMessage p $ +errImportConflict :: HasSpanInfo s => s -> String -> ModuleIdent -> Ident -> Message +errImportConflict p what m x = spanInfoMessage p $ text "Inconsistent module interfaces" $+$ text "Declaration of" <+> text what <+> text (escName x) <+> text "does not match its definition in module" <+> text (moduleName m) -errInstanceConflict :: Position -> ModuleIdent -> InstIdent -> Message -errInstanceConflict p m i = posMessage p $ +errInstanceConflict :: HasSpanInfo s => s -> ModuleIdent -> InstIdent -> Message +errInstanceConflict p m i = spanInfoMessage p $ text "Inconsistent module interfaces" $+$ text "Declaration of instance" <+> ppInstIdent i <+> text "does not match its definition in module" <+> text (moduleName m) diff --git a/src/Checks/InterfaceSyntaxCheck.hs b/src/Checks/InterfaceSyntaxCheck.hs --- a/src/Checks/InterfaceSyntaxCheck.hs +++ b/src/Checks/InterfaceSyntaxCheck.hs @@ -29,7 +29,7 @@ import Data.Maybe (isNothing) import Base.Expr -import Base.Messages (Message, posMessage, internalError) +import Base.Messages (Message, spanInfoMessage, internalError) import Base.TopEnv import Base.Utils (findMultiples, findDouble) @@ -37,11 +37,9 @@ import Env.Type import Curry.Base.Ident -import Curry.Base.Position import Curry.Base.SpanInfo import Curry.Base.Pretty import Curry.Syntax -import Curry.Syntax.Pretty data ISCState = ISCState { typeEnv :: TypeEnv @@ -124,7 +122,7 @@ checkClass qcls QualTypeExpr _ cx' inst' <- checkQualType $ QualTypeExpr NoSpanInfo cx inst checkSimpleContext cx' - checkInstanceType p inst' + checkInstanceType inst' mapM_ (report . errMultipleImplementation . head) $ findMultiples $ map fst is return $ IInstanceDecl p cx' qcls inst' is m @@ -178,19 +176,19 @@ checkIMethodDecl :: Ident -> IMethodDecl -> ISC IMethodDecl checkIMethodDecl tv (IMethodDecl p f a qty) = do qty' <- checkQualType qty - unless (tv `elem` fv qty') $ report $ errAmbiguousType p tv + unless (tv `elem` fv qty') $ report $ errAmbiguousType f tv let QualTypeExpr _ cx _ = qty' - when (tv `elem` fv cx) $ report $ errConstrainedClassVariable p tv + when (tv `elem` fv cx) $ report $ errConstrainedClassVariable f tv return $ IMethodDecl p f a qty' -checkInstanceType :: Position -> InstanceType -> ISC () -checkInstanceType p inst = do +checkInstanceType :: InstanceType -> ISC () +checkInstanceType inst = do tEnv <- getTypeEnv unless (isSimpleType inst && not (isTypeSyn (typeConstr inst) tEnv) && null (filter isAnonId $ typeVars inst) && isNothing (findDouble $ fv inst)) $ - report $ errIllegalInstanceType p inst + report $ errIllegalInstanceType inst inst checkQualType :: QualTypeExpr -> ISC QualTypeExpr checkQualType (QualTypeExpr spi cx ty) = do @@ -291,7 +289,7 @@ -- --------------------------------------------------------------------------- errUndefined :: String -> QualIdent -> Message -errUndefined what qident = posMessage qident $ hsep $ map text +errUndefined what qident = spanInfoMessage qident $ hsep $ map text ["Undefined", what, qualName qident] errUndefinedClass :: QualIdent -> Message @@ -301,47 +299,47 @@ errUndefinedType = errUndefined "type" errMultipleImplementation :: Ident -> Message -errMultipleImplementation f = posMessage f $ hsep $ map text +errMultipleImplementation f = spanInfoMessage f $ hsep $ map text ["Arity information for method", idName f, "occurs more than once"] -errAmbiguousType :: Position -> Ident -> Message -errAmbiguousType p ident = posMessage p $ hsep $ map text +errAmbiguousType :: HasSpanInfo s => s -> Ident -> Message +errAmbiguousType p ident = spanInfoMessage p $ hsep $ map text [ "Method type does not mention class variable", idName ident ] -errConstrainedClassVariable :: Position -> Ident -> Message -errConstrainedClassVariable p ident = posMessage p $ hsep $ map text +errConstrainedClassVariable :: HasSpanInfo s => s -> Ident -> Message +errConstrainedClassVariable p ident = spanInfoMessage p $ hsep $ map text [ "Method context must not constrain class variable", idName ident ] errNonLinear :: Ident -> String -> Message -errNonLinear tv what = posMessage tv $ hsep $ map text +errNonLinear tv what = spanInfoMessage tv $ hsep $ map text [ "Type variable", escName tv, "occurs more than once in", what ] errNoVariable :: Ident -> String -> Message -errNoVariable tv what = posMessage tv $ hsep $ map text +errNoVariable tv what = spanInfoMessage tv $ hsep $ map text [ "Type constructor or type class identifier", escName tv, "used in", what ] errUnboundVariable :: Ident -> Message -errUnboundVariable tv = posMessage tv $ +errUnboundVariable tv = spanInfoMessage tv $ text "Undefined type variable" <+> text (escName tv) errBadTypeSynonym :: QualIdent -> Message -errBadTypeSynonym tc = posMessage tc $ text "Synonym type" +errBadTypeSynonym tc = spanInfoMessage tc $ text "Synonym type" <+> text (qualName tc) <+> text "in interface" errNoElement :: String -> String -> QualIdent -> Ident -> Message -errNoElement what for tc x = posMessage tc $ hsep $ map text +errNoElement what for tc x = spanInfoMessage x $ hsep $ map text [ "Hidden", what, escName x, "is not defined for", for, qualName tc ] errIllegalSimpleConstraint :: Constraint -> Message -errIllegalSimpleConstraint c@(Constraint _ qcls _) = posMessage qcls $ vcat - [ text "Illegal class constraint" <+> ppConstraint c +errIllegalSimpleConstraint c@(Constraint _ qcls _) = spanInfoMessage qcls $ vcat + [ text "Illegal class constraint" <+> pPrint c , text "Constraints in class and instance declarations must be of" , text "the form C u, where C is a type class and u is a type variable." ] -errIllegalInstanceType :: Position -> InstanceType -> Message -errIllegalInstanceType p inst = posMessage p $ vcat - [ text "Illegal instance type" <+> ppInstanceType inst +errIllegalInstanceType :: HasSpanInfo s => s -> InstanceType -> Message +errIllegalInstanceType p inst = spanInfoMessage p $ vcat + [ text "Illegal instance type" <+> pPrint inst , text "The instance type must be of the form (T u_1 ... u_n)," , text "where T is not a type synonym and u_1, ..., u_n are" , text "mutually distinct, non-anonymous type variables." diff --git a/src/Checks/KindCheck.hs b/src/Checks/KindCheck.hs --- a/src/Checks/KindCheck.hs +++ b/src/Checks/KindCheck.hs @@ -30,7 +30,7 @@ import Curry.Base.Ident import Curry.Base.Position -import Curry.Base.SpanInfo () +import Curry.Base.SpanInfo import Curry.Base.Pretty import Curry.Syntax import Curry.Syntax.Pretty @@ -39,7 +39,7 @@ import Base.Expr import Base.Kinds import Base.KindSubst -import Base.Messages (Message, posMessage, internalError) +import Base.Messages (Message, spanInfoMessage, internalError) import Base.SCC import Base.TopEnv import Base.Types @@ -58,7 +58,7 @@ -- synonyms into the type constructor environment. kindCheck :: TCEnv -> ClassEnv -> Module a -> ((TCEnv, ClassEnv), [Message]) -kindCheck tcEnv clsEnv (Module _ _ m _ _ ds) = runKCM check initState +kindCheck tcEnv clsEnv (Module _ _ _ m _ _ ds) = runKCM check initState where check = do checkNonRecursiveTypes tds &&> checkAcyclicSuperClasses cds @@ -123,7 +123,7 @@ bt (ExternalDataDecl _ tc _) = [tc] bt (NewtypeDecl _ tc _ _ _) = [tc] bt (TypeDecl _ tc _ _) = [tc] -bt (ClassDecl _ _ cls _ _) = [cls] +bt (ClassDecl _ _ _ cls _ _) = [cls] bt _ = [] ft :: ModuleIdent -> Decl a -> [Ident] @@ -139,19 +139,19 @@ fts m = maybe id $ fts m instance HasType (Decl a) where - fts _ (InfixDecl _ _ _ _) = id - fts m (DataDecl _ _ _ cs clss) = fts m cs . fts m clss - fts _ (ExternalDataDecl _ _ _) = id - fts m (NewtypeDecl _ _ _ nc clss) = fts m nc . fts m clss - fts m (TypeDecl _ _ _ ty) = fts m ty - fts m (TypeSig _ _ ty) = fts m ty - fts m (FunctionDecl _ _ _ eqs) = fts m eqs - fts _ (ExternalDecl _ _) = id - fts m (PatternDecl _ _ rhs) = fts m rhs - fts _ (FreeDecl _ _) = id - fts m (DefaultDecl _ tys) = fts m tys - fts m (ClassDecl _ cx _ _ ds) = fts m cx . fts m ds - fts m (InstanceDecl _ cx cls inst ds) = + fts _ (InfixDecl _ _ _ _) = id + fts m (DataDecl _ _ _ cs clss) = fts m cs . fts m clss + fts _ (ExternalDataDecl _ _ _) = id + fts m (NewtypeDecl _ _ _ nc clss) = fts m nc . fts m clss + fts m (TypeDecl _ _ _ ty) = fts m ty + fts m (TypeSig _ _ ty) = fts m ty + fts m (FunctionDecl _ _ _ eqs) = fts m eqs + fts _ (ExternalDecl _ _) = id + fts m (PatternDecl _ _ rhs) = fts m rhs + fts _ (FreeDecl _ _) = id + fts m (DefaultDecl _ tys) = fts m tys + fts m (ClassDecl _ _ cx _ _ ds) = fts m cx . fts m ds + fts m (InstanceDecl _ _ cx cls inst ds) = fts m cx . fts m cls . fts m inst . fts m ds instance HasType ConstrDecl where @@ -186,8 +186,8 @@ fts m (Equation _ _ rhs) = fts m rhs instance HasType (Rhs a) where - fts m (SimpleRhs _ e ds) = fts m e . fts m ds - fts m (GuardedRhs _ es ds) = fts m es . fts m ds + fts m (SimpleRhs _ _ e ds) = fts m e . fts m ds + fts m (GuardedRhs _ _ es ds) = fts m es . fts m ds instance HasType (CondExpr a) where fts m (CondExpr _ g e) = fts m g . fts m e @@ -213,15 +213,15 @@ fts m (LeftSection _ e _) = fts m e fts m (RightSection _ _ e) = fts m e fts m (Lambda _ _ e) = fts m e - fts m (Let _ ds e) = fts m ds . fts m e - fts m (Do _ stms e) = fts m stms . fts m e + fts m (Let _ _ ds e) = fts m ds . fts m e + fts m (Do _ _ stms e) = fts m stms . fts m e fts m (IfThenElse _ e1 e2 e3) = fts m e1 . fts m e2 . fts m e3 - fts m (Case _ _ e as) = fts m e . fts m as + fts m (Case _ _ _ e as) = fts m e . fts m as instance HasType (Statement a) where - fts m (StmtExpr _ e) = fts m e - fts m (StmtDecl _ ds) = fts m ds - fts m (StmtBind _ _ e) = fts m e + fts m (StmtExpr _ e) = fts m e + fts m (StmtDecl _ _ ds) = fts m ds + fts m (StmtBind _ _ e) = fts m e instance HasType (Alt a) where fts m (Alt _ _ rhs) = fts m rhs @@ -277,16 +277,16 @@ checkAcyclicSuperClasses :: [Decl a] -> KCM () checkAcyclicSuperClasses ds = do m <- getModuleIdent - mapM_ checkClassDecl $ scc bt (\(ClassDecl _ cx _ _ _) -> fc m cx) ds + mapM_ checkClassDecl $ scc bt (\(ClassDecl _ _ cx _ _ _) -> fc m cx) ds checkClassDecl :: [Decl a] -> KCM () checkClassDecl [] = internalError "Checks.KindCheck.checkClassDecl: empty list" -checkClassDecl [ClassDecl _ cx cls _ _] = do +checkClassDecl [ClassDecl _ _ cx cls _ _] = do m <- getModuleIdent when (cls `elem` fc m cx) $ report $ errRecursiveClasses [cls] -checkClassDecl (ClassDecl _ _ cls _ _ : ds) = - report $ errRecursiveClasses $ cls : [cls' | ClassDecl _ _ cls' _ _ <- ds] +checkClassDecl (ClassDecl _ _ _ cls _ _ : ds) = + report $ errRecursiveClasses $ cls : [cls' | ClassDecl _ _ _ cls' _ _ <- ds] checkClassDecl _ = internalError "Checks.KindCheck.checkClassDecl: no class declaration" @@ -342,7 +342,7 @@ where aliasType tc' k = AliasType tc' k $ length tvs ty' = expandMonoType m tcEnv' tvs ty -bindKind m tcEnv' clsEnv tcEnv (ClassDecl _ _ cls tv ds) = +bindKind m tcEnv' clsEnv tcEnv (ClassDecl _ _ _ cls tv ds) = bindTypeClass cls (concatMap mkMethods ds) tcEnv where mkMethods (TypeSig _ fs qty) = map (mkMethod qty) fs @@ -390,7 +390,7 @@ bindTypeVar ident k = bindTopEnv ident (TypeVar k) bindClass :: ModuleIdent -> TCEnv -> ClassEnv -> Decl a -> ClassEnv -bindClass m tcEnv clsEnv (ClassDecl _ cx cls _ ds) = +bindClass m tcEnv clsEnv (ClassDecl _ _ cx cls _ ds) = bindClassInfo qcls (sclss, ms) clsEnv where qcls = qualifyWith m cls ms = map (\f -> (f, f `elem` fs)) $ concatMap methods ds @@ -442,54 +442,54 @@ kcDecl tcEnv (NewtypeDecl _ tc tvs nc _) = do (_, tcEnv') <- bindTypeVars tc tvs tcEnv kcNewConstrDecl tcEnv' nc -kcDecl tcEnv t@(TypeDecl p tc tvs ty) = do +kcDecl tcEnv t@(TypeDecl _ tc tvs ty) = do (k, tcEnv') <- bindTypeVars tc tvs tcEnv - kcType tcEnv' p "type declaration" (ppDecl t) k ty -kcDecl tcEnv (TypeSig p _ qty) = kcTypeSig tcEnv p qty + kcType tcEnv' "type declaration" (pPrint t) k ty +kcDecl tcEnv (TypeSig _ _ qty) = kcTypeSig tcEnv qty kcDecl tcEnv (FunctionDecl _ _ _ eqs) = mapM_ (kcEquation tcEnv) eqs kcDecl _ (ExternalDecl _ _) = ok kcDecl tcEnv (PatternDecl _ _ rhs) = kcRhs tcEnv rhs kcDecl _ (FreeDecl _ _) = ok -kcDecl tcEnv (DefaultDecl p tys) = do +kcDecl tcEnv (DefaultDecl _ tys) = do tcEnv' <- foldM bindFreshKind tcEnv $ nub $ fv tys - mapM_ (kcValueType tcEnv' p "default declaration" empty) tys -kcDecl tcEnv (ClassDecl p cx cls tv ds) = do + mapM_ (kcValueType tcEnv' "default declaration" empty) tys +kcDecl tcEnv (ClassDecl _ _ cx cls tv ds) = do m <- getModuleIdent let tcEnv' = bindTypeVar tv (clsKind m (qualifyWith m cls) tcEnv) tcEnv - kcContext tcEnv' p cx + kcContext tcEnv' cx mapM_ (kcDecl tcEnv') ds -kcDecl tcEnv (InstanceDecl p cx qcls inst ds) = do +kcDecl tcEnv (InstanceDecl p _ cx qcls inst ds) = do m <- getModuleIdent tcEnv' <- foldM bindFreshKind tcEnv $ fv inst - kcContext tcEnv' p cx - kcType tcEnv' p what doc (clsKind m qcls tcEnv) inst + kcContext tcEnv' cx + kcType tcEnv' what doc (clsKind m qcls tcEnv) inst mapM_ (kcDecl tcEnv') ds where what = "instance declaration" - doc = ppDecl (InstanceDecl p cx qcls inst []) + doc = pPrint (InstanceDecl p WhitespaceLayout cx qcls inst []) kcConstrDecl :: TCEnv -> ConstrDecl -> KCM () -kcConstrDecl tcEnv d@(ConstrDecl p _ tys) = do - mapM_ (kcValueType tcEnv p what doc) tys +kcConstrDecl tcEnv d@(ConstrDecl _ _ tys) = do + mapM_ (kcValueType tcEnv what doc) tys where what = "data constructor declaration" - doc = ppConstr d -kcConstrDecl tcEnv d@(ConOpDecl p ty1 _ ty2) = do - kcValueType tcEnv p what doc ty1 - kcValueType tcEnv p what doc ty2 + doc = pPrint d +kcConstrDecl tcEnv d@(ConOpDecl _ ty1 _ ty2) = do + kcValueType tcEnv what doc ty1 + kcValueType tcEnv what doc ty2 where what = "data constructor declaration" - doc = ppConstr d + doc = pPrint d kcConstrDecl tcEnv (RecordDecl _ _ fs) = do mapM_ (kcFieldDecl tcEnv) fs kcFieldDecl :: TCEnv -> FieldDecl -> KCM () -kcFieldDecl tcEnv d@(FieldDecl p _ ty) = - kcValueType tcEnv p "field declaration" (ppFieldDecl d) ty +kcFieldDecl tcEnv d@(FieldDecl _ _ ty) = + kcValueType tcEnv "field declaration" (pPrint d) ty kcNewConstrDecl :: TCEnv -> NewConstrDecl -> KCM () -kcNewConstrDecl tcEnv d@(NewConstrDecl p _ ty) = - kcValueType tcEnv p "newtype constructor declaration" (ppNewConstr d) ty +kcNewConstrDecl tcEnv d@(NewConstrDecl _ _ ty) = + kcValueType tcEnv "newtype constructor declaration" (pPrint d) ty kcNewConstrDecl tcEnv (NewRecordDecl p _ (l, ty)) = kcFieldDecl tcEnv (FieldDecl p [l] ty) @@ -497,110 +497,110 @@ kcEquation tcEnv (Equation _ _ rhs) = kcRhs tcEnv rhs kcRhs :: TCEnv -> Rhs a -> KCM () -kcRhs tcEnv (SimpleRhs p e ds) = do - kcExpr tcEnv p e +kcRhs tcEnv (SimpleRhs _ _ e ds) = do + kcExpr tcEnv e mapM_ (kcDecl tcEnv) ds -kcRhs tcEnv (GuardedRhs _ es ds) = do +kcRhs tcEnv (GuardedRhs _ _ es ds) = do mapM_ (kcCondExpr tcEnv) es mapM_ (kcDecl tcEnv) ds kcCondExpr :: TCEnv -> CondExpr a -> KCM () -kcCondExpr tcEnv (CondExpr p g e) = kcExpr tcEnv p g >> kcExpr tcEnv p e +kcCondExpr tcEnv (CondExpr _ g e) = kcExpr tcEnv g >> kcExpr tcEnv e -kcExpr :: HasPosition p => TCEnv -> p -> Expression a -> KCM () -kcExpr _ _ (Literal _ _ _) = ok -kcExpr _ _ (Variable _ _ _) = ok -kcExpr _ _ (Constructor _ _ _) = ok -kcExpr tcEnv p (Paren _ e) = kcExpr tcEnv p e -kcExpr tcEnv p (Typed _ e qty) = do - kcExpr tcEnv p e - kcTypeSig tcEnv p qty -kcExpr tcEnv p (Record _ _ _ fs) = mapM_ (kcField tcEnv p) fs -kcExpr tcEnv p (RecordUpdate _ e fs) = do - kcExpr tcEnv p e - mapM_ (kcField tcEnv p) fs -kcExpr tcEnv p (Tuple _ es) = mapM_ (kcExpr tcEnv p) es -kcExpr tcEnv p (List _ _ es) = mapM_ (kcExpr tcEnv p) es -kcExpr tcEnv p (ListCompr _ e stms) = do - kcExpr tcEnv p e - mapM_ (kcStmt tcEnv p) stms -kcExpr tcEnv p (EnumFrom _ e) = kcExpr tcEnv p e -kcExpr tcEnv p (EnumFromThen _ e1 e2) = do - kcExpr tcEnv p e1 - kcExpr tcEnv p e2 -kcExpr tcEnv p (EnumFromTo _ e1 e2) = do - kcExpr tcEnv p e1 - kcExpr tcEnv p e2 -kcExpr tcEnv p (EnumFromThenTo _ e1 e2 e3) = do - kcExpr tcEnv p e1 - kcExpr tcEnv p e2 - kcExpr tcEnv p e3 -kcExpr tcEnv p (UnaryMinus _ e) = kcExpr tcEnv p e -kcExpr tcEnv p (Apply _ e1 e2) = do - kcExpr tcEnv p e1 - kcExpr tcEnv p e2 -kcExpr tcEnv p (InfixApply _ e1 _ e2) = do - kcExpr tcEnv p e1 - kcExpr tcEnv p e2 -kcExpr tcEnv p (LeftSection _ e _) = kcExpr tcEnv p e -kcExpr tcEnv p (RightSection _ _ e) = kcExpr tcEnv p e -kcExpr tcEnv p (Lambda _ _ e) = kcExpr tcEnv p e -kcExpr tcEnv p (Let _ ds e) = do +kcExpr :: TCEnv -> Expression a -> KCM () +kcExpr _ (Literal _ _ _) = ok +kcExpr _ (Variable _ _ _) = ok +kcExpr _ (Constructor _ _ _) = ok +kcExpr tcEnv (Paren _ e) = kcExpr tcEnv e +kcExpr tcEnv (Typed _ e qty) = do + kcExpr tcEnv e + kcTypeSig tcEnv qty +kcExpr tcEnv (Record _ _ _ fs) = mapM_ (kcField tcEnv) fs +kcExpr tcEnv (RecordUpdate _ e fs) = do + kcExpr tcEnv e + mapM_ (kcField tcEnv) fs +kcExpr tcEnv (Tuple _ es) = mapM_ (kcExpr tcEnv) es +kcExpr tcEnv (List _ _ es) = mapM_ (kcExpr tcEnv) es +kcExpr tcEnv (ListCompr _ e stms) = do + kcExpr tcEnv e + mapM_ (kcStmt tcEnv) stms +kcExpr tcEnv (EnumFrom _ e) = kcExpr tcEnv e +kcExpr tcEnv (EnumFromThen _ e1 e2) = do + kcExpr tcEnv e1 + kcExpr tcEnv e2 +kcExpr tcEnv (EnumFromTo _ e1 e2) = do + kcExpr tcEnv e1 + kcExpr tcEnv e2 +kcExpr tcEnv (EnumFromThenTo _ e1 e2 e3) = do + kcExpr tcEnv e1 + kcExpr tcEnv e2 + kcExpr tcEnv e3 +kcExpr tcEnv (UnaryMinus _ e) = kcExpr tcEnv e +kcExpr tcEnv (Apply _ e1 e2) = do + kcExpr tcEnv e1 + kcExpr tcEnv e2 +kcExpr tcEnv (InfixApply _ e1 _ e2) = do + kcExpr tcEnv e1 + kcExpr tcEnv e2 +kcExpr tcEnv (LeftSection _ e _) = kcExpr tcEnv e +kcExpr tcEnv (RightSection _ _ e) = kcExpr tcEnv e +kcExpr tcEnv (Lambda _ _ e) = kcExpr tcEnv e +kcExpr tcEnv (Let _ _ ds e) = do mapM_ (kcDecl tcEnv) ds - kcExpr tcEnv p e -kcExpr tcEnv p (Do _ stms e) = do - mapM_ (kcStmt tcEnv p) stms - kcExpr tcEnv p e -kcExpr tcEnv p (IfThenElse _ e1 e2 e3) = do - kcExpr tcEnv p e1 - kcExpr tcEnv p e2 - kcExpr tcEnv p e3 -kcExpr tcEnv p (Case _ _ e alts) = do - kcExpr tcEnv p e + kcExpr tcEnv e +kcExpr tcEnv (Do _ _ stms e) = do + mapM_ (kcStmt tcEnv) stms + kcExpr tcEnv e +kcExpr tcEnv (IfThenElse _ e1 e2 e3) = do + kcExpr tcEnv e1 + kcExpr tcEnv e2 + kcExpr tcEnv e3 +kcExpr tcEnv (Case _ _ _ e alts) = do + kcExpr tcEnv e mapM_ (kcAlt tcEnv) alts -kcStmt :: HasPosition p => TCEnv -> p -> Statement a -> KCM () -kcStmt tcEnv p (StmtExpr _ e) = kcExpr tcEnv p e -kcStmt tcEnv _ (StmtDecl _ ds) = mapM_ (kcDecl tcEnv) ds -kcStmt tcEnv p (StmtBind _ _ e) = kcExpr tcEnv p e +kcStmt :: TCEnv -> Statement a -> KCM () +kcStmt tcEnv (StmtExpr _ e) = kcExpr tcEnv e +kcStmt tcEnv (StmtDecl _ _ ds) = mapM_ (kcDecl tcEnv) ds +kcStmt tcEnv (StmtBind _ _ e) = kcExpr tcEnv e kcAlt :: TCEnv -> Alt a -> KCM () kcAlt tcEnv (Alt _ _ rhs) = kcRhs tcEnv rhs -kcField :: HasPosition p => TCEnv -> p -> Field (Expression a) -> KCM () -kcField tcEnv p (Field _ _ e) = kcExpr tcEnv p e +kcField :: TCEnv -> Field (Expression a) -> KCM () +kcField tcEnv (Field _ _ e) = kcExpr tcEnv e -kcContext :: HasPosition p => TCEnv -> p -> Context -> KCM () -kcContext tcEnv p = mapM_ (kcConstraint tcEnv p) +kcContext :: TCEnv -> Context -> KCM () +kcContext tcEnv = mapM_ (kcConstraint tcEnv) -kcConstraint :: HasPosition p => TCEnv -> p -> Constraint -> KCM () -kcConstraint tcEnv p sc@(Constraint _ qcls ty) = do +kcConstraint :: TCEnv -> Constraint -> KCM () +kcConstraint tcEnv sc@(Constraint _ qcls ty) = do m <- getModuleIdent - kcType tcEnv p "class constraint" doc (clsKind m qcls tcEnv) ty + kcType tcEnv "class constraint" doc (clsKind m qcls tcEnv) ty where - doc = ppConstraint sc + doc = pPrint sc -kcTypeSig :: HasPosition p => TCEnv -> p -> QualTypeExpr -> KCM () -kcTypeSig tcEnv p (QualTypeExpr _ cx ty) = do +kcTypeSig :: TCEnv -> QualTypeExpr -> KCM () +kcTypeSig tcEnv (QualTypeExpr _ cx ty) = do tcEnv' <- foldM bindFreshKind tcEnv free - kcContext tcEnv' p cx - kcValueType tcEnv' p "type signature" doc ty + kcContext tcEnv' cx + kcValueType tcEnv' "type signature" doc ty where free = filter (null . flip lookupTypeInfo tcEnv) $ nub $ fv ty - doc = ppTypeExpr 0 ty + doc = pPrintPrec 0 ty -kcValueType :: HasPosition p => TCEnv -> p -> String -> Doc -> TypeExpr -> KCM () -kcValueType tcEnv p what doc = kcType tcEnv p what doc KindStar +kcValueType :: TCEnv -> String -> Doc -> TypeExpr -> KCM () +kcValueType tcEnv what doc = kcType tcEnv what doc KindStar -kcType :: HasPosition p => TCEnv -> p -> String -> Doc -> Kind -> TypeExpr -> KCM () -kcType tcEnv p what doc k ty = do - k' <- kcTypeExpr tcEnv p "type expression" doc' 0 ty - unify p what (doc $-$ text "Type:" <+> doc') k k' +kcType :: TCEnv -> String -> Doc -> Kind -> TypeExpr -> KCM () +kcType tcEnv what doc k ty = do + k' <- kcTypeExpr tcEnv "type expression" doc' 0 ty + unify ty what (doc $-$ text "Type:" <+> doc') k k' where - doc' = ppTypeExpr 0 ty + doc' = pPrintPrec 0 ty -kcTypeExpr :: HasPosition p => TCEnv -> p -> String -> Doc -> Int -> TypeExpr -> KCM Kind -kcTypeExpr tcEnv p _ _ n (ConstructorType _ tc) = do +kcTypeExpr :: TCEnv -> String -> Doc -> Int -> TypeExpr -> KCM Kind +kcTypeExpr tcEnv _ _ n (ConstructorType p tc) = do m <- getModuleIdent case qualLookupTypeInfo tc tcEnv of [AliasType _ _ n' _] -> case n >= n' of @@ -609,29 +609,29 @@ report $ errPartialAlias p tc n' n freshKindVar _ -> return $ tcKind m tc tcEnv -kcTypeExpr tcEnv p what doc n (ApplyType _ ty1 ty2) = do - (alpha, beta) <- kcTypeExpr tcEnv p what doc (n + 1) ty1 >>= - kcArrow p what (doc $-$ text "Type:" <+> ppTypeExpr 0 ty1) - kcTypeExpr tcEnv p what doc 0 ty2 >>= - unify p what (doc $-$ text "Type:" <+> ppTypeExpr 0 ty2) alpha +kcTypeExpr tcEnv what doc n (ApplyType p ty1 ty2) = do + (alpha, beta) <- kcTypeExpr tcEnv what doc (n + 1) ty1 >>= + kcArrow p what (doc $-$ text "Type:" <+> pPrintPrec 0 ty1) + kcTypeExpr tcEnv what doc 0 ty2 >>= + unify p what (doc $-$ text "Type:" <+> pPrintPrec 0 ty2) alpha return beta -kcTypeExpr tcEnv _ _ _ _ (VariableType _ tv) = return (varKind tv tcEnv) -kcTypeExpr tcEnv p what doc _ (TupleType _ tys) = do - mapM_ (kcValueType tcEnv p what doc) tys +kcTypeExpr tcEnv _ _ _ (VariableType _ tv) = return (varKind tv tcEnv) +kcTypeExpr tcEnv what doc _ (TupleType _ tys) = do + mapM_ (kcValueType tcEnv what doc) tys return KindStar -kcTypeExpr tcEnv p what doc _ (ListType _ ty) = do - kcValueType tcEnv p what doc ty +kcTypeExpr tcEnv what doc _ (ListType _ ty) = do + kcValueType tcEnv what doc ty return KindStar -kcTypeExpr tcEnv p what doc _ (ArrowType _ ty1 ty2) = do - kcValueType tcEnv p what doc ty1 - kcValueType tcEnv p what doc ty2 +kcTypeExpr tcEnv what doc _ (ArrowType _ ty1 ty2) = do + kcValueType tcEnv what doc ty1 + kcValueType tcEnv what doc ty2 return KindStar -kcTypeExpr tcEnv p what doc n (ParenType _ ty) = kcTypeExpr tcEnv p what doc n ty -kcTypeExpr tcEnv p what doc n (ForallType _ vs ty) = do +kcTypeExpr tcEnv what doc n (ParenType _ ty) = kcTypeExpr tcEnv what doc n ty +kcTypeExpr tcEnv what doc n (ForallType _ vs ty) = do tcEnv' <- foldM bindFreshKind tcEnv vs - kcTypeExpr tcEnv' p what doc n ty + kcTypeExpr tcEnv' what doc n ty -kcArrow :: HasPosition p => p -> String -> Doc -> Kind -> KCM (Kind, Kind) +kcArrow :: HasSpanInfo p => p -> String -> Doc -> Kind -> KCM (Kind, Kind) kcArrow p what doc k = do theta <- getKindSubst case subst theta k of @@ -650,7 +650,7 @@ -- --------------------------------------------------------------------------- -- The unification uses Robinson's algorithm. -unify :: HasPosition p => p -> String -> Doc -> Kind -> Kind -> KCM () +unify :: HasSpanInfo p => p -> String -> Doc -> Kind -> Kind -> KCM () unify p what doc k1 k2 = do theta <- getKindSubst let k1' = subst theta k1 @@ -710,9 +710,9 @@ errRecursiveTypes :: [Ident] -> Message errRecursiveTypes [] = internalError "KindCheck.errRecursiveTypes: empty list" -errRecursiveTypes [tc] = posMessage tc $ hsep $ map text +errRecursiveTypes [tc] = spanInfoMessage tc $ hsep $ map text ["Recursive synonym or renaming type", idName tc] -errRecursiveTypes (tc:tcs) = posMessage tc $ +errRecursiveTypes (tc:tcs) = spanInfoMessage tc $ text "Mutually recursive synonym and/or renaming types" <+> text (idName tc) <> types empty tcs where @@ -725,9 +725,9 @@ errRecursiveClasses :: [Ident] -> Message errRecursiveClasses [] = internalError "KindCheck.errRecursiveClasses: empty list" -errRecursiveClasses [cls] = posMessage cls $ hsep $ map text +errRecursiveClasses [cls] = spanInfoMessage cls $ hsep $ map text ["Recursive type class", idName cls] -errRecursiveClasses (cls:clss) = posMessage cls $ +errRecursiveClasses (cls:clss) = spanInfoMessage cls $ text "Mutually recursive type classes" <+> text (idName cls) <> classes empty clss where @@ -737,15 +737,15 @@ classPos cls' = text (idName cls') <+> parens (text $ showLine $ getPosition cls') -errNonArrowKind :: HasPosition p => p -> String -> Doc -> Kind -> Message -errNonArrowKind p what doc k = posMessage p $ vcat +errNonArrowKind :: HasSpanInfo p => p -> String -> Doc -> Kind -> Message +errNonArrowKind p what doc k = spanInfoMessage p $ vcat [ text "Kind error in" <+> text what, doc , text "Kind:" <+> ppKind k , text "Cannot be applied" ] -errPartialAlias :: HasPosition p => p -> QualIdent -> Int -> Int -> Message -errPartialAlias p tc arity argc = posMessage p $ hsep +errPartialAlias :: HasSpanInfo p => p -> QualIdent -> Int -> Int -> Message +errPartialAlias p tc arity argc = spanInfoMessage p $ hsep [ text "Type synonym", ppQIdent tc , text "requires at least" , int arity, text (plural arity "argument") <> comma @@ -754,8 +754,8 @@ where plural n x = if n == 1 then x else x ++ "s" -errKindMismatch :: HasPosition p => p -> String -> Doc -> Kind -> Kind -> Message -errKindMismatch p what doc k1 k2 = posMessage p $ vcat +errKindMismatch :: HasSpanInfo p => p -> String -> Doc -> Kind -> Kind -> Message +errKindMismatch p what doc k1 k2 = spanInfoMessage p $ vcat [ text "Kind error in" <+> text what, doc , text "Inferred kind:" <+> ppKind k2 , text "Expected kind:" <+> ppKind k1 diff --git a/src/Checks/PrecCheck.hs b/src/Checks/PrecCheck.hs --- a/src/Checks/PrecCheck.hs +++ b/src/Checks/PrecCheck.hs @@ -37,7 +37,7 @@ import Curry.Syntax import Base.Expr -import Base.Messages (Message, posMessage, internalError) +import Base.Messages (Message, spanInfoMessage, internalError) import Base.Utils (findMultiples) import Env.OpPrec (OpPrecEnv, OpPrec (..), PrecInfo (..), defaultP, bindP @@ -94,7 +94,7 @@ opss -> mapM_ (report . errMultiplePrecedence) opss where (fixDs, nonFixDs) = partition isInfixDecl ds0 - innerDs = [ d | ClassDecl _ _ _ _ ds <- ds0, d <- ds ] + innerDs = [ d | ClassDecl _ _ _ _ _ ds <- ds0, d <- ds ] opFixDecls = [ op | InfixDecl _ _ _ ops <- fixDs, op <- ops ] -- Unrenaming is necessary for inner class declarations, because operators -- within class declarations have been renamed during syntax checking. @@ -136,10 +136,10 @@ FunctionDecl p a f <$> mapM checkEquation eqs checkDecl (PatternDecl p t rhs) = PatternDecl p <$> checkPattern t <*> checkRhs rhs -checkDecl (ClassDecl p cx cls tv ds) = - ClassDecl p cx cls tv <$> mapM checkDecl ds -checkDecl (InstanceDecl p cx qcls inst ds) = - InstanceDecl p cx qcls inst <$> mapM checkDecl ds +checkDecl (ClassDecl p li cx cls tv ds) = + ClassDecl p li cx cls tv <$> mapM checkDecl ds +checkDecl (InstanceDecl p li cx qcls inst ds) = + InstanceDecl p li cx qcls inst <$> mapM checkDecl ds checkDecl d = return d checkEquation :: Equation a -> PCM (Equation a) @@ -188,10 +188,10 @@ RecordPattern spi a c <$> mapM (checkField checkPattern) fs checkRhs :: Rhs a -> PCM (Rhs a) -checkRhs (SimpleRhs spi e ds) = withLocalPrecEnv $ - flip (SimpleRhs spi) <$> checkDecls ds <*> checkExpr e -checkRhs (GuardedRhs spi es ds) = withLocalPrecEnv $ - flip (GuardedRhs spi) <$> checkDecls ds <*> mapM checkCondExpr es +checkRhs (SimpleRhs spi li e ds) = withLocalPrecEnv $ + flip (SimpleRhs spi li) <$> checkDecls ds <*> checkExpr e +checkRhs (GuardedRhs spi li es ds) = withLocalPrecEnv $ + flip (GuardedRhs spi li) <$> checkDecls ds <*> mapM checkCondExpr es checkCondExpr :: CondExpr a -> PCM (CondExpr a) checkCondExpr (CondExpr p g e) = CondExpr p <$> checkExpr g <*> checkExpr e @@ -223,23 +223,26 @@ e1' <- checkExpr e1 e2' <- checkExpr e2 fixPrec spi e1' op e2' -checkExpr (LeftSection spi e op) = checkExpr e >>= checkLSection spi op -checkExpr (RightSection spi op e) = checkExpr e >>= checkRSection spi op -checkExpr (Lambda spi ts e) = +checkExpr (LeftSection spi e op) = checkExpr e >>= checkLSection spi op +checkExpr (RightSection spi op e) = checkExpr e >>= checkRSection spi op +checkExpr (Lambda spi ts e) = Lambda spi <$> mapM checkPattern ts <*> checkExpr e -checkExpr (Let spi ds e) = withLocalPrecEnv $ - Let spi <$> checkDecls ds <*> checkExpr e -checkExpr (Do spi sts e) = withLocalPrecEnv $ - Do spi <$> mapM checkStmt sts <*> checkExpr e +checkExpr (Let spi li ds e) = withLocalPrecEnv $ + Let spi li <$> checkDecls ds <*> checkExpr e +checkExpr (Do spi li sts e) = withLocalPrecEnv $ + Do spi li <$> mapM checkStmt sts <*> checkExpr e checkExpr (IfThenElse spi e1 e2 e3) = IfThenElse spi <$> checkExpr e1 <*> checkExpr e2 <*> checkExpr e3 -checkExpr (Case spi ct e alts) = - Case spi ct <$> checkExpr e <*> mapM checkAlt alts +checkExpr (Case spi li ct e alts) = + Case spi li ct <$> checkExpr e <*> mapM checkAlt alts checkStmt :: Statement a -> PCM (Statement a) -checkStmt (StmtExpr spi e) = StmtExpr spi <$> checkExpr e -checkStmt (StmtDecl spi ds) = StmtDecl spi <$> checkDecls ds -checkStmt (StmtBind spi t e) = StmtBind spi <$> checkPattern t <*> checkExpr e +checkStmt (StmtExpr spi e) = + StmtExpr spi <$> checkExpr e +checkStmt (StmtDecl spi li ds) = + StmtDecl spi li <$> checkDecls ds +checkStmt (StmtBind spi t e) = + StmtBind spi <$> checkPattern t <*> checkExpr e checkAlt :: Alt a -> PCM (Alt a) checkAlt (Alt p t rhs) = Alt p <$> checkPattern t <*> checkRhs rhs @@ -488,18 +491,18 @@ -- --------------------------------------------------------------------------- errUndefinedOperator :: Ident -> Message -errUndefinedOperator op = posMessage op $ hsep $ map text +errUndefinedOperator op = spanInfoMessage op $ hsep $ map text ["No definition for", escName op, "in this scope"] errMultiplePrecedence :: [Ident] -> Message errMultiplePrecedence [] = internalError "PrecCheck.errMultiplePrecedence: empty list" -errMultiplePrecedence (op:ops) = posMessage op $ +errMultiplePrecedence (op:ops) = spanInfoMessage op $ (hsep $ map text ["More than one fixity declaration for", escName op, "at"]) $+$ nest 2 (vcat (map (ppPosition . getPosition) (op:ops))) errInvalidParse :: String -> Ident -> QualIdent -> Message -errInvalidParse what op1 op2 = posMessage op1 $ hsep $ map text +errInvalidParse what op1 op2 = spanInfoMessage op1 $ hsep $ map text [ "Invalid use of", what, escName op1, "with", escQualName op2, "in" , showLine $ getPosition op2] @@ -507,6 +510,6 @@ -- TODO: Is this still true after span update for parser? errAmbiguousParse :: String -> QualIdent -> QualIdent -> Message -errAmbiguousParse what op1 op2 = posMessage op1 $ hsep $ map text +errAmbiguousParse what op1 op2 = spanInfoMessage op1 $ hsep $ map text ["Ambiguous use of", what, escQualName op1, "with", escQualName op2, "in" , showLine $ getPosition op2] diff --git a/src/Checks/SyntaxCheck.hs b/src/Checks/SyntaxCheck.hs --- a/src/Checks/SyntaxCheck.hs +++ b/src/Checks/SyntaxCheck.hs @@ -34,34 +34,36 @@ import Control.Applicative ((<$>), (<*>)) #endif -import Control.Monad (unless, when) -import qualified Control.Monad.State as S ( State, runState, gets, modify - , withState ) -import Data.Function (on) -import Data.List (insertBy, intersect, nub, nubBy) -import qualified Data.Map as Map ( Map, empty, findWithDefault - , fromList, insertWith, keys ) -import Data.Maybe (isJust, isNothing) -import qualified Data.Set as Set ( Set, empty, insert, member - , singleton, toList, union) +import Control.Monad (unless, when) +import qualified Control.Monad.State as S (State, gets, modify, runState, + withState) +import Data.Function (on) +import Data.List (insertBy, intersect, nub, nubBy) +import qualified Data.Map as Map (Map, empty, findWithDefault, + fromList, insertWith, keys) +import Data.Maybe (isJust, isNothing) +import qualified Data.Set as Set (Set, empty, insert, member, + singleton, toList, union) -import Curry.Base.Ident -import Curry.Base.Position -import Curry.Base.Pretty -import Curry.Base.Span -import Curry.Base.SpanInfo -import Curry.Syntax -import Curry.Syntax.Pretty (ppPattern) +import Curry.Base.Ident +import Curry.Base.Position +import Curry.Base.Pretty +import Curry.Base.Span +import Curry.Base.SpanInfo +import Curry.Syntax -import Base.Expr -import Base.Messages (Message, posMessage, internalError) -import Base.NestEnv -import Base.SCC (scc) -import Base.Utils ((++!), findDouble, findMultiples) +import Base.Expr +import Base.Messages (Message, internalError, + spanInfoMessage) +import Base.NestEnv +import Base.SCC (scc) +import Base.Utils (findDouble, findMultiples, (++!)) -import Env.TypeConstructor (TCEnv, clsMethods) -import Env.Value (ValueEnv, ValueInfo (..)) +import Env.TypeConstructor (TCEnv, clsMethods, getOrigName) +import Env.Value (ValueEnv, ValueInfo (..), + qualLookupValueUnique) + -- The syntax checking proceeds as follows. First, the compiler extracts -- information about all imported values and data constructors from the -- imported (type) environments. Next, the data constructors defined in @@ -77,7 +79,7 @@ syntaxCheck :: [KnownExtension] -> TCEnv -> ValueEnv -> Module () -> ((Module (), [KnownExtension]), [Message]) -syntaxCheck exts tcEnv vEnv mdl@(Module _ _ m _ _ ds) = +syntaxCheck exts tcEnv vEnv mdl@(Module _ _ _ m _ _ ds) = case findMultiples cons of [] -> case findMultiples (ls ++ fs ++ cons ++ cs) of [] -> runSC (checkModule mdl) state @@ -90,9 +92,9 @@ cons = concatMap constrs tds ls = nub $ concatMap recLabels tds fs = nub $ concatMap vars vds - cs = concatMap (concatMap methods) [ds' | ClassDecl _ _ _ _ ds' <- cds] + cs = concatMap (concatMap methods) [ds' | ClassDecl _ _ _ _ _ ds' <- cds] rEnv = globalEnv $ fmap renameInfo vEnv - state = initState exts m tcEnv rEnv + state = initState exts m tcEnv rEnv vEnv -- A global state transformer is used for generating fresh integer keys with -- which the variables are renamed. @@ -109,6 +111,7 @@ , moduleIdent :: ModuleIdent -- ^ 'ModuleIdent' of the current module , tyConsEnv :: TCEnv , renameEnv :: RenameEnv -- ^ Information store + , valueEnv :: ValueEnv -- ^ To check instance method visibility , scopeId :: Integer -- ^ Identifier for the current scope , nextId :: Integer -- ^ Next fresh identifier , funcDeps :: FuncDeps -- ^ Stores data about functions dependencies @@ -117,9 +120,10 @@ } -- |Initial syntax check state -initState :: [KnownExtension] -> ModuleIdent -> TCEnv -> RenameEnv -> SCState -initState exts m tcEnv rEnv = - SCState exts m tcEnv rEnv globalScopeId 1 noFuncDeps False [] +initState :: [KnownExtension] -> ModuleIdent -> TCEnv -> RenameEnv -> ValueEnv + -> SCState +initState exts m tcEnv rEnv vEnv = + SCState exts m tcEnv rEnv vEnv globalScopeId 1 noFuncDeps False [] -- |Identifier for global (top-level) declarations globalScopeId :: Integer @@ -154,6 +158,10 @@ getRenameEnv :: SCM RenameEnv getRenameEnv = S.gets renameEnv +-- |Retrieve the 'ValueEnv' +getValueEnv :: SCM ValueEnv +getValueEnv = S.gets valueEnv + -- |Modify the 'RenameEnv' modifyRenameEnv :: (RenameEnv -> RenameEnv) -> SCM () modifyRenameEnv f = S.modify $ \s -> s { renameEnv = f $ renameEnv s } @@ -361,7 +369,7 @@ bindRecordLabel :: (Ident, [Ident]) -> SCM () bindRecordLabel (l, cs) = do m <- getModuleIdent - new <- (null . lookupVar l) <$> getRenameEnv + new <- null . lookupVar l <$> getRenameEnv unless new $ report $ errDuplicateDefinition l modifyRenameEnv $ bindGlobal False m l $ RecordLabel (qualifyWith m l) (map (qualifyWith m) cs) @@ -376,7 +384,7 @@ = let arty = length $ snd $ getFlatLhs eq in bindGlobal tcc m f (GlobalVar (qualifyWith m f) arty) env bindFuncDecl tcc m (TypeSig _ fs (QualTypeExpr _ _ ty)) env - = foldr bindTS env $ map (qualifyWith m) fs + = foldr (bindTS . qualifyWith m) env fs where bindTS qf env' | null $ qualLookupVar qf env' @@ -388,8 +396,8 @@ -- |Bind type class information, i.e. class methods bindClassDecl :: Decl a -> SCM () -bindClassDecl (ClassDecl _ _ _ _ ds) = mapM_ bindClassMethod ds -bindClassDecl _ = ok +bindClassDecl (ClassDecl _ _ _ _ _ ds) = mapM_ bindClassMethod ds +bindClassDecl _ = ok bindClassMethod :: Decl a -> SCM () bindClassMethod ts@(TypeSig _ _ _) = do @@ -406,8 +414,7 @@ | otherwise = let arty = length $ snd $ getFlatLhs $ head eqs in bindLocal (unRenameIdent f) (LocalVar f arty) env bindVarDecl (PatternDecl _ t _) env = foldr bindVar env (bv t) -bindVarDecl (FreeDecl _ vs) env = - foldr bindVar env (map varIdent vs) +bindVarDecl (FreeDecl _ vs) env = foldr (bindVar . varIdent) env vs bindVarDecl _ env = env bindVar :: Ident -> RenameEnv -> RenameEnv @@ -447,7 +454,7 @@ -- declaration are allowed to be declared). checkModule :: Module () -> SCM (Module (), [KnownExtension]) -checkModule (Module spi ps m es is ds) = do +checkModule (Module spi li ps m es is ds) = do mapM_ bindTypeDecl tds mapM_ bindClassDecl cds ds' <- checkTopDecls ds @@ -456,7 +463,7 @@ let ds'' = updateClassAndInstanceDecls cds' ids' ds' checkFuncPatDeps exts <- getExtensions - return (Module spi ps m es is ds'', exts) + return (Module spi li ps m es is ds'', exts) where tds = filter isTypeDecl ds cds = filter isClassDecl ds ids = filter isInstanceDecl ds @@ -468,7 +475,7 @@ fps <- getFuncPats deps <- getGlobalDeps let levels = scc (:[]) - (\k -> Set.toList (Map.findWithDefault (Set.empty) k deps)) + (\k -> Set.toList (Map.findWithDefault Set.empty k deps)) (Map.keys deps) levelMap = Map.fromList [ (f, l) | (fs, l) <- zip levels [1 ..], f <- fs ] level f = Map.findWithDefault (0 :: Int) f levelMap @@ -485,21 +492,48 @@ checkDeclGroup (bindFuncDecl tcc m) ds checkClassDecl :: Decl () -> SCM (Decl ()) -checkClassDecl (ClassDecl p cx cls tv ds) = do +checkClassDecl (ClassDecl p li cx cls tv ds) = do checkMethods (qualify cls) (concatMap methods ds) ds - ClassDecl p cx cls tv <$> checkTopDecls ds + ClassDecl p li cx cls tv <$> checkTopDecls ds checkClassDecl _ = internalError "SyntaxCheck.checkClassDecl: no class declaration" checkInstanceDecl :: Decl () -> SCM (Decl ()) -checkInstanceDecl (InstanceDecl p cx qcls ty ds) = do +checkInstanceDecl (InstanceDecl p li cx qcls ty ds) = do m <- getModuleIdent + vEnv <- getValueEnv tcEnv <- getTyConsEnv - checkMethods qcls (clsMethods m qcls tcEnv) ds - InstanceDecl p cx qcls ty <$> checkTopDecls ds + let clsMthds = clsMethods m qcls tcEnv + let orig = getOrigName m qcls tcEnv + let mthds = + if isLocalIdent m orig + then clsMthds + else filter (isFromCls orig m vEnv) clsMthds + checkMethods qcls mthds ds + mapM_ checkAmbiguousMethod ds + InstanceDecl p li cx qcls ty <$> checkTopDecls ds + where + isFromCls orig m vEnv f = case qualLookupValueUnique m (qualify f) vEnv of + [Value _ (Just cls) _ _] + | cls == orig -> True + _ -> False + checkInstanceDecl _ = internalError "SyntaxCheck.checkInstanceDecl: no instance declaration" +checkAmbiguousMethod :: Decl a -> SCM () +checkAmbiguousMethod (FunctionDecl _ _ f _) = do + m <- getModuleIdent + rename <- getRenameEnv + case lookupVar f rename of + rs1@(_:_:_) -> case qualLookupVar (qualifyWith m f) rename of + [] -> report $ errAmbiguousIdent rs1 (qualify f) + rs2@(_:_:_) -> report $ errAmbiguousIdent rs2 (qualify f) + _ -> return () + _ -> return () +checkAmbiguousMethod _ = + internalError "SyntaxCheck.checkAmbiguousMethod: no function declaration" + checkMethods :: QualIdent -> [Ident] -> [Decl a] -> SCM () checkMethods qcls ms ds = mapM_ (report . errUndefinedMethod qcls) $ filter (`notElem` ms) fs @@ -507,9 +541,9 @@ updateClassAndInstanceDecls :: [Decl a] -> [Decl a] -> [Decl a] -> [Decl a] updateClassAndInstanceDecls [] [] ds = ds -updateClassAndInstanceDecls (c:cs) is (ClassDecl _ _ _ _ _:ds) = +updateClassAndInstanceDecls (c:cs) is (ClassDecl _ _ _ _ _ _:ds) = c : updateClassAndInstanceDecls cs is ds -updateClassAndInstanceDecls cs (i:is) (InstanceDecl _ _ _ _ _:ds) = +updateClassAndInstanceDecls cs (i:is) (InstanceDecl _ _ _ _ _ _:ds) = i : updateClassAndInstanceDecls cs is ds updateClassAndInstanceDecls cs is (d:ds) = d : updateClassAndInstanceDecls cs is ds @@ -555,7 +589,7 @@ checkPrecedence _ Nothing = return Nothing checkPrecedence p (Just i) = do unless (0 <= i && i <= 9) $ report - $ errPrecedenceOutOfRange (spanInfo2Pos p) i + $ errPrecedenceOutOfRange p i return $ Just i checkVar' :: String -> Var a -> SCM (Var a) @@ -589,7 +623,7 @@ | not $ isDataConstr f env -> return left | k /= globalScopeId -> return right | null infos -> return left - | otherwise -> do report $ errToplevelPattern p + | otherwise -> do report $ errToplevelPattern pspi return right where f' = renameIdent f k infos = qualLookupVar (qualifyWith m f) env @@ -600,7 +634,7 @@ | not $ isDataConstr op env -> return left | k /= globalScopeId -> return right | null infos -> return left - | otherwise -> do report $ errToplevelPattern p + | otherwise -> do report $ errToplevelPattern pspi return right where op' = renameIdent op k infos = qualLookupVar (qualifyWith m op) env @@ -620,7 +654,6 @@ r -> do report $ errNonVariable "curried definition" f return $ r where (f, _) = flatLhs lhs - where p = spanInfo2Pos pspi checkOpLhs :: Integer -> RenameEnv -> (Pattern a -> Pattern a) -> Pattern a -> Either (Ident, Lhs a) (Pattern a) @@ -704,7 +737,7 @@ checkLhs p (OpLhs spi t1 op t2) = do let wrongCalls = concatMap (checkParenPattern (Just $ qualify op)) [t1,t2] unless (null wrongCalls) $ report $ errInfixWithoutParens - (getPosition op) wrongCalls + spi wrongCalls flip (OpLhs spi) op <$> checkPattern p t1 <*> checkPattern p t2 checkLhs p (ApLhs spi lhs ts) = ApLhs spi <$> checkLhs p lhs <*> mapM (checkPattern p) ts @@ -747,7 +780,7 @@ checkPattern _ (NegativePattern spi a l) = return $ NegativePattern spi a l checkPattern p (VariablePattern spi a v) - | isAnonId v = (VariablePattern spi a . renameIdent v) <$> newId + | isAnonId v = VariablePattern spi a . renameIdent v <$> newId | otherwise = checkConstructorPattern p spi (qualify v) [] checkPattern p (ConstructorPattern spi _ c ts) = checkConstructorPattern p spi c ts @@ -767,9 +800,9 @@ t' <- checkPattern p t banFPTerm "lazy pattern" p t' return (LazyPattern spi t') -checkPattern _ (FunctionPattern _ _ _ _) = internalError $ +checkPattern _ (FunctionPattern _ _ _ _) = internalError "SyntaxCheck.checkPattern: function pattern not defined" -checkPattern _ (InfixFuncPattern _ _ _ _ _) = internalError $ +checkPattern _ (InfixFuncPattern _ _ _ _ _) = internalError "SyntaxCheck.checkPattern: infix function pattern not defined" checkConstructorPattern :: SpanInfo -> SpanInfo -> QualIdent -> [Pattern ()] @@ -803,16 +836,11 @@ | null ts && not (isQualified c) = return $ VariablePattern spi () $ renameIdent (unqualify c) k -- (varIdent r) k | otherwise = do - let n = arity r - checkFuncPatsExtension (spanInfo2Pos p) + checkFuncPatsExtension p checkFuncPatCall r c ts' <- mapM (checkPattern p) ts mapM_ (checkFPTerm p) ts' - return $ if n' > n - then let (ts1, ts2) = splitAt n ts' - in genFuncPattAppl - (FunctionPattern spi () (qualVarIdent r) ts1) ts2 - else FunctionPattern spi () (qualVarIdent r) ts' + return $ FunctionPattern spi () (qualVarIdent r) ts' checkInfixPattern :: SpanInfo -> SpanInfo -> Pattern () -> QualIdent -> Pattern () -> SCM (Pattern ()) @@ -835,7 +863,7 @@ when (n /= 2) $ report $ errWrongArity op n 2 flip (InfixPattern spi ()) qop <$> checkPattern p t1 <*> checkPattern p t2 funcPattern r qop = do - checkFuncPatsExtension (spanInfo2Pos p) + checkFuncPatsExtension p checkFuncPatCall r qop ts' <- mapM (checkPattern p) [t1,t2] let [t1',t2'] = ts' @@ -871,10 +899,14 @@ -- Note: process decls first checkRhs :: Rhs () -> SCM (Rhs ()) -checkRhs (SimpleRhs spi e ds) = inNestedScope $ - flip (SimpleRhs spi) <$> checkDeclGroup bindVarDecl ds <*> checkExpr spi e -checkRhs (GuardedRhs spi es ds) = inNestedScope $ - flip (GuardedRhs spi) <$> checkDeclGroup bindVarDecl ds <*> mapM checkCondExpr es +checkRhs (SimpleRhs spi li e ds) = inNestedScope $ + flip (SimpleRhs spi li) <$> + checkDeclGroup bindVarDecl ds <*> + checkExpr spi e +checkRhs (GuardedRhs spi li es ds) = inNestedScope $ + flip (GuardedRhs spi li) <$> + checkDeclGroup bindVarDecl ds <*> + mapM checkCondExpr es checkCondExpr :: CondExpr () -> SCM (CondExpr ()) checkCondExpr (CondExpr spi g e) = CondExpr spi <$> checkExpr spi g <*> checkExpr spi e @@ -909,14 +941,14 @@ checkExpr p (RightSection spi op e) = RightSection spi <$> checkOp op <*> checkExpr p e checkExpr p (Lambda spi ts e) = inNestedScope $ checkLambda p spi ts e -checkExpr p (Let spi ds e) = inNestedScope $ - Let spi <$> checkDeclGroup bindVarDecl ds <*> checkExpr p e -checkExpr p (Do spi sts e) = withLocalEnv $ - Do spi <$> mapM (checkStatement "do sequence" p) sts <*> checkExpr p e +checkExpr p (Let spi li ds e) = inNestedScope $ + Let spi li <$> checkDeclGroup bindVarDecl ds <*> checkExpr p e +checkExpr p (Do spi li sts e) = withLocalEnv $ + Do spi li <$> mapM (checkStatement "do sequence" p) sts <*> checkExpr p e checkExpr p (IfThenElse spi e1 e2 e3) = IfThenElse spi <$> checkExpr p e1 <*> checkExpr p e2 <*> checkExpr p e3 -checkExpr p (Case spi ct e alts) = - Case spi ct <$> checkExpr p e <*> mapM checkAlt alts +checkExpr p (Case spi li ct e alts) = + Case spi li ct <$> checkExpr p e <*> mapM checkAlt alts checkLambda :: SpanInfo -> SpanInfo -> [Pattern ()] -> Expression () -> SCM (Expression ()) @@ -936,8 +968,8 @@ checkVariable spi a v -- anonymous free variable | isAnonId (unqualify v) = do - checkAnonFreeVarsExtension $ getPosition v - (\n -> Variable spi a $ updQualIdent id (flip renameIdent n) v) <$> newId + checkAnonFreeVarsExtension $ getSpanInfo v + (\n -> Variable spi a $ updQualIdent id (`renameIdent` n) v) <$> newId -- return $ Variable v -- normal variable | otherwise = do @@ -947,7 +979,9 @@ return $ Variable spi a v [Constr _ _] -> return $ Constructor spi a v [GlobalVar f _] -> addGlobalDep f >> return (Variable spi a v) - [LocalVar v' _] -> return $ Variable spi a $ qualify v' @> v + [LocalVar v' _] -> return $ Variable spi a + $ qualify + $ spanInfoLike v' (qidIdent v) [RecordLabel _ _] -> return $ Variable spi a v rs -> do m <- getModuleIdent @@ -956,7 +990,9 @@ return $ Variable spi a v [Constr _ _] -> return $ Constructor spi a v [GlobalVar f _] -> addGlobalDep f >> return (Variable spi a v) - [LocalVar v' _] -> return $ Variable spi a $ qualify v' @> v + [LocalVar v' _] -> return $ Variable spi a + $ qualify + $ spanInfoLike v' (qidIdent v) [RecordLabel _ _] -> return $ Variable spi a v rs' -> do report $ errAmbiguousIdent rs' v return $ Variable spi a v @@ -995,11 +1031,11 @@ -- * Because statements are processed list-wise, inNestedEnv can not be -- used as this nesting must be visible to following statements. checkStatement :: String -> SpanInfo -> Statement () -> SCM (Statement ()) -checkStatement _ p (StmtExpr spi e) = StmtExpr spi <$> checkExpr p e -checkStatement s p (StmtBind spi t e) = +checkStatement _ p (StmtExpr spi e) = StmtExpr spi <$> checkExpr p e +checkStatement s p (StmtBind spi t e) = flip (StmtBind spi) <$> checkExpr p e <*> (incNesting >> bindPattern s p t) -checkStatement _ _ (StmtDecl spi ds) = - StmtDecl spi <$> (incNesting >> checkDeclGroup bindVarDecl ds) +checkStatement _ _ (StmtDecl spi li ds) = + StmtDecl spi li <$> (incNesting >> checkDeclGroup bindVarDecl ds) bindPattern :: String -> SpanInfo -> Pattern () -> SCM (Pattern ()) bindPattern s p t = do @@ -1021,9 +1057,9 @@ banFPTerm s p (AsPattern _ _ t) = banFPTerm s p t banFPTerm s p (LazyPattern _ t) = banFPTerm s p t banFPTerm s p pat@(FunctionPattern _ _ _ _) - = report $ errUnsupportedFuncPattern s (spanInfo2Pos p) pat + = report $ errUnsupportedFuncPattern s p pat banFPTerm s p pat@(InfixFuncPattern _ _ _ _ _) - = report $ errUnsupportedFuncPattern s (spanInfo2Pos p) pat + = report $ errUnsupportedFuncPattern s p pat checkOp :: InfixOp a -> SCM (InfixOp a) checkOp op = do @@ -1101,9 +1137,10 @@ [l | (l, cs) <- zip ls css, c' `notElem` cs] _ -> internalError $ "Checks.SyntaxCheck.checkLabels: " ++ show c -checkLabels p Nothing ls css = - when (null (foldr1 intersect css)) - $ report $ errNoCommonCons (spanInfo2Pos p) ls +checkLabels p Nothing ls css + | not (null (foldr1 intersect css)) || + any null css = ok + | otherwise = report $ errNoCommonCons p ls checkField :: (a -> SCM a) -> Field a -> SCM (Field a) checkField check (Field p l x) = Field p l <$> check x @@ -1134,7 +1171,7 @@ -- it is necessary to sort the list of declarations. sortFuncDecls :: [Decl a] -> [Decl a] -sortFuncDecls decls = sortFD Set.empty [] decls +sortFuncDecls = sortFD Set.empty [] where sortFD _ res [] = reverse res sortFD env res (decl : decls') = case decl of @@ -1191,23 +1228,6 @@ qualVarIdent (LocalVar v _) = qualify v qualVarIdent _ = internalError "SyntaxCheck.qualVarIdent: no variable" -arity :: RenameInfo -> Int -arity (Constr _ n) = n -arity (GlobalVar _ n) = n -arity (LocalVar _ n) = n -arity (RecordLabel _ _) = 1 - --- Unlike expressions, constructor terms have no possibility to represent --- over-applications in functional patterns. Therefore it is necessary to --- transform them to nested function patterns using the prelude function --- apply. E.g., the function pattern (id id 10) is transformed to --- (apply (id id) 10). - -genFuncPattAppl :: Pattern () -> [Pattern ()] -> Pattern () -genFuncPattAppl term [] = term -genFuncPattAppl term (t:ts) - = FunctionPattern NoSpanInfo () qApplyId [genFuncPattAppl term ts, t] -- TODO FIXME major problem - checkFPTerm :: SpanInfo -> Pattern a -> SCM () checkFPTerm _ (LiteralPattern _ _ _) = ok checkFPTerm _ (NegativePattern _ _ _) = ok @@ -1219,7 +1239,7 @@ checkFPTerm p (ListPattern _ _ ts) = mapM_ (checkFPTerm p) ts checkFPTerm p (AsPattern _ _ t) = checkFPTerm p t checkFPTerm p t@(LazyPattern _ _) = - report $ errUnsupportedFPTerm "Lazy" (spanInfo2Pos p) t + report $ errUnsupportedFPTerm "Lazy" p t checkFPTerm p (RecordPattern _ _ _ fs) = mapM_ (checkFPTerm p) [ t | Field _ _ t <- fs ] checkFPTerm _ (FunctionPattern _ _ _ _) = ok -- do not check again @@ -1229,19 +1249,19 @@ -- Miscellaneous functions -- --------------------------------------------------------------------------- -checkFuncPatsExtension :: Position -> SCM () -checkFuncPatsExtension p = checkUsedExtension p +checkFuncPatsExtension :: SpanInfo -> SCM () +checkFuncPatsExtension spi = checkUsedExtension spi "Functional Patterns" FunctionalPatterns -checkAnonFreeVarsExtension :: Position -> SCM () -checkAnonFreeVarsExtension p = checkUsedExtension p +checkAnonFreeVarsExtension :: SpanInfo -> SCM () +checkAnonFreeVarsExtension spi = checkUsedExtension spi "Anonymous free variables" AnonFreeVars -checkUsedExtension :: Position -> String -> KnownExtension -> SCM () -checkUsedExtension pos msg ext = do +checkUsedExtension :: SpanInfo -> String -> KnownExtension -> SCM () +checkUsedExtension spi msg ext = do enabled <- hasExtension ext unless enabled $ do - report $ errMissingLanguageExtension pos msg ext + report $ errMissingLanguageExtension spi msg ext enableExtension ext -- to avoid multiple warnings typeArity :: TypeExpr -> Int @@ -1259,43 +1279,43 @@ -- Error messages -- --------------------------------------------------------------------------- -errUnsupportedFPTerm :: String -> Position -> Pattern a -> Message -errUnsupportedFPTerm s p pat = posMessage p $ text s +errUnsupportedFPTerm :: String -> SpanInfo -> Pattern a -> Message +errUnsupportedFPTerm s spi pat = spanInfoMessage spi $ text s <+> text "patterns are not supported inside a functional pattern." - $+$ ppPattern 0 pat + $+$ pPrintPrec 0 pat -errUnsupportedFuncPattern :: String -> Position -> Pattern a -> Message -errUnsupportedFuncPattern s p pat = posMessage p $ +errUnsupportedFuncPattern :: String -> SpanInfo -> Pattern a -> Message +errUnsupportedFuncPattern s spi pat = spanInfoMessage spi $ text "Functional patterns are not supported inside a" <+> text s <> dot - $+$ ppPattern 0 pat + $+$ pPrintPrec 0 pat errFuncPatNotGlobal :: QualIdent -> Message -errFuncPatNotGlobal f = posMessage f $ hsep $ map text +errFuncPatNotGlobal f = spanInfoMessage f $ hsep $ map text ["Function", escQualName f, "in functional pattern is not global"] errFuncPatCyclic :: QualIdent -> QualIdent -> Message -errFuncPatCyclic fp f = posMessage fp $ hsep $ map text +errFuncPatCyclic fp f = spanInfoMessage fp $ hsep $ map text [ "Function", escName $ unqualify fp, "used in functional pattern depends on" , escName $ unqualify f, " causing a cyclic dependency"] -errPrecedenceOutOfRange :: Position -> Integer -> Message -errPrecedenceOutOfRange p i = posMessage p $ hsep $ map text +errPrecedenceOutOfRange :: SpanInfo -> Integer -> Message +errPrecedenceOutOfRange spi i = spanInfoMessage spi $ hsep $ map text ["Precedence out of range:", show i] errUndefinedVariable :: QualIdent -> Message -errUndefinedVariable v = posMessage v $ hsep $ map text +errUndefinedVariable v = spanInfoMessage v $ hsep $ map text [escQualName v, "is undefined"] errUndefinedData :: QualIdent -> Message -errUndefinedData c = posMessage c $ hsep $ map text +errUndefinedData c = spanInfoMessage c $ hsep $ map text ["Undefined data constructor", escQualName c] errUndefinedLabel :: QualIdent -> Message -errUndefinedLabel l = posMessage l $ hsep $ map text +errUndefinedLabel l = spanInfoMessage l $ hsep $ map text ["Undefined record label", escQualName l] errUndefinedMethod :: QualIdent -> Ident -> Message -errUndefinedMethod qcls f = posMessage f $ hsep $ map text +errUndefinedMethod qcls f = spanInfoMessage f $ hsep $ map text [escName f, "is not a (visible) method of class", escQualName qcls] errAmbiguousIdent :: [RenameInfo] -> QualIdent -> Message @@ -1310,26 +1330,26 @@ errAmbiguousLabel = errAmbiguous "field label" errAmbiguous :: String -> [RenameInfo] -> QualIdent -> Message -errAmbiguous what rs qn = posMessage qn +errAmbiguous what rs qn = spanInfoMessage qn $ text "Ambiguous" <+> text what <+> text (escQualName qn) $+$ text "It could refer to:" $+$ nest 2 (vcat (map ppRenameInfo rs)) errDuplicateDefinition :: Ident -> Message -errDuplicateDefinition v = posMessage v $ hsep $ map text +errDuplicateDefinition v = spanInfoMessage v $ hsep $ map text ["More than one definition for", escName v] errDuplicateVariables :: [Ident] -> Message errDuplicateVariables [] = internalError "SyntaxCheck.errDuplicateVariables: empty list" -errDuplicateVariables (v:vs) = posMessage v $ +errDuplicateVariables (v:vs) = spanInfoMessage v $ text (escName v) <+> text "occurs more than one in pattern at:" $+$ nest 2 (vcat (map (ppPosition . getPosition) (v:vs))) errMultipleDataConstructor :: [Ident] -> Message errMultipleDataConstructor [] = internalError "SyntaxCheck.errMultipleDataDeclaration: empty list" -errMultipleDataConstructor (i:is) = posMessage i $ +errMultipleDataConstructor (i:is) = spanInfoMessage i $ text "Multiple definitions for data/record constructor" <+> text (escName i) <+> text "at:" $+$ nest 2 (vcat (map (ppPosition . getPosition) (i:is))) @@ -1337,7 +1357,7 @@ errMultipleDeclarations :: ModuleIdent -> [Ident] -> Message errMultipleDeclarations _ [] = internalError "SyntaxCheck.errMultipleDeclarations: empty list" -errMultipleDeclarations m (i:is) = posMessage i $ +errMultipleDeclarations m (i:is) = spanInfoMessage i $ text "Multiple declarations of" <+> text (escQualName (qualifyWith m i)) $+$ text "Declared at:" $+$ nest 2 (vcat (map (ppPosition . getPosition) (i:is))) @@ -1345,63 +1365,63 @@ errDuplicateTypeSig :: [Ident] -> Message errDuplicateTypeSig [] = internalError "SyntaxCheck.errDuplicateTypeSig: empty list" -errDuplicateTypeSig (v:vs) = posMessage v $ +errDuplicateTypeSig (v:vs) = spanInfoMessage v $ text "More than one type signature for" <+> text (escName v) <+> text "at:" $+$ nest 2 (vcat (map (ppPosition . getPosition) (v:vs))) errDuplicateLabel :: String -> QualIdent -> Message -errDuplicateLabel what l = posMessage l $ hsep $ map text +errDuplicateLabel what l = spanInfoMessage l $ hsep $ map text ["Field label", escQualName l, "occurs more than once in record", what] errNonVariable :: String -> Ident -> Message -errNonVariable what c = posMessage c $ hsep $ map text +errNonVariable what c = spanInfoMessage c $ hsep $ map text ["Data constructor", escName c, "in left hand side of", what] errNoBody :: Ident -> Message -errNoBody v = posMessage v $ hsep $ map text ["No body for", escName v] +errNoBody v = spanInfoMessage v $ hsep $ map text ["No body for", escName v] -errNoCommonCons :: Position -> [QualIdent] -> Message -errNoCommonCons p ls = posMessage p $ +errNoCommonCons :: SpanInfo -> [QualIdent] -> Message +errNoCommonCons spi ls = spanInfoMessage spi $ text "No constructor has all of these fields:" $+$ nest 2 (vcat (map (text . escQualName) ls)) errNoLabel :: QualIdent -> QualIdent -> Message -errNoLabel c l = posMessage l $ hsep $ map text +errNoLabel c l = spanInfoMessage l $ hsep $ map text [escQualName l, "is not a field label of constructor", escQualName c] errNoTypeSig :: Ident -> Message -errNoTypeSig f = posMessage f $ hsep $ map text +errNoTypeSig f = spanInfoMessage f $ hsep $ map text ["No type signature for external function", escName f] -errToplevelPattern :: Position -> Message -errToplevelPattern p = posMessage p $ text +errToplevelPattern :: SpanInfo -> Message +errToplevelPattern spi = spanInfoMessage spi $ text "Pattern declaration not allowed at top-level" errDifferentArity :: [Ident] -> Message errDifferentArity [] = internalError "SyntaxCheck.errDifferentArity: empty list" -errDifferentArity (i:is) = posMessage i $ +errDifferentArity (i:is) = spanInfoMessage i $ text "Equations for" <+> text (escName i) <+> text "have different arities" <+> text "at:" $+$ nest 2 (vcat (map (ppPosition . getPosition) (i:is))) errWrongArity :: QualIdent -> Int -> Int -> Message -errWrongArity c arity' argc = posMessage c $ hsep (map text +errWrongArity c arity' argc = spanInfoMessage c $ hsep (map text ["Data constructor", escQualName c, "expects", arguments arity']) <> comma <+> text "but is applied to" <+> text (show argc) where arguments 0 = "no arguments" arguments 1 = "1 argument" arguments n = show n ++ " arguments" -errMissingLanguageExtension :: Position -> String -> KnownExtension -> Message -errMissingLanguageExtension p what ext = posMessage p $ +errMissingLanguageExtension :: SpanInfo -> String -> KnownExtension -> Message +errMissingLanguageExtension spi what ext = spanInfoMessage spi $ text what <+> text "are not supported in standard Curry." $+$ nest 2 (text "Use flag or -X" <+> text (show ext) <+> text "to enable this extension.") -errInfixWithoutParens :: Position -> [(QualIdent, QualIdent)] -> Message -errInfixWithoutParens p calls = posMessage p $ +errInfixWithoutParens :: SpanInfo -> [(QualIdent, QualIdent)] -> Message +errInfixWithoutParens spi calls = spanInfoMessage spi $ text "Missing parens in infix patterns:" $+$ vcat (map showCall calls) where diff --git a/src/Checks/TypeCheck.hs b/src/Checks/TypeCheck.hs --- a/src/Checks/TypeCheck.hs +++ b/src/Checks/TypeCheck.hs @@ -43,12 +43,14 @@ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>), (<*>)) #endif -import Control.Monad.Extra ( (&&^), allM, filterM, foldM - , liftM, notM, replicateM, unless - , unlessM ) -import qualified Control.Monad.State as S (State, runState, gets, modify) -import Data.List (nub, nubBy, partition, sortBy) -import Data.Function (on) +import Control.Monad.Trans (lift) +import Control.Monad.Extra (allM, filterM, foldM, liftM, (&&^), + notM, replicateM, when, unless, unlessM) +import qualified Control.Monad.State as S + (State, StateT, get, gets, put, modify, + runState, evalStateT) +import Data.Function (on) +import Data.List (nub, nubBy, partition, sortBy, (\\)) import qualified Data.Map as Map (Map, empty, insert, lookup) import Data.Maybe (fromJust, fromMaybe, isJust) import qualified Data.Set.Extra as Set ( Set, concatMap, deleteMin, empty @@ -57,7 +59,6 @@ , toList, union, unions ) import Curry.Base.Ident -import Curry.Base.Position import Curry.Base.Pretty import Curry.Base.SpanInfo import Curry.Syntax @@ -66,7 +67,7 @@ import Base.CurryTypes import Base.Expr import Base.Kinds -import Base.Messages (Message, posMessage, internalError) +import Base.Messages (Message, spanInfoMessage, internalError) import Base.SCC import Base.TopEnv import Base.TypeExpansion @@ -134,9 +135,9 @@ (&&>) :: TCM () -> TCM () -> TCM () pre &&> suf = do errs <- pre >> S.gets errors - if null errs then suf else return () + when (null errs) suf -(>>-) :: TCM (a, b, c) -> (a -> b -> TCM a) -> TCM (a, c) +(>>-) :: Monad m => m (a, b, c) -> (a -> b -> m a) -> m (a, c) m >>- f = do (u, v, w) <- m u' <- f u v @@ -149,7 +150,7 @@ return (u, w, x) runTCM :: TCM a -> TcState -> (a, ValueEnv, [Message]) -runTCM tcm s = let (a, s') = S.runState tcm s +runTCM tcm ts = let (a, s') = S.runState tcm ts in (a, typeSubst s' `subst` valueEnv s', reverse $ errors s') getModuleIdent :: TCM ModuleIdent @@ -300,7 +301,7 @@ ok checkFieldLabel _ = ok -tcFieldLabel :: HasPosition p => [Ident] -> (Ident, p, TypeExpr) +tcFieldLabel :: HasSpanInfo p => [Ident] -> (Ident, p, TypeExpr) -> TCM (Ident, p, Type) tcFieldLabel tvs (l, p, ty) = do m <- getModuleIdent @@ -315,7 +316,7 @@ (x, y, z : map thd3 xyzs') : groupLabels xyzs'' where (xyzs', xyzs'') = partition ((x ==) . fst3) xyzs -tcFieldLabels :: HasPosition p => (Ident, p, [Type]) -> TCM () +tcFieldLabels :: HasSpanInfo p => (Ident, p, [Type]) -> TCM () tcFieldLabels (_, _, []) = return () tcFieldLabels (l, p, ty:tys) = unless (not (any (ty /=) tys)) $ do m <- getModuleIdent @@ -339,11 +340,11 @@ n = kindArity k labels = zip (concatMap recLabels cs) (concatMap recLabelTypes cs) clabels = [(l, constr l, ty) | (l, ty) <- labels] - constr l = map (qualifyLike tc) $ - [constrIdent c | c <- cs, l `elem` recLabels c] - sameLabel (l1,_,_) (l2,_,_) = l1 == l2 - bindData (RenamingType tc k (RecordConstr c [l] [lty])) vEnv' = - bindLabel m n (constrType' tc n) (l, [qc], lty) vEnv' + constr l = [qualifyLike tc (constrIdent c) + | c <- cs, l `elem` recLabels c] + sameLabel (l1, _, _) (l2, _, _) = l1 == l2 + bindData (RenamingType tc k (RecordConstr c [l] [lty])) vEnv' + = bindLabel m n (constrType' tc n) (l, [qc], lty) vEnv' where n = kindArity k qc = qualifyLike tc c @@ -371,17 +372,23 @@ bindClassMethods' m tcEnv vEnv = foldr (bindMethods . snd) vEnv $ localBindings tcEnv where - bindMethods (TypeClass _ _ ms) vEnv' = - foldr (bindClassMethod m) vEnv' ms - bindMethods _ vEnv' = vEnv' + bindMethods (TypeClass cls _ ms) vEnv' = + foldr (bindClassMethod m cls) vEnv' ms + bindMethods _ vEnv' = + vEnv' -- Since the implementations of class methods can differ in their arity, -- we assume an arity of 0 when we enter one into the value environment. -bindClassMethod :: ModuleIdent -> ClassMethod -> ValueEnv -> ValueEnv -bindClassMethod m (ClassMethod f _ pty) = - bindGlobalInfo (\qc tySc -> Value qc True 0 tySc) m f (typeScheme pty) +bindClassMethod :: ModuleIdent -> QualIdent -> ClassMethod -> ValueEnv + -> ValueEnv +bindClassMethod m cls (ClassMethod f _ ty) = + bindGlobalInfo (\qc tySc -> Value qc (Just cls) 0 tySc) m f (typeScheme ty) +-- ----------------------------------------------------------------------------- +-- Default Types +-- ----------------------------------------------------------------------------- + -- Default Types: -- The list of default types is given either by a default declaration in -- the source code or defaults to the predefined list of numeric data types. @@ -409,30 +416,29 @@ bindTypeSig = Map.insert bindTypeSigs :: Decl a -> SigEnv -> SigEnv -bindTypeSigs (TypeSig _ vs qty) env = - foldr (flip bindTypeSig qty) env vs -bindTypeSigs _ env = env +bindTypeSigs (TypeSig _ vs ty) env = foldr (`bindTypeSig` ty) env vs +bindTypeSigs _ env = env lookupTypeSig :: Ident -> SigEnv -> Maybe QualTypeExpr lookupTypeSig = Map.lookup -- Declaration groups: -- Before type checking a group of declarations, a dependency analysis is --- performed and the declaration group is eventually transformed into --- nested declaration groups which are checked separately. Within each --- declaration group, first the value environment is extended with new --- bindings for all variables and functions defined in the group. Next, --- types are inferred for all declarations without an explicit type signature --- and the inferred types are then generalized. Finally, the types of all --- explicitly typed declarations are checked. +-- performed and the declaration group is eventually transformed into nested +-- declaration groups which are checked separately. Within each declaration +-- group, first the value environment is extended with new bindings for all +-- variables and functions defined in the group. Next, types are inferred for +-- all declarations without an explicit type signature and the inferred types +-- are then generalized. Finally, the types of all explicitly typed declarations +-- are checked. --- Within a group of mutually recursive declarations, all type variables --- that appear in the types of the variables defined in the group and --- whose type cannot be generalized must not be generalized in the other --- declarations of that group as well. +-- Within a group of mutually recursive declarations, all type variables that +-- appear in the types of the variables defined in the group and whose type +-- cannot be generalized must not be generalized in the other declarations of +-- that group as well. tcDecls :: [Decl a] -> TCM (PredSet, [Decl PredType]) -tcDecls = liftM (fmap fromPDecls) . tcPDecls . toPDecls +tcDecls = fmap (fmap fromPDecls) . tcPDecls . toPDecls tcPDecls :: [PDecl a] -> TCM (PredSet, [PDecl PredType]) tcPDecls pds = withLocalSigEnv $ do @@ -450,8 +456,15 @@ tcPDeclGroup ps [(i, FreeDecl p fvs)] = do vs <- mapM (tcDeclVar False) (bv fvs) m <- getModuleIdent - modifyValueEnv $ flip (bindVars m) vs - return (ps, [(i, FreeDecl p (map (\(v, _, ForAll _ pty) -> Var pty v) vs))]) + (vs', ps') <- unzip <$> mapM addDataPred vs + modifyValueEnv $ flip (bindVars m) vs' + let d = FreeDecl p (map (\(v, _, ForAll _ ty) -> Var ty v) vs') + return (ps `Set.union` Set.unions ps', [(i, d)]) + where + addDataPred (idt, n, ForAll ids ty1) = do + (ps2, ty2) <- freshDataType + ps' <- unify idt "free variable" (ppIdent idt) emptyPredSet (unpredType ty1) ps2 ty2 + return ((idt, n, ForAll ids ty1), ps') tcPDeclGroup ps pds = do vEnv <- getValueEnv vss <- mapM (tcDeclVars . snd) pds @@ -461,7 +474,7 @@ let (impPds, expPds) = partitionPDecls sigs pds (ps', impPds') <- mapAccumM tcPDecl ps impPds theta <- getTypeSubst - tvs <- liftM (concatMap $ typeVars . subst theta . fst) $ + tvs <- concatMap (typeVars . subst theta . fst) <$> filterM (notM . isNonExpansive . snd . snd) impPds' let fvs = foldr Set.insert (fvEnv (subst theta vEnv)) tvs (gps, lps) = splitPredSet fvs ps' @@ -482,10 +495,10 @@ typeSig _ = Nothing bindVars :: ModuleIdent -> ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv -bindVars m = foldr $ uncurry3 $ flip (bindFun m) False +bindVars m = foldr $ uncurry3 $ flip (bindFun m) Nothing rebindVars :: ModuleIdent -> ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv -rebindVars m = foldr $ uncurry3 $ flip (rebindFun m) False +rebindVars m = foldr $ uncurry3 $ flip (rebindFun m) Nothing tcDeclVars :: Decl a -> TCM [(Ident, Int, TypeScheme)] tcDeclVars (FunctionDecl _ _ f eqs) = do @@ -523,7 +536,7 @@ tcPDecl ps (i, d@(PatternDecl p t rhs)) = do (ps', ty', t') <- tcPattern p t (ps'', rhs') <- tcRhs rhs >>- - unifyDecl p "pattern declaration" (ppDecl d) (ps `Set.union` ps') ty' + unifyDecl p "pattern declaration" (pPrint d) (ps `Set.union` ps') ty' return (ps'', (ty', (i, PatternDecl p t' rhs'))) tcPDecl _ _ = internalError "TypeCheck.tcPDecl" @@ -541,17 +554,17 @@ tcEquation :: Type -> PredSet -> Equation a -> TCM (PredSet, Equation PredType) tcEquation ty ps eqn@(Equation p lhs rhs) = - tcEqn p lhs rhs >>- unifyDecl p "equation" (ppEquation eqn) ps ty + tcEqn p lhs rhs >>- unifyDecl p "equation" (pPrint eqn) ps ty tcEqn :: SpanInfo -> Lhs a -> Rhs a -> TCM (PredSet, Type, Equation PredType) tcEqn p lhs rhs = do (ps, tys, lhs', ps', ty, rhs') <- withLocalValueEnv $ do bindLambdaVars lhs - (ps, tys, lhs') <- tcLhs p lhs + (ps, tys, lhs') <- S.evalStateT (tcLhs p lhs) Set.empty (ps', ty, rhs') <- tcRhs rhs return (ps, tys, lhs', ps', ty, rhs') - ps'' <- reducePredSet p "equation" (ppEquation (Equation p lhs' rhs')) + ps'' <- reducePredSet p "equation" (pPrint (Equation p lhs' rhs')) (ps `Set.union` ps') return (ps'', foldr TypeArrow ty tys, Equation p lhs' rhs') @@ -566,7 +579,7 @@ ty <- freshTypeVar return (v, 0, monoType ty) -unifyDecl :: HasPosition p => p -> String -> Doc -> PredSet -> Type -> PredSet +unifyDecl :: HasSpanInfo p => p -> String -> Doc -> PredSet -> Type -> PredSet -> Type -> TCM PredSet unifyDecl p what doc psLhs tyLhs psRhs tyRhs = do @@ -590,7 +603,7 @@ _ -> return ps defaultPDecl _ _ _ _ = internalError "TypeCheck.defaultPDecl" -applyDefaultsDecl :: HasPosition p => p -> String -> Doc -> Set.Set Int +applyDefaultsDecl :: HasSpanInfo p => p -> String -> Doc -> Set.Set Int -> PredSet -> Type -> TCM PredSet applyDefaultsDecl p what doc fvs ps ty = do theta <- getTypeSubst @@ -648,13 +661,13 @@ pty <- expandPoly qty unlessM (checkTypeSig pty tySc) $ do m <- getModuleIdent - report $ errTypeSigTooGeneral p m (text "Function:" <+> ppIdent f) qty tySc + report $ errTypeSigTooGeneral m (text "Function:" <+> ppIdent f) qty tySc return (ps, (i, FunctionDecl p pty f eqs)) checkPDeclType qty ps tySc (i, PatternDecl p (VariablePattern spi _ v) rhs) = do pty <- expandPoly qty unlessM (checkTypeSig pty tySc) $ do m <- getModuleIdent - report $ errTypeSigTooGeneral p m (text "Variable:" <+> ppIdent v) qty tySc + report $ errTypeSigTooGeneral m (text "Variable:" <+> ppIdent v) qty tySc return (ps, (i, PatternDecl p (VariablePattern spi pty v) rhs)) checkPDeclType _ _ _ _ = internalError "TypeCheck.checkPDeclType" @@ -747,14 +760,14 @@ internalError "TypeCheck.isNonExpansive: declaration" instance Binding (Rhs a) where - isNonExpansive (SimpleRhs _ e ds) = withLocalValueEnv $ do + isNonExpansive (GuardedRhs _ _ _ _) = return False + isNonExpansive (SimpleRhs _ _ e ds) = withLocalValueEnv $ do m <- getModuleIdent tcEnv <- getTyConsEnv clsEnv <- getClassEnv sigs <- getSigEnv modifyValueEnv $ flip (foldr (bindDeclArity m tcEnv clsEnv sigs)) ds isNonExpansive e &&^ isNonExpansive ds - isNonExpansive (GuardedRhs _ _ _) = return False -- A record construction is non-expansive only if all field labels are present. @@ -778,21 +791,21 @@ isNonExpansive' _ (Record _ _ c fs) = do m <- getModuleIdent vEnv <- getValueEnv - liftM ((length (constrLabels m c vEnv) == length fs) &&) (isNonExpansive fs) -isNonExpansive' _ (Tuple _ es) = isNonExpansive es -isNonExpansive' _ (List _ _ es) = isNonExpansive es -isNonExpansive' n (Apply _ f e) = - isNonExpansive' (n + 1) f &&^ isNonExpansive e -isNonExpansive' n (InfixApply _ e1 op e2) = - isNonExpansive' (n + 2) (infixOp op) &&^ isNonExpansive e1 &&^ - isNonExpansive e2 -isNonExpansive' n (LeftSection _ e op) = - isNonExpansive' (n + 1) (infixOp op) &&^ isNonExpansive e -isNonExpansive' n (Lambda _ ts e) = withLocalValueEnv $ do + fmap ((length (constrLabels m c vEnv) == length fs) &&) (isNonExpansive fs) +isNonExpansive' _ (Tuple _ es) = isNonExpansive es +isNonExpansive' _ (List _ _ es) = isNonExpansive es +isNonExpansive' n (Apply _ f e) = isNonExpansive' (n + 1) f + &&^ isNonExpansive e +isNonExpansive' n (InfixApply _ e1 op e2) + = isNonExpansive' (n + 2) (infixOp op) &&^ isNonExpansive e1 + &&^ isNonExpansive e2 +isNonExpansive' n (LeftSection _ e op) = isNonExpansive' (n + 1) (infixOp op) + &&^ isNonExpansive e +isNonExpansive' n (Lambda _ ts e) = withLocalValueEnv $ do modifyValueEnv $ flip (foldr bindVarArity) (bv ts) - liftM ((n < length ts) ||) - (liftM ((all isVariablePattern ts) &&) (isNonExpansive' (n - length ts) e)) -isNonExpansive' n (Let _ ds e) = withLocalValueEnv $ do + fmap (((n < length ts) ||) . (all isVariablePattern ts &&)) + (isNonExpansive' (n - length ts) e) +isNonExpansive' n (Let _ _ ds e) = withLocalValueEnv $ do m <- getModuleIdent tcEnv <- getTyConsEnv clsEnv <- getClassEnv @@ -825,7 +838,7 @@ bindVarArity v = bindArity v 0 bindArity :: Ident -> Int -> ValueEnv -> ValueEnv -bindArity v n = bindTopEnv v (Value (qualify v) False n undefined) +bindArity v n = bindTopEnv v (Value (qualify v) Nothing n undefined) -- Class and instance declarations: -- When checking method implementations in class and instance @@ -838,34 +851,34 @@ -- instance declarations because the instance type must be substituted -- for the type variable used in the type class declaration. -- --- When checking inferred method types against their expected types, we --- have to be careful because the class' type variable is always assigned --- index 0 in the method types recorded in the value environment. However, --- in the inferred type scheme returned from 'tcMethodDecl', type variables --- are assigned indices in the order of their occurrence. In order to avoid --- incorrectly reporting errors when the type class variable is not the first --- variable that appears in a method's type, 'tcInstMethodDecl' normalizes --- the expected method type before applying 'checkInstMethodType' to it and --- 'checkClassMethodType' uses 'expandPolyType' instead of 'expandMethodType' --- in order to convert the method's type signature. Unfortunately, this means --- that the compiler has to add the class constraint explicitly to the type --- signature. +-- When checking inferred method types against their expected types, we have to +-- be careful because the class' type variable is always assigned index 0 in +-- the method types recorded in the value environment. However, in the inferred +-- type scheme returned from 'tcMethodDecl', type variables are assigned +-- indices in the order of their occurrence. In order to avoid incorrectly +-- reporting errors when the type class variable is not the first variable that +-- appears in a method's type, 'tcInstanceMethodPDecl' normalizes the expected +-- method type before applying 'checkInstMethodType' to it. Unfortunately, this +-- means that the compiler has to add the class constraint explicitly to the +-- type signature. tcTopPDecl :: PDecl a -> TCM (PDecl PredType) -tcTopPDecl (i, DataDecl p tc tvs cs clss) = - return (i, DataDecl p tc tvs cs clss) -tcTopPDecl (i, ExternalDataDecl p tc tvs) = - return (i, ExternalDataDecl p tc tvs) -tcTopPDecl (i, NewtypeDecl p tc tvs nc clss) = - return (i, NewtypeDecl p tc tvs nc clss) -tcTopPDecl (i, TypeDecl p tc tvs ty) = return (i, TypeDecl p tc tvs ty) -tcTopPDecl (i, DefaultDecl p tys) = return (i, DefaultDecl p tys) -tcTopPDecl (i, ClassDecl p cx cls tv ds) = withLocalSigEnv $ do +tcTopPDecl (i, DataDecl p tc tvs cs clss) + = return (i, DataDecl p tc tvs cs clss) +tcTopPDecl (i, ExternalDataDecl p tc tvs) + = return (i, ExternalDataDecl p tc tvs) +tcTopPDecl (i, NewtypeDecl p tc tvs nc clss) + = return (i, NewtypeDecl p tc tvs nc clss) +tcTopPDecl (i, TypeDecl p tc tvs ty) + = return (i, TypeDecl p tc tvs ty) +tcTopPDecl (i, DefaultDecl p tys) + = return (i, DefaultDecl p tys) +tcTopPDecl (i, ClassDecl p li cx cls tv ds) = withLocalSigEnv $ do + let (vpds, opds) = partition (isValueDecl . snd) $ toPDecls ds setSigEnv $ foldr (bindTypeSigs . snd) emptySigEnv opds vpds' <- mapM (tcClassMethodPDecl (qualify cls) tv) vpds - return (i, ClassDecl p cx cls tv $ fromPDecls $ map untyped opds ++ vpds') - where (vpds, opds) = partition (isValueDecl . snd) $ toPDecls ds -tcTopPDecl (i, InstanceDecl p cx qcls ty ds) = do + return (i, ClassDecl p li cx cls tv $ fromPDecls $ map untyped opds ++ vpds') +tcTopPDecl (i, InstanceDecl p li cx qcls ty ds) = do tcEnv <- getTyConsEnv pty <- expandPoly $ QualTypeExpr NoSpanInfo cx ty mid <- getModuleIdent @@ -873,14 +886,14 @@ clsQual = head $ filter isQualified $ reverseLookupByOrigName origCls tcEnv qQualCls = qualQualify (fromJust $ qidModule clsQual) qcls vpds' <- mapM (tcInstanceMethodPDecl qQualCls pty) vpds - return (i, InstanceDecl p cx qcls ty $ fromPDecls $ map untyped opds ++ vpds') + return (i,InstanceDecl p li cx qcls ty $ fromPDecls $ map untyped opds++vpds') where (vpds, opds) = partition (isValueDecl . snd) $ toPDecls ds -tcTopPDecl _ = internalError "Checks.TypeCheck.tcTopDecl" +tcTopPDecl _ = internalError "TypeCheck.tcTopDecl" tcClassMethodPDecl :: QualIdent -> Ident -> PDecl a -> TCM (PDecl PredType) tcClassMethodPDecl qcls tv pd@(_, FunctionDecl _ _ f _) = do methTy <- classMethodType qualify f - (tySc, pd') <- tcMethodPDecl methTy pd + (tySc, pd') <- tcMethodPDecl qcls methTy pd sigs <- getSigEnv let QualTypeExpr spi cx ty = fromJust $ lookupTypeSig f sigs qty = QualTypeExpr spi @@ -892,36 +905,36 @@ -> TCM (PDecl PredType) tcInstanceMethodPDecl qcls pty pd@(_, FunctionDecl _ _ f _) = do methTy <- instMethodType (qualifyLike qcls) pty f - (tySc, pd') <- tcMethodPDecl (typeScheme methTy) pd + (tySc, pd') <- tcMethodPDecl qcls (typeScheme methTy) pd checkInstMethodType (normalize 0 methTy) tySc pd' tcInstanceMethodPDecl _ _ _ = internalError "TypeCheck.tcInstanceMethodPDecl" -tcMethodPDecl :: TypeScheme -> PDecl a -> TCM (TypeScheme, PDecl PredType) -tcMethodPDecl tySc (i, FunctionDecl p _ f eqs) = withLocalValueEnv $ do +tcMethodPDecl :: QualIdent -> TypeScheme -> PDecl a -> TCM (TypeScheme, PDecl PredType) +tcMethodPDecl qcls tySc (i, FunctionDecl p _ f eqs) = withLocalValueEnv $ do m <- getModuleIdent - modifyValueEnv $ bindFun m f True (eqnArity $ head eqs) tySc + modifyValueEnv $ bindFun m f (Just qcls) (eqnArity $ head eqs) tySc (ps, (ty, pd)) <- tcFunctionPDecl i emptyPredSet tySc p f eqs theta <- getTypeSubst return (gen Set.empty ps $ subst theta ty, pd) -tcMethodPDecl _ _ = internalError "TypeCheck.tcMethodPDecl" +tcMethodPDecl _ _ _ = internalError "TypeCheck.tcMethodPDecl" checkClassMethodType :: QualTypeExpr -> TypeScheme -> PDecl PredType -> TCM (PDecl PredType) -checkClassMethodType qty tySc pd@(_, FunctionDecl p _ f _) = do +checkClassMethodType qty tySc pd@(_, FunctionDecl _ _ f _) = do pty <- expandPoly qty unlessM (checkTypeSig pty tySc) $ do m <- getModuleIdent - report $ errTypeSigTooGeneral p m (text "Method:" <+> ppIdent f) qty tySc + report $ errTypeSigTooGeneral m (text "Method:" <+> ppIdent f) qty tySc return pd checkClassMethodType _ _ _ = internalError "TypeCheck.checkClassMethodType" checkInstMethodType :: PredType -> TypeScheme -> PDecl PredType -> TCM (PDecl PredType) -checkInstMethodType pty tySc pd@(_, FunctionDecl p _ f _) = do +checkInstMethodType pty tySc pd@(_, FunctionDecl _ _ f _) = do unlessM (checkTypeSig pty tySc) $ do m <- getModuleIdent report $ - errMethodTypeTooSpecific p m (text "Method:" <+> ppIdent f) pty tySc + errMethodTypeTooSpecific f m (text "Method:" <+> ppIdent f) pty tySc return pd checkInstMethodType _ _ _ = internalError "TypeCheck.checkInstMethodType" @@ -951,7 +964,7 @@ Just (QualTypeExpr _ _ ty) -> do m <- getModuleIdent PredType _ ty' <- expandPoly $ QualTypeExpr NoSpanInfo [] ty - modifyValueEnv $ bindFun m f False (arrowArity ty') (polyType ty') + modifyValueEnv $ bindFun m f Nothing (arrowArity ty') (polyType ty') return ty' -- Patterns and Expressions: @@ -963,24 +976,24 @@ tcLiteral :: Bool -> Literal -> TCM (PredSet, Type) tcLiteral _ (Char _) = return (emptyPredSet, charType) tcLiteral poly (Int _) - | poly = freshNumType - | otherwise = liftM ((,) emptyPredSet) (freshConstrained numTypes) + | poly = freshNumType + | otherwise = fmap ((,) emptyPredSet) (freshConstrained numTypes) tcLiteral poly (Float _) - | poly = freshFractionalType - | otherwise = liftM ((,) emptyPredSet) (freshConstrained fractionalTypes) -tcLiteral _ (String _) = return (emptyPredSet, stringType) + | poly = freshFractionalType + | otherwise = fmap ((,) emptyPredSet) (freshConstrained fractionalTypes) +tcLiteral _ (String _) = return (emptyPredSet, stringType) -tcLhs :: HasPosition p => p -> Lhs a -> TCM (PredSet, [Type], Lhs PredType) +tcLhs :: HasSpanInfo p => p -> Lhs a -> PTCM (PredSet, [Type], Lhs PredType) tcLhs p (FunLhs spi f ts) = do - (pss, tys, ts') <- liftM unzip3 $ mapM (tcPattern p) ts + (pss, tys, ts') <- unzip3 <$> mapM (tcPatternHelper p) ts return (Set.unions pss, tys, FunLhs spi f ts') tcLhs p (OpLhs spi t1 op t2) = do - (ps1, ty1, t1') <- tcPattern p t1 - (ps2, ty2, t2') <- tcPattern p t2 + (ps1, ty1, t1') <- tcPatternHelper p t1 + (ps2, ty2, t2') <- tcPatternHelper p t2 return (ps1 `Set.union` ps2, [ty1, ty2], OpLhs spi t1' op t2') tcLhs p (ApLhs spi lhs ts) = do (ps, tys1, lhs') <- tcLhs p lhs - (pss, tys2, ts') <- liftM unzip3 $ mapM (tcPattern p) ts + (pss, tys2, ts') <- unzip3 <$> mapM (tcPatternHelper p) ts return (Set.unions (ps:pss), tys1 ++ tys2, ApLhs spi lhs' ts') -- When computing the type of a variable in a pattern, we ignore the @@ -990,129 +1003,161 @@ -- checked as constructor and functional patterns, respectively, resulting -- in slighty misleading error messages if the type check fails. -tcPattern :: HasPosition p => p -> Pattern a +-- We also keep track of already used variables, +-- in order to add a Data constraint for non-linear patterns + +tcPattern :: HasSpanInfo p => p -> Pattern a -> TCM (PredSet, Type, Pattern PredType) -tcPattern _ (LiteralPattern spi _ l) = do - (ps, ty) <- tcLiteral False l +tcPattern = tcPatternWith Set.empty + +tcPatternWith :: HasSpanInfo p => Set.Set Ident -> p -> Pattern a + -> TCM (PredSet, Type, Pattern PredType) +tcPatternWith s p pt = S.evalStateT (tcPatternHelper p pt) s + +type PTCM a = S.StateT (Set.Set Ident) TCM a + +tcPatternHelper :: HasSpanInfo p => p -> Pattern a + -> PTCM (PredSet, Type, Pattern PredType) +tcPatternHelper _ (LiteralPattern spi _ l) = do + (ps, ty) <- lift $ tcLiteral False l return (ps, ty, LiteralPattern spi (predType ty) l) -tcPattern _ (NegativePattern spi _ l) = do - (ps, ty) <- tcLiteral False l +tcPatternHelper _ (NegativePattern spi _ l) = do + (ps, ty) <- lift $ tcLiteral False l return (ps, ty, NegativePattern spi (predType ty) l) -tcPattern _ (VariablePattern spi _ v) = do - vEnv <- getValueEnv - (_, ty) <- inst (varType v vEnv) - return (emptyPredSet, ty, VariablePattern spi (predType ty) v) -tcPattern p t@(ConstructorPattern spi _ c ts) = do - m <- getModuleIdent - vEnv <- getValueEnv - (ps, (tys, ty')) <- liftM (fmap arrowUnapply) (skol (constrType m c vEnv)) - (ps', ts') <- mapAccumM (uncurry . tcPatternArg p "pattern" (ppPattern 0 t)) +tcPatternHelper _ (VariablePattern spi _ v) = do + vEnv <- lift getValueEnv + (_, ty) <- lift $ inst (varType v vEnv) + used <- S.get + ps <- if Set.member v used + then return (Set.singleton (Pred qDataId ty)) + else S.put (Set.insert v used) >> return Set.empty + return (ps, ty, VariablePattern spi (predType ty) v) +tcPatternHelper p t@(ConstructorPattern spi _ c ts) = do + m <- lift getModuleIdent + vEnv <- lift getValueEnv + (ps, (tys, ty')) <- fmap arrowUnapply <$> lift (skol (constrType m c vEnv)) + (ps', ts') <- mapAccumM (uncurry . ptcPatternArg p "pattern" (pPrintPrec 0 t)) ps (zip tys ts) return (ps', ty', ConstructorPattern spi (predType ty') c ts') -tcPattern p (InfixPattern spi a t1 op t2) = do - (ps, ty, t') <- tcPattern p (ConstructorPattern NoSpanInfo a op [t1, t2]) +tcPatternHelper p (InfixPattern spi a t1 op t2) = do + (ps, ty, t') <- tcPatternHelper p (ConstructorPattern NoSpanInfo a op [t1,t2]) let ConstructorPattern _ a' op' [t1', t2'] = t' return (ps, ty, InfixPattern spi a' t1' op' t2') -tcPattern p (ParenPattern spi t) = do - (ps, ty, t') <- tcPattern p t +tcPatternHelper p (ParenPattern spi t) = do + (ps, ty, t') <- tcPatternHelper p t return (ps, ty, ParenPattern spi t') -tcPattern _ t@(RecordPattern spi _ c fs) = do - m <- getModuleIdent - vEnv <- getValueEnv - (ps, ty) <- liftM (fmap arrowBase) (skol (constrType m c vEnv)) - (ps', fs') <- mapAccumM (tcField tcPattern "pattern" - (\t' -> ppPattern 0 t $-$ text "Term:" <+> ppPattern 0 t') ty) ps fs +tcPatternHelper _ t@(RecordPattern spi _ c fs) = do + m <- lift getModuleIdent + vEnv <- lift getValueEnv + (ps, ty) <- fmap arrowBase <$> lift (skol (constrType m c vEnv)) + -- tcField does not support passing "used" variables, thus we do it by hand + used <- S.get + (ps', fs') <- lift $ mapAccumM (tcField (tcPatternWith used) "pattern" + (\t' -> pPrintPrec 0 t $-$ text "Term:" <+> pPrintPrec 0 t') ty) ps fs + S.put $ foldr Set.insert used $ concatMap bv fs return (ps', ty, RecordPattern spi (predType ty) c fs') -tcPattern p (TuplePattern spi ts) = do - (pss, tys, ts') <- liftM unzip3 $ mapM (tcPattern p) ts +tcPatternHelper p (TuplePattern spi ts) = do + (pss, tys, ts') <- unzip3 <$> mapM (tcPatternHelper p) ts return (Set.unions pss, tupleType tys, TuplePattern spi ts') -tcPattern p t@(ListPattern spi _ ts) = do - ty <- freshTypeVar - (ps, ts') <- mapAccumM (flip (tcPatternArg p "pattern" (ppPattern 0 t)) ty) +tcPatternHelper p t@(ListPattern spi _ ts) = do + ty <- lift freshTypeVar + (ps, ts') <- mapAccumM (flip (ptcPatternArg p "pattern" (pPrintPrec 0 t)) ty) emptyPredSet ts return (ps, listType ty, ListPattern spi (predType $ listType ty) ts') -tcPattern p t@(AsPattern spi v t') = do - vEnv <- getValueEnv - (_, ty) <- inst (varType v vEnv) - (ps, t'') <- tcPattern p t' >>- - unify p "pattern" (ppPattern 0 t) emptyPredSet ty - return (ps, ty, AsPattern spi v t'') -tcPattern p (LazyPattern spi t) = do - (ps, ty, t') <- tcPattern p t +tcPatternHelper p t@(AsPattern spi v t') = do + vEnv <- lift getValueEnv + (_, ty) <- lift $ inst (varType v vEnv) + used <- S.get + ps <- if Set.member v used + then return (Set.singleton (Pred qDataId ty)) + else S.put (Set.insert v used) >> return Set.empty + (ps'', t'') <- tcPatternHelper p t' >>- + (\ps' ty' -> lift $ unify p "pattern" (pPrintPrec 0 t) ps ty ps' ty') + return (ps'', ty, AsPattern spi v t'') +tcPatternHelper p (LazyPattern spi t) = do + (ps, ty, t') <- tcPatternHelper p t return (ps, ty, LazyPattern spi t') -tcPattern p t@(FunctionPattern spi _ f ts) = do - m <- getModuleIdent - vEnv <- getValueEnv - (ps, ty) <- inst (funType m f vEnv) - tcFuncPattern p spi (ppPattern 0 t) f id ps ty ts -tcPattern p (InfixFuncPattern spi a t1 op t2) = do - (ps, ty, t') <- tcPattern p (FunctionPattern spi a op [t1, t2]) +tcPatternHelper p t@(FunctionPattern spi _ f ts) = do + m <- lift getModuleIdent + vEnv <- lift getValueEnv + (ps, ty) <- lift $ inst (funType m f vEnv) + -- insert all + S.modify (flip (foldr Set.insert) (bv t)) + tcFuncPattern p spi (pPrintPrec 0 t) f id ps ty ts +tcPatternHelper p (InfixFuncPattern spi a t1 op t2) = do + (ps, ty, t') <- tcPatternHelper p (FunctionPattern spi a op [t1, t2]) let FunctionPattern _ a' op' [t1', t2'] = t' return (ps, ty, InfixFuncPattern spi a' t1' op' t2') -tcFuncPattern :: HasPosition p => p -> SpanInfo -> Doc -> QualIdent +tcFuncPattern :: HasSpanInfo p => p -> SpanInfo -> Doc -> QualIdent -> ([Pattern PredType] -> [Pattern PredType]) -> PredSet -> Type -> [Pattern a] - -> TCM (PredSet, Type, Pattern PredType) + -> PTCM (PredSet, Type, Pattern PredType) tcFuncPattern _ spi _ f ts ps ty [] = - return (ps, ty, FunctionPattern spi (predType ty) f (ts [])) + return (Set.insert (Pred qDataId ty) ps, ty, FunctionPattern spi (predType ty) f (ts [])) tcFuncPattern p spi doc f ts ps ty (t':ts') = do - (alpha, beta) <- - tcArrow p "functional pattern" (doc $-$ text "Term:" <+> ppPattern 0 t) ty - (ps', t'') <- tcPatternArg p "functional pattern" doc ps alpha t' + (alpha, beta) <- lift $ + tcArrow p "functional pattern" (doc $-$ text "Term:" <+> pPrintPrec 0 t) ty + (ps', t'') <- ptcPatternArg p "functional pattern" doc ps alpha t' tcFuncPattern p spi doc f (ts . (t'' :)) ps' beta ts' where t = FunctionPattern spi (predType ty) f (ts []) -tcPatternArg :: HasPosition p => p -> String -> Doc -> PredSet -> Type +ptcPatternArg :: HasSpanInfo p => p -> String -> Doc -> PredSet -> Type + -> Pattern a -> PTCM (PredSet, Pattern PredType) +ptcPatternArg p what doc ps ty t = + tcPatternHelper p t >>- + (\ps' ty' -> lift $ + unify p what (doc $-$ text "Term:" <+> pPrintPrec 0 t) ps ty ps' ty') + +tcPatternArg :: HasSpanInfo p => p -> String -> Doc -> PredSet -> Type -> Pattern a -> TCM (PredSet, Pattern PredType) tcPatternArg p what doc ps ty t = tcPattern p t >>- - unify p what (doc $-$ text "Term:" <+> ppPattern 0 t) ps ty + unify p what (doc $-$ text "Term:" <+> pPrintPrec 0 t) ps ty tcRhs :: Rhs a -> TCM (PredSet, Type, Rhs PredType) -tcRhs (SimpleRhs p e ds) = do +tcRhs (SimpleRhs p li e ds) = do (ps, ds', ps', ty, e') <- withLocalValueEnv $ do (ps, ds') <- tcDecls ds - (ps', ty, e') <- tcExpr p e + (ps', ty, e') <- tcExpr e return (ps, ds', ps', ty, e') - ps'' <- reducePredSet p "expression" (ppExpr 0 e') (ps `Set.union` ps') - return (ps'', ty, SimpleRhs p e' ds') -tcRhs (GuardedRhs spi es ds) = withLocalValueEnv $ do + ps'' <- reducePredSet p "expression" (pPrintPrec 0 e') (ps `Set.union` ps') + return (ps'', ty, SimpleRhs p li e' ds') +tcRhs (GuardedRhs spi li es ds) = withLocalValueEnv $ do (ps, ds') <- tcDecls ds ty <- freshTypeVar (ps', es') <- mapAccumM (tcCondExpr ty) ps es - return (ps', ty, GuardedRhs spi es' ds') + return (ps', ty, GuardedRhs spi li es' ds') tcCondExpr :: Type -> PredSet -> CondExpr a -> TCM (PredSet, CondExpr PredType) tcCondExpr ty ps (CondExpr p g e) = do - (ps', g') <- tcExpr p g >>- unify p "guard" (ppExpr 0 g) ps boolType - (ps'', e') <- tcExpr p e >>- unify p "guarded expression" (ppExpr 0 e) ps' ty + (ps', g') <- tcExpr g >>- unify p "guard" (pPrintPrec 0 g) ps boolType + (ps'', e') <- tcExpr e >>- unify p "guarded expression" (pPrintPrec 0 e) ps' ty return (ps'', CondExpr p g' e') -tcExpr :: HasPosition p => p -> Expression a - -> TCM (PredSet, Type, Expression PredType) -tcExpr _ (Literal spi _ l) = do +tcExpr :: Expression a -> TCM (PredSet, Type, Expression PredType) +tcExpr (Literal spi _ l) = do (ps, ty) <- tcLiteral True l return (ps, ty, Literal spi (predType ty) l) -tcExpr _ (Variable spi _ v) = do +tcExpr (Variable spi _ v) = do m <- getModuleIdent vEnv <- getValueEnv - (ps, ty) <- if isAnonId (unqualify v) then freshPredType [] + (ps, ty) <- if isAnonId (unqualify v) then freshPredType [qDataId] else inst (funType m v vEnv) return (ps, ty, Variable spi (predType ty) v) -tcExpr _ (Constructor spi _ c) = do +tcExpr (Constructor spi _ c) = do m <- getModuleIdent vEnv <- getValueEnv (ps, ty) <- inst (constrType m c vEnv) return (ps, ty, Constructor spi (predType ty) c) -tcExpr p (Paren spi e) = do - (ps, ty, e') <- tcExpr p e +tcExpr (Paren spi e) = do + (ps, ty, e') <- tcExpr e return (ps, ty, Paren spi e') -tcExpr p (Typed spi e qty) = do +tcExpr (Typed spi e qty) = do pty <- expandPoly qty (ps, ty) <- inst (typeScheme pty) - (ps', e') <- tcExpr p e >>- - unifyDecl p "explicitly typed expression" (ppExpr 0 e) emptyPredSet ty + (ps', e') <- tcExpr e >>- + unifyDecl spi "explicitly typed expression" (pPrintPrec 0 e) emptyPredSet ty fvs <- computeFvEnv theta <- getTypeSubst let (gps, lps) = splitPredSet fvs ps' @@ -1120,124 +1165,127 @@ unlessM (checkTypeSig pty tySc) $ do m <- getModuleIdent report $ - errTypeSigTooGeneral p m (text "Expression:" <+> ppExpr 0 e) qty tySc + errTypeSigTooGeneral m (text "Expression:" <+> pPrintPrec 0 e) qty tySc return (ps `Set.union` gps, ty, Typed spi e' qty) -tcExpr _ e@(Record spi _ c fs) = do +tcExpr e@(Record spi _ c fs) = do m <- getModuleIdent vEnv <- getValueEnv - (ps, ty) <- liftM (fmap arrowBase) (inst (constrType m c vEnv)) - (ps', fs') <- mapAccumM (tcField tcExpr "construction" - (\e' -> ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e') ty) ps fs - return (ps', ty, Record spi (predType ty) c fs') -tcExpr p e@(RecordUpdate spi e1 fs) = do - (ps, ty, e1') <- tcExpr p e1 - (ps', fs') <- mapAccumM (tcField tcExpr "update" - (\e' -> ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e') ty) ps fs + (ps, ty) <- fmap arrowBase <$> inst (constrType m c vEnv) + (ps', fs') <- mapAccumM (tcField (const tcExpr) "construction" + (\e' -> pPrintPrec 0 e $-$ text "Term:" <+> pPrintPrec 0 e') ty) ps fs + let missing = map (qualifyLike c) (constrLabels m c vEnv) + \\ map (\(Field _ qid _) -> qid) fs' + pss <- mapM (tcMissingField spi ty) missing + return (Set.unions (ps':pss), ty, Record spi (predType ty) c fs') +tcExpr e@(RecordUpdate spi e1 fs) = do + (ps, ty, e1') <- tcExpr e1 + (ps', fs') <- mapAccumM (tcField (const tcExpr) "update" + (\e' -> pPrintPrec 0 e $-$ text "Term:" <+> pPrintPrec 0 e') ty) ps fs return (ps', ty, RecordUpdate spi e1' fs') -tcExpr p (Tuple spi es) = do - (pss, tys, es') <- liftM unzip3 $ mapM (tcExpr p) es +tcExpr (Tuple spi es) = do + (pss, tys, es') <- liftM unzip3 $ mapM (tcExpr) es return (Set.unions pss, tupleType tys, Tuple spi es') -tcExpr p e@(List spi _ es) = do +tcExpr e@(List spi _ es) = do ty <- freshTypeVar (ps, es') <- - mapAccumM (flip (tcArg p "expression" (ppExpr 0 e)) ty) emptyPredSet es + mapAccumM (flip (tcArg spi "expression" (pPrintPrec 0 e)) ty) emptyPredSet es return (ps, listType ty, List spi (predType $ listType ty) es') -tcExpr p (ListCompr spi e qs) = do +tcExpr (ListCompr spi e qs) = do (ps, qs', ps', ty, e') <- withLocalValueEnv $ do - (ps, qs') <- mapAccumM (tcQual p) emptyPredSet qs - (ps', ty, e') <- tcExpr p e + (ps, qs') <- mapAccumM (tcQual spi) emptyPredSet qs + (ps', ty, e') <- tcExpr e return (ps, qs', ps', ty, e') - ps'' <- reducePredSet p "expression" (ppExpr 0 e') (ps `Set.union` ps') + ps'' <- reducePredSet spi "expression" (pPrintPrec 0 e') (ps `Set.union` ps') return (ps'', listType ty, ListCompr spi e' qs') -tcExpr p e@(EnumFrom spi e1) = do +tcExpr e@(EnumFrom spi e1) = do (ps, ty) <- freshEnumType - (ps', e1') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps ty e1 + (ps', e1') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps ty e1 return (ps', listType ty, EnumFrom spi e1') -tcExpr p e@(EnumFromThen spi e1 e2) = do +tcExpr e@(EnumFromThen spi e1 e2) = do (ps, ty) <- freshEnumType - (ps', e1') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps ty e1 - (ps'', e2') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps' ty e2 + (ps', e1') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps ty e1 + (ps'', e2') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps' ty e2 return (ps'', listType ty, EnumFromThen spi e1' e2') -tcExpr p e@(EnumFromTo spi e1 e2) = do +tcExpr e@(EnumFromTo spi e1 e2) = do (ps, ty) <- freshEnumType - (ps', e1') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps ty e1 - (ps'', e2') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps' ty e2 + (ps', e1') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps ty e1 + (ps'', e2') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps' ty e2 return (ps'', listType ty, EnumFromTo spi e1' e2') -tcExpr p e@(EnumFromThenTo spi e1 e2 e3) = do +tcExpr e@(EnumFromThenTo spi e1 e2 e3) = do (ps, ty) <- freshEnumType - (ps', e1') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps ty e1 - (ps'', e2') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps' ty e2 - (ps''', e3') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps'' ty e3 + (ps', e1') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps ty e1 + (ps'', e2') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps' ty e2 + (ps''', e3') <- tcArg spi "arithmetic sequence" (pPrintPrec 0 e) ps'' ty e3 return (ps''', listType ty, EnumFromThenTo spi e1' e2' e3') -tcExpr p e@(UnaryMinus spi e1) = do +tcExpr e@(UnaryMinus spi e1) = do (ps, ty) <- freshNumType - (ps', e1') <- tcArg p "unary negation" (ppExpr 0 e) ps ty e1 + (ps', e1') <- tcArg spi "unary negation" (pPrintPrec 0 e) ps ty e1 return (ps', ty, UnaryMinus spi e1') -tcExpr p e@(Apply spi e1 e2) = do - (ps, (alpha, beta), e1') <- tcExpr p e1 >>=- - tcArrow p "application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) - (ps', e2') <- tcArg p "application" (ppExpr 0 e) ps alpha e2 +tcExpr e@(Apply spi e1 e2) = do + (ps, (alpha, beta), e1') <- tcExpr e1 >>=- + tcArrow spi "application" (pPrintPrec 0 e $-$ text "Term:" <+> pPrintPrec 0 e1) + (ps', e2') <- tcArg spi "application" (pPrintPrec 0 e) ps alpha e2 return (ps', beta, Apply spi e1' e2') -tcExpr p e@(InfixApply spi e1 op e2) = do +tcExpr e@(InfixApply spi e1 op e2) = do (ps, (alpha, beta, gamma), op') <- tcInfixOp op >>=- - tcBinary p "infix application" (ppExpr 0 e $-$ text "Operator:" <+> ppOp op) - (ps', e1') <- tcArg p "infix application" (ppExpr 0 e) ps alpha e1 - (ps'', e2') <- tcArg p "infix application" (ppExpr 0 e) ps' beta e2 + tcBinary spi "infix application" (pPrintPrec 0 e $-$ text "Operator:" <+> pPrint op) + (ps', e1') <- tcArg spi "infix application" (pPrintPrec 0 e) ps alpha e1 + (ps'', e2') <- tcArg spi "infix application" (pPrintPrec 0 e) ps' beta e2 return (ps'', gamma, InfixApply spi e1' op' e2') -tcExpr p e@(LeftSection spi e1 op) = do +tcExpr e@(LeftSection spi e1 op) = do (ps, (alpha, beta), op') <- tcInfixOp op >>=- - tcArrow p "left section" (ppExpr 0 e $-$ text "Operator:" <+> ppOp op) - (ps', e1') <- tcArg p "left section" (ppExpr 0 e) ps alpha e1 + tcArrow spi "left section" (pPrintPrec 0 e $-$ text "Operator:" <+> pPrint op) + (ps', e1') <- tcArg spi "left section" (pPrintPrec 0 e) ps alpha e1 return (ps', beta, LeftSection spi e1' op') -tcExpr p e@(RightSection spi op e1) = do +tcExpr e@(RightSection spi op e1) = do (ps, (alpha, beta, gamma), op') <- tcInfixOp op >>=- - tcBinary p "right section" (ppExpr 0 e $-$ text "Operator:" <+> ppOp op) - (ps', e1') <- tcArg p "right section" (ppExpr 0 e) ps beta e1 + tcBinary spi "right section" (pPrintPrec 0 e $-$ text "Operator:" <+> pPrint op) + (ps', e1') <- tcArg spi "right section" (pPrintPrec 0 e) ps beta e1 return (ps', TypeArrow alpha gamma, RightSection spi op' e1') -tcExpr p (Lambda spi ts e) = do +tcExpr (Lambda spi ts e) = do (pss, tys, ts', ps, ty, e')<- withLocalValueEnv $ do bindLambdaVars ts - (pss, tys, ts') <- liftM unzip3 $ mapM (tcPattern p) ts - (ps, ty, e') <- tcExpr p e + (pss, tys, ts') <- liftM unzip3 $ mapM (tcPattern spi) ts + (ps, ty, e') <- tcExpr e return (pss, tys, ts', ps, ty, e') - ps' <- reducePredSet p "expression" (ppExpr 0 e') (Set.unions $ ps : pss) + ps' <- reducePredSet spi "expression" (pPrintPrec 0 e') (Set.unions $ ps : pss) return (ps', foldr TypeArrow ty tys, Lambda spi ts' e') -tcExpr p (Let spi ds e) = do +tcExpr (Let spi li ds e) = do (ps, ds', ps', ty, e') <- withLocalValueEnv $ do (ps, ds') <- tcDecls ds - (ps', ty, e') <- tcExpr p e + (ps', ty, e') <- tcExpr e return (ps, ds', ps', ty, e') - ps'' <- reducePredSet p "expression" (ppExpr 0 e') (ps `Set.union` ps') - return (ps'', ty, Let spi ds' e') -tcExpr p (Do spi sts e) = do + ps'' <- reducePredSet spi "expression" (pPrintPrec 0 e') (ps `Set.union` ps') + return (ps'', ty, Let spi li ds' e') +tcExpr (Do spi li sts e) = do (sts', ty, ps', e') <- withLocalValueEnv $ do ((ps, mTy), sts') <- - mapAccumM (uncurry (tcStmt p)) (emptyPredSet, Nothing) sts + mapAccumM (uncurry (tcStmt spi)) (emptyPredSet, Nothing) sts ty <- liftM (maybe id TypeApply mTy) freshTypeVar - (ps', e') <- tcExpr p e >>- unify p "statement" (ppExpr 0 e) ps ty + (ps', e') <- tcExpr e >>- unify spi "statement" (pPrintPrec 0 e) ps ty return (sts', ty, ps', e') - return (ps', ty, Do spi sts' e') -tcExpr p e@(IfThenElse spi e1 e2 e3) = do - (ps, e1') <- tcArg p "expression" (ppExpr 0 e) emptyPredSet boolType e1 - (ps', ty, e2') <- tcExpr p e2 - (ps'', e3') <- tcArg p "expression" (ppExpr 0 e) (ps `Set.union` ps') ty e3 + return (ps', ty, Do spi li sts' e') +tcExpr e@(IfThenElse spi e1 e2 e3) = do + (ps, e1') <- tcArg spi "expression" (pPrintPrec 0 e) emptyPredSet boolType e1 + (ps', ty, e2') <- tcExpr e2 + (ps'', e3') <- tcArg spi "expression" (pPrintPrec 0 e) (ps `Set.union` ps') ty e3 return (ps'', ty, IfThenElse spi e1' e2' e3') -tcExpr p (Case spi ct e as) = do - (ps, tyLhs, e') <- tcExpr p e +tcExpr (Case spi li ct e as) = do + (ps, tyLhs, e') <- tcExpr e tyRhs <- freshTypeVar (ps', as') <- mapAccumM (tcAlt tyLhs tyRhs) ps as - return (ps', tyRhs, Case spi ct e' as') + return (ps', tyRhs, Case spi li ct e' as') -tcArg :: HasPosition p => p -> String -> Doc -> PredSet -> Type -> Expression a +tcArg :: HasSpanInfo p => p -> String -> Doc -> PredSet -> Type -> Expression a -> TCM (PredSet, Expression PredType) tcArg p what doc ps ty e = - tcExpr p e >>- unify p what (doc $-$ text "Term:" <+> ppExpr 0 e) ps ty + tcExpr e >>- unify p what (doc $-$ text "Term:" <+> pPrintPrec 0 e) ps ty tcAlt :: Type -> Type -> PredSet -> Alt a -> TCM (PredSet, Alt PredType) tcAlt tyLhs tyRhs ps a@(Alt p t rhs) = tcAltern tyLhs p t rhs >>- - unify p "case alternative" (ppAlt a) ps tyRhs + unify p "case alternative" (pPrint a) ps tyRhs tcAltern :: Type -> SpanInfo -> Pattern a -> Rhs a -> TCM (PredSet, Type, Alt PredType) @@ -1245,48 +1293,86 @@ (ps, t', ps', ty', rhs') <- withLocalValueEnv $ do bindLambdaVars t (ps, t') <- - tcPatternArg p "case pattern" (ppAlt (Alt p t rhs)) emptyPredSet tyLhs t + tcPatternArg p "case pattern" (pPrint (Alt p t rhs)) emptyPredSet tyLhs t (ps', ty', rhs') <- tcRhs rhs return (ps, t', ps', ty', rhs') - ps'' <- reducePredSet p "alternative" (ppAlt (Alt p t' rhs')) + ps'' <- reducePredSet p "alternative" (pPrint (Alt p t' rhs')) (ps `Set.union` ps') return (ps'', ty', Alt p t' rhs') -tcQual :: HasPosition p => p -> PredSet -> Statement a +tcQual :: HasSpanInfo p => p -> PredSet -> Statement a -> TCM (PredSet, Statement PredType) tcQual p ps (StmtExpr spi e) = do - (ps', e') <- tcExpr p e >>- unify p "guard" (ppExpr 0 e) ps boolType + (ps', e') <- tcExpr e >>- unify p "guard" (pPrintPrec 0 e) ps boolType return (ps', StmtExpr spi e') -tcQual _ ps (StmtDecl spi ds) = do +tcQual _ ps (StmtDecl spi li ds) = do (ps', ds') <- tcDecls ds - return (ps `Set.union` ps', StmtDecl spi ds') + return (ps `Set.union` ps', StmtDecl spi li ds') tcQual p ps q@(StmtBind spi t e) = do alpha <- freshTypeVar - (ps', e') <- tcArg p "generator" (ppStmt q) ps (listType alpha) e + (ps', e') <- tcArg p "generator" (pPrint q) ps (listType alpha) e bindLambdaVars t - (ps'', t') <- tcPatternArg p "generator" (ppStmt q) ps' alpha t + (ps'', t') <- tcPatternArg p "generator" (pPrint q) ps' alpha t return (ps'', StmtBind spi t' e') -tcStmt :: HasPosition p => p -> PredSet -> Maybe Type -> Statement a +tcStmt :: HasSpanInfo p => p -> PredSet -> Maybe Type -> Statement a -> TCM ((PredSet, Maybe Type), Statement PredType) tcStmt p ps mTy (StmtExpr spi e) = do (ps', ty) <- maybe freshMonadType (return . (,) emptyPredSet) mTy alpha <- freshTypeVar - (ps'', e') <- tcExpr p e >>- - unify p "statement" (ppExpr 0 e) (ps `Set.union` ps') (applyType ty [alpha]) + (ps'', e') <- tcExpr e >>- + unify p "statement" (pPrintPrec 0 e) (ps `Set.union` ps') (applyType ty [alpha]) return ((ps'', Just ty), StmtExpr spi e') -tcStmt _ ps mTy (StmtDecl spi ds) = do +tcStmt _ ps mTy (StmtDecl spi li ds) = do (ps', ds') <- tcDecls ds - return ((ps `Set.union` ps', mTy), StmtDecl spi ds') + return ((ps `Set.union` ps', mTy), StmtDecl spi li ds') tcStmt p ps mTy st@(StmtBind spi t e) = do - (ps', ty) <- maybe freshMonadType (return . (,) emptyPredSet) mTy + failable <- checkFailableBind t + let freshMType = if failable then freshMonadFailType else freshMonadType + (ps', ty) <- maybe freshMType (return . (,) emptyPredSet) mTy alpha <- freshTypeVar (ps'', e') <- - tcArg p "statement" (ppStmt st) (ps `Set.union` ps') (applyType ty [alpha]) e + tcArg p "statement" (pPrint st) (ps `Set.union` ps') (applyType ty [alpha]) e bindLambdaVars t - (ps''', t') <- tcPatternArg p "statement" (ppStmt st) ps'' alpha t + (ps''', t') <- tcPatternArg p "statement" (pPrint st) ps'' alpha t return ((ps''', Just ty), StmtBind spi t' e') +checkFailableBind :: Pattern a -> TCM Bool +checkFailableBind (ConstructorPattern _ _ idt ps ) = do + tcEnv <- getTyConsEnv + case qualLookupTypeInfo idt tcEnv of + [RenamingType _ _ _ ] -> or <$> mapM checkFailableBind ps -- or [] == False + [DataType _ _ cs] + | length cs == 1 -> or <$> mapM checkFailableBind ps + | otherwise -> return True + _ -> return True +checkFailableBind (InfixPattern _ _ p1 idt p2) = do + tcEnv <- getTyConsEnv + case qualLookupTypeInfo idt tcEnv of + [RenamingType _ _ _ ] -> (||) <$> checkFailableBind p1 + <*> checkFailableBind p2 + [DataType _ _ cs] + | length cs == 1 -> (||) <$> checkFailableBind p1 + <*> checkFailableBind p2 + | otherwise -> return True + _ -> return True +checkFailableBind (RecordPattern _ _ idt fs ) = do + tcEnv <- getTyConsEnv + case qualLookupTypeInfo idt tcEnv of + [RenamingType _ _ _ ] -> or <$> mapM (checkFailableBind . fieldContent) fs + [DataType _ _ cs] + | length cs == 1 -> or <$> mapM (checkFailableBind . fieldContent) fs + | otherwise -> return True + _ -> return True + where fieldContent (Field _ _ c) = c +checkFailableBind (TuplePattern _ ps ) = + or <$> mapM checkFailableBind ps +checkFailableBind (AsPattern _ _ p ) = checkFailableBind p +checkFailableBind (ParenPattern _ p ) = checkFailableBind p +checkFailableBind (LazyPattern _ _ ) = return False +checkFailableBind (VariablePattern _ _ _ ) = return False +checkFailableBind _ = return True + tcInfixOp :: InfixOp a -> TCM (PredSet, Type, InfixOp PredType) tcInfixOp (InfixOp _ op) = do m <- getModuleIdent @@ -1302,7 +1388,7 @@ -- The first unification in 'tcField' cannot fail; it serves only for -- instantiating the type variables in the field label's type. -tcField :: (Position -> a b -> TCM (PredSet, Type, a PredType)) +tcField :: (SpanInfo -> a b -> TCM (PredSet, Type, a PredType)) -> String -> (a b -> Doc) -> Type -> PredSet -> Field (a b) -> TCM (PredSet, Field (a PredType)) tcField check what doc ty ps (Field p l x) = do @@ -1311,14 +1397,22 @@ (ps', ty') <- inst (labelType m l vEnv) let TypeArrow ty1 ty2 = ty' _ <- unify p "field label" empty emptyPredSet ty emptyPredSet ty1 - (ps'', x') <- check (spanInfo2Pos p) x >>- + (ps'', x') <- check p x >>- unify p ("record " ++ what) (doc x) (ps `Set.union` ps') ty2 return (ps'', Field p l x') --- The function 'tcArrow' checks that its argument can be used as --- an arrow type a -> b and returns the pair (a,b). +tcMissingField :: HasSpanInfo p => p -> Type -> QualIdent -> TCM PredSet +tcMissingField p ty l = do + m <- getModuleIdent + vEnv <- getValueEnv + (ps, ty') <- inst (labelType m l vEnv) + let TypeArrow _ ty2 = ty' + let ps' = Set.singleton (Pred qDataId ty2) + unify p "field label" empty ps ty' ps' (TypeArrow ty ty2) -tcArrow :: HasPosition p => p -> String -> Doc -> Type -> TCM (Type, Type) +-- | Checks that it's argument can be used as an arrow type @a -> b@ and returns +-- the pair @(a, b)@. +tcArrow :: HasSpanInfo p => p -> String -> Doc -> Type -> TCM (Type, Type) tcArrow p what doc ty = do theta <- getTypeSubst unaryArrow (subst theta ty) @@ -1337,7 +1431,7 @@ -- The function 'tcBinary' checks that its argument can be used as an arrow type -- a -> b -> c and returns the triple (a,b,c). -tcBinary :: HasPosition p => p -> String -> Doc -> Type +tcBinary :: HasSpanInfo p => p -> String -> Doc -> Type -> TCM (Type, Type, Type) tcBinary p what doc ty = tcArrow p what doc ty >>= uncurry binaryArrow where @@ -1354,7 +1448,7 @@ -- Unification: The unification uses Robinson's algorithm. -unify :: HasPosition p => p -> String -> Doc -> PredSet -> Type -> PredSet +unify :: HasSpanInfo p => p -> String -> Doc -> PredSet -> Type -> PredSet -> Type -> TCM PredSet unify p what doc ps1 ty1 ps2 ty2 = do theta <- getTypeSubst @@ -1424,12 +1518,12 @@ -- restricted by the current predicate set after the reduction and thus -- may cause a further extension of the current type substitution. -reducePredSet :: HasPosition p => p -> String -> Doc -> PredSet -> TCM PredSet +reducePredSet :: HasSpanInfo p => p -> String -> Doc -> PredSet -> TCM PredSet reducePredSet p what doc ps = do m <- getModuleIdent clsEnv <- getClassEnv theta <- getTypeSubst - inEnv <- (fmap $ fmap $ subst theta) <$> getInstEnv + inEnv <- fmap (fmap (subst theta)) <$> getInstEnv let ps' = subst theta ps (ps1, ps2) = partitionPredSet $ minPredSet clsEnv $ reducePreds inEnv ps' theta' <- @@ -1449,7 +1543,7 @@ fmap (expandAliasType tys . snd3) (lookupInstInfo (qcls, tc) $ fst inEnv) _ -> Nothing -reportMissingInstance :: HasPosition p => ModuleIdent -> p -> String -> Doc +reportMissingInstance :: HasSpanInfo p => ModuleIdent -> p -> String -> Doc -> InstEnv' -> TypeSubst -> Pred -> TCM TypeSubst reportMissingInstance m p what doc inEnv theta (Pred qcls ty) = case subst theta ty of @@ -1492,7 +1586,7 @@ -- types that satisfies all constraints for the ambiguous type variable. An -- error is reported if no such type exists. -applyDefaults :: HasPosition p => p -> String -> Doc -> Set.Set Int -> PredSet +applyDefaults :: HasSpanInfo p => p -> String -> Doc -> Set.Set Int -> PredSet -> Type -> TCM PredSet applyDefaults p what doc fvs ps ty = do m <- getModuleIdent @@ -1553,6 +1647,12 @@ freshMonadType :: TCM (PredSet, Type) freshMonadType = freshPredType [qMonadId] +freshMonadFailType :: TCM (PredSet, Type) +freshMonadFailType = freshPredType [qMonadFailId] + +freshDataType :: TCM (PredSet, Type) +freshDataType = freshPredType [qDataId] + freshConstrained :: [Type] -> TCM Type freshConstrained = freshVar . TypeConstrained @@ -1690,52 +1790,52 @@ -- --------------------------------------------------------------------------- errPolymorphicVar :: Ident -> Message -errPolymorphicVar v = posMessage v $ hsep $ map text +errPolymorphicVar v = spanInfoMessage v $ hsep $ map text ["Variable", idName v, "has a polymorphic type"] -errTypeSigTooGeneral :: HasPosition a => a -> ModuleIdent -> Doc -> QualTypeExpr +errTypeSigTooGeneral :: ModuleIdent -> Doc -> QualTypeExpr -> TypeScheme -> Message -errTypeSigTooGeneral p m what qty tySc = posMessage p $ vcat +errTypeSigTooGeneral m what qty tySc = spanInfoMessage qty $ vcat [ text "Type signature too general", what , text "Inferred type:" <+> ppTypeScheme m tySc - , text "Type signature:" <+> ppQualTypeExpr qty + , text "Type signature:" <+> pPrint qty ] -errMethodTypeTooSpecific :: HasPosition a => a -> ModuleIdent -> Doc -> PredType +errMethodTypeTooSpecific :: HasSpanInfo a => a -> ModuleIdent -> Doc -> PredType -> TypeScheme -> Message -errMethodTypeTooSpecific p m what pty tySc = posMessage p $ vcat +errMethodTypeTooSpecific p m what pty tySc = spanInfoMessage p $ vcat [ text "Method type too specific", what , text "Inferred type:" <+> ppTypeScheme m tySc , text "Expected type:" <+> ppPredType m pty ] -errNonFunctionType :: HasPosition a => a -> String -> Doc -> ModuleIdent -> Type +errNonFunctionType :: HasSpanInfo a => a -> String -> Doc -> ModuleIdent -> Type -> Message -errNonFunctionType p what doc m ty = posMessage p $ vcat +errNonFunctionType p what doc m ty = spanInfoMessage p $ vcat [ text "Type error in" <+> text what, doc , text "Type:" <+> ppType m ty , text "Cannot be applied" ] -errNonBinaryOp :: HasPosition a => a -> String -> Doc -> ModuleIdent -> Type +errNonBinaryOp :: HasSpanInfo a => a -> String -> Doc -> ModuleIdent -> Type -> Message -errNonBinaryOp p what doc m ty = posMessage p $ vcat +errNonBinaryOp p what doc m ty = spanInfoMessage p $ vcat [ text "Type error in" <+> text what, doc , text "Type:" <+> ppType m ty , text "Cannot be used as binary operator" ] -errTypeMismatch :: HasPosition a => a -> String -> Doc -> ModuleIdent -> Type +errTypeMismatch :: HasSpanInfo a => a -> String -> Doc -> ModuleIdent -> Type -> Type -> Doc -> Message -errTypeMismatch p what doc m ty1 ty2 reason = posMessage p $ vcat +errTypeMismatch p what doc m ty1 ty2 reason = spanInfoMessage p $ vcat [ text "Type error in" <+> text what, doc , text "Inferred type:" <+> ppType m ty2 , text "Expected type:" <+> ppType m ty1 , reason ] -errSkolemFieldLabel :: HasPosition a => a -> Ident -> Message -errSkolemFieldLabel p l = posMessage p $ hsep $ map text +errSkolemFieldLabel :: HasSpanInfo a => a -> Ident -> Message +errSkolemFieldLabel p l = spanInfoMessage p $ hsep $ map text ["Existential type escapes with type of record selector", escName l] errRecursiveType :: ModuleIdent -> Int -> Type -> Doc @@ -1748,25 +1848,25 @@ , text "are incompatible" ] -errIncompatibleLabelTypes :: HasPosition a => a -> ModuleIdent -> Ident -> Type +errIncompatibleLabelTypes :: HasSpanInfo a => a -> ModuleIdent -> Ident -> Type -> Type -> Message -errIncompatibleLabelTypes p m l ty1 ty2 = posMessage p $ sep +errIncompatibleLabelTypes p m l ty1 ty2 = spanInfoMessage p $ sep [ text "Labeled types" <+> ppIdent l <+> text "::" <+> ppType m ty1 , nest 10 $ text "and" <+> ppIdent l <+> text "::" <+> ppType m ty2 , text "are incompatible" ] -errMissingInstance :: HasPosition a => ModuleIdent -> a -> String -> Doc -> Pred +errMissingInstance :: HasSpanInfo a => ModuleIdent -> a -> String -> Doc -> Pred -> Message -errMissingInstance m p what doc pr = posMessage p $ vcat +errMissingInstance m p what doc pr = spanInfoMessage p $ vcat [ text "Missing instance for" <+> ppPred m pr , text "in" <+> text what , doc ] -errAmbiguousTypeVariable :: HasPosition a => ModuleIdent -> a -> String -> Doc +errAmbiguousTypeVariable :: HasSpanInfo a => ModuleIdent -> a -> String -> Doc -> PredSet -> Type -> Int -> Message -errAmbiguousTypeVariable m p what doc ps ty tv = posMessage p $ vcat +errAmbiguousTypeVariable m p what doc ps ty tv = spanInfoMessage p $ vcat [ text "Ambiguous type variable" <+> ppType m (TypeVariable tv) , text "in type" <+> ppPredType m (PredType ps ty) , text "inferred for" <+> text what diff --git a/src/Checks/TypeSyntaxCheck.hs b/src/Checks/TypeSyntaxCheck.hs --- a/src/Checks/TypeSyntaxCheck.hs +++ b/src/Checks/TypeSyntaxCheck.hs @@ -26,8 +26,7 @@ import Control.Monad (unless, when) import qualified Control.Monad.State as S (State, runState, gets, modify) import Data.List (nub) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe, isNothing) +import Data.Maybe (isNothing) import Curry.Base.Ident import Curry.Base.Position @@ -37,7 +36,7 @@ import Curry.Syntax.Pretty import Base.Expr (Expr (fv)) -import Base.Messages (Message, posMessage, internalError) +import Base.Messages (Message, spanInfoMessage, internalError) import Base.TopEnv import Base.Utils (findMultiples, findDouble) @@ -55,20 +54,19 @@ -- type classes are added to this environment and the declarations are checked -- within this environment. -typeSyntaxCheck :: [KnownExtension] -> TCEnv -> Module a - -> ((Module a, [KnownExtension]), [Message]) -typeSyntaxCheck exts tcEnv mdl@(Module _ _ m _ _ ds) = +typeSyntaxCheck :: TCEnv -> Module a -> (Module a, [Message]) +typeSyntaxCheck tcEnv mdl@(Module _ _ _ m _ _ ds) = case findMultiples $ map getIdent tcds of [] -> if length dfds <= 1 then runTSCM (checkModule mdl) state - else ((mdl, exts), [errMultipleDefaultDeclarations dfps]) - tss -> ((mdl, exts), map errMultipleDeclarations tss) + else (mdl, [errMultipleDefaultDeclarations dfps]) + tss -> (mdl, map errMultipleDeclarations tss) where tcds = filter isTypeOrClassDecl ds dfds = filter isDefaultDecl ds - dfps = map (\(DefaultDecl p _) -> spanInfo2Pos p) dfds + dfps = map (\(DefaultDecl p _) -> p) dfds tEnv = foldr (bindType m) (fmap toTypeKind tcEnv) tcds - state = TSCState m tEnv exts Map.empty 1 [] + state = TSCState m tEnv 1 [] -- Type Syntax Check Monad type TSCM = S.State TSCState @@ -77,8 +75,6 @@ data TSCState = TSCState { moduleIdent :: ModuleIdent , typeEnv :: TypeEnv - , extensions :: [KnownExtension] - , renameEnv :: RenameEnv , nextId :: Integer , errors :: [Message] } @@ -92,31 +88,6 @@ getTypeEnv :: TSCM TypeEnv getTypeEnv = S.gets typeEnv -hasExtension :: KnownExtension -> TSCM Bool -hasExtension ext = S.gets (elem ext . extensions) - -enableExtension :: KnownExtension -> TSCM () -enableExtension e = S.modify $ \s -> s { extensions = e : extensions s } - -getExtensions :: TSCM [KnownExtension] -getExtensions = S.gets extensions - -getRenameEnv :: TSCM RenameEnv -getRenameEnv = S.gets renameEnv - -modifyRenameEnv :: (RenameEnv -> RenameEnv) -> TSCM () -modifyRenameEnv f = S.modify $ \s -> s { renameEnv = f $ renameEnv s } - -withLocalEnv :: TSCM a -> TSCM a -withLocalEnv act = do - oldEnv <- getRenameEnv - res <- act - modifyRenameEnv $ const oldEnv - return res - -resetEnv :: TSCM () -resetEnv = modifyRenameEnv $ const Map.empty - newId :: TSCM Integer newId = do curId <- S.gets nextId @@ -144,214 +115,58 @@ bindType m (TypeDecl _ tc _ _) = bindTypeKind m tc (Alias qtc) where qtc = qualifyWith m tc -bindType m (ClassDecl _ _ cls _ ds) = bindTypeKind m cls (Class qcls ms) +bindType m (ClassDecl _ _ _ cls _ ds) = bindTypeKind m cls (Class qcls ms) where qcls = qualifyWith m cls ms = concatMap methods ds bindType _ _ = id --- As preparation for the kind check, type variables within type declarations --- have to be renamed since existentially quantified type variable may shadow --- a universally quantified variable from the left hand side of a type --- declaration. - --- TODO: This renaming may be used to support scoped type variables in future. - --- TODO: In the long run, this renaming may be merged with the syntax check --- renaming and moved into a separate module. - -type RenameEnv = Map.Map Ident Ident - -class Rename a where - rename :: a -> TSCM a - -renameTypeSig :: (Expr a, Rename a) => a -> TSCM a -renameTypeSig x = withLocalEnv $ do - env <- getRenameEnv - bindVars (filter (`notElem` Map.keys env) $ fv x) - rename x - -renameReset :: Rename a => a -> TSCM a -renameReset x = withLocalEnv $ resetEnv >> rename x - -instance Rename a => Rename [a] where - rename = mapM rename - -instance Rename (Decl a) where - rename (InfixDecl p fix pr ops) = return $ InfixDecl p fix pr ops - rename (DataDecl p tc tvs cs clss) = withLocalEnv $ do - bindVars tvs - DataDecl p tc <$> rename tvs <*> rename cs <*> pure clss - rename (ExternalDataDecl p tc tvs) = withLocalEnv $ do - bindVars tvs - ExternalDataDecl p tc <$> rename tvs - rename (NewtypeDecl p tc tvs nc clss) = withLocalEnv $ do - bindVars tvs - NewtypeDecl p tc <$> rename tvs <*> rename nc <*> pure clss - rename (TypeDecl p tc tvs ty) = withLocalEnv $ do - bindVars tvs - TypeDecl p tc <$> rename tvs <*> rename ty - rename (TypeSig p fs qty) = TypeSig p fs <$> renameTypeSig qty - rename (FunctionDecl p a f eqs) = FunctionDecl p a f <$> renameReset eqs - rename (ExternalDecl p fs) = return $ ExternalDecl p fs - rename (PatternDecl p ts rhs) = PatternDecl p ts <$> renameReset rhs - rename (FreeDecl p fvs) = return $ FreeDecl p fvs - rename (DefaultDecl p tys) = DefaultDecl p <$> mapM renameTypeSig tys - rename (ClassDecl p cx cls tv ds) = withLocalEnv $ do - bindVar tv - ClassDecl p <$> rename cx <*> pure cls <*> rename tv <*> rename ds - rename (InstanceDecl p cx cls ty ds) = withLocalEnv $ do - bindVars (fv ty) - InstanceDecl p <$> rename cx <*> pure cls <*> rename ty <*> renameReset ds - -instance Rename ConstrDecl where - rename (ConstrDecl p c tys) = withLocalEnv $ do - ConstrDecl p <$> pure c <*> rename tys - rename (ConOpDecl p ty1 op ty2) = withLocalEnv $ do - ConOpDecl p <$> rename ty1 <*> pure op <*> rename ty2 - rename (RecordDecl p c fs) = withLocalEnv $ do - RecordDecl p <$> pure c <*> rename fs - -instance Rename FieldDecl where - rename (FieldDecl p ls ty) = FieldDecl p ls <$> rename ty - -instance Rename NewConstrDecl where - rename (NewConstrDecl p c ty) = NewConstrDecl p c <$> rename ty - rename (NewRecordDecl p c (l, ty)) = NewRecordDecl p c . (,) l <$> rename ty - -instance Rename Constraint where - rename (Constraint spi cls ty) = Constraint spi cls <$> rename ty - -instance Rename QualTypeExpr where - rename (QualTypeExpr spi cx ty) = QualTypeExpr spi <$> rename cx <*> rename ty - -instance Rename TypeExpr where - rename (ConstructorType spi tc) = return $ ConstructorType spi tc - rename (ApplyType spi ty1 ty2) = ApplyType spi <$> rename ty1 <*> rename ty2 - rename (VariableType spi tv) = VariableType spi <$> rename tv - rename (TupleType spi tys) = TupleType spi <$> rename tys - rename (ListType spi ty) = ListType spi <$> rename ty - rename (ArrowType spi ty1 ty2) = ArrowType spi <$> rename ty1 <*> rename ty2 - rename (ParenType spi ty) = ParenType spi <$> rename ty - rename (ForallType spi vs ty) = do - bindVars vs - ForallType spi <$> mapM rename vs <*> rename ty - -instance Rename (Equation a) where - rename (Equation p lhs rhs) = Equation p lhs <$> rename rhs - -instance Rename (Rhs a) where - rename (SimpleRhs spi e ds) = SimpleRhs spi <$> rename e <*> rename ds - rename (GuardedRhs spi es ds) = GuardedRhs spi <$> rename es <*> rename ds - -instance Rename (CondExpr a) where - rename (CondExpr spi c e) = CondExpr spi <$> rename c <*> rename e - -instance Rename (Expression a) where - rename (Literal spi a l) = return $ Literal spi a l - rename (Variable spi a v) = return $ Variable spi a v - rename (Constructor spi a c) = return $ Constructor spi a c - rename (Paren spi e) = Paren spi <$> rename e - rename (Typed spi e qty) = Typed spi <$> rename e <*> renameTypeSig qty - rename (Record spi a c fs) = Record spi a c <$> rename fs - rename (RecordUpdate spi e fs) = RecordUpdate spi <$> rename e <*> rename fs - rename (Tuple spi es) = Tuple spi <$> rename es - rename (List spi a es) = List spi a <$> rename es - rename (ListCompr spi e stmts) = ListCompr spi <$> rename e <*> rename stmts - rename (EnumFrom spi e) = EnumFrom spi <$> rename e - rename (EnumFromThen spi e1 e2) = EnumFromThen spi <$> rename e1 <*> rename e2 - rename (EnumFromTo spi e1 e2) = EnumFromTo spi <$> rename e1 <*> rename e2 - rename (EnumFromThenTo spi e1 e2 e3) = - EnumFromThenTo spi <$> rename e1 <*> rename e2 <*> rename e3 - rename (UnaryMinus spi e) = UnaryMinus spi <$> rename e - rename (Apply spi e1 e2) = Apply spi <$> rename e1 <*> rename e2 - rename (InfixApply spi e1 op e2) = - flip (InfixApply spi) op <$> rename e1 <*> rename e2 - rename (LeftSection spi e op) = flip (LeftSection spi) op <$> rename e - rename (RightSection spi op e) = RightSection spi op <$> rename e - rename (Lambda spi ts e) = Lambda spi ts <$> rename e - rename (Let spi ds e) = Let spi <$> rename ds <*> rename e - rename (Do spi stmts e) = Do spi <$> rename stmts <*> rename e - rename (IfThenElse spi c e1 e2) = - IfThenElse spi <$> rename c <*> rename e1 <*> rename e2 - rename (Case spi ct e alts) = Case spi ct <$> rename e <*> rename alts - -instance Rename (Statement a) where - rename (StmtExpr spi e) = StmtExpr spi <$> rename e - rename (StmtDecl spi ds) = StmtDecl spi <$> rename ds - rename (StmtBind spi t e) = StmtBind spi t <$> rename e - -instance Rename (Alt a) where - rename (Alt spi t rhs) = Alt spi t <$> rename rhs - -instance Rename a => Rename (Field a) where - rename (Field spi l x) = Field spi l <$> rename x - -instance Rename Ident where - rename tv | isAnonId tv = renameIdent tv <$> newId - | otherwise = fromMaybe tv <$> lookupVar tv - -bindVar :: Ident -> TSCM () -bindVar tv = do - k <- newId - modifyRenameEnv $ Map.insert tv (renameIdent tv k) - -bindVars :: [Ident] -> TSCM () -bindVars = mapM_ bindVar - -lookupVar :: Ident -> TSCM (Maybe Ident) -lookupVar tv = do - env <- getRenameEnv - return $ Map.lookup tv env - -- When type declarations are checked, the compiler will allow anonymous -- type variables on the left hand side of the declaration, but not on -- the right hand side. Function and pattern declarations must be -- traversed because they can contain local type signatures. -checkModule :: Module a -> TSCM (Module a, [KnownExtension]) -checkModule (Module spi ps m es is ds) = do +checkModule :: Module a -> TSCM (Module a) +checkModule (Module spi li ps m es is ds) = do ds' <- mapM checkDecl ds - ds'' <- rename ds' - exts <- getExtensions - return (Module spi ps m es is ds'', exts) + return $ Module spi li ps m es is ds' checkDecl :: Decl a -> TSCM (Decl a) -checkDecl (DataDecl p tc tvs cs clss) = do +checkDecl (DataDecl p tc tvs cs clss) = do checkTypeLhs tvs cs' <- mapM (checkConstrDecl tvs) cs - mapM_ checkClass clss + mapM_ (checkClass False) clss return $ DataDecl p tc tvs cs' clss -checkDecl (NewtypeDecl p tc tvs nc clss) = do +checkDecl (NewtypeDecl p tc tvs nc clss) = do checkTypeLhs tvs nc' <- checkNewConstrDecl tvs nc - mapM_ checkClass clss + mapM_ (checkClass False) clss return $ NewtypeDecl p tc tvs nc' clss -checkDecl (TypeDecl p tc tvs ty) = do +checkDecl (TypeDecl p tc tvs ty) = do checkTypeLhs tvs ty' <- checkClosedType tvs ty return $ TypeDecl p tc tvs ty' -checkDecl (TypeSig p vs qty) = +checkDecl (TypeSig p vs qty) = TypeSig p vs <$> checkQualType qty -checkDecl (FunctionDecl a p f eqs) = - FunctionDecl a p f <$> mapM checkEquation eqs -checkDecl (PatternDecl p t rhs) = - PatternDecl p t <$> checkRhs rhs -checkDecl (DefaultDecl p tys) = DefaultDecl p <$> mapM checkType tys -checkDecl (ClassDecl p cx cls clsvar ds) = do +checkDecl (FunctionDecl a p f eqs) = FunctionDecl a p f <$> + mapM checkEquation eqs +checkDecl (PatternDecl p t rhs) = PatternDecl p t <$> checkRhs rhs +checkDecl (DefaultDecl p tys) = DefaultDecl p <$> + mapM (checkClosedType []) tys +checkDecl (ClassDecl p li cx cls clsvar ds) = do checkTypeVars "class declaration" [clsvar] cx' <- checkClosedContext [clsvar] cx checkSimpleContext cx' ds' <- mapM checkDecl ds mapM_ (checkClassMethod clsvar) ds' - return $ ClassDecl p cx' cls clsvar ds' -checkDecl (InstanceDecl p cx qcls inst ds) = do - checkClass qcls + return $ ClassDecl p li cx' cls clsvar ds' +checkDecl (InstanceDecl p li cx qcls inst ds) = do + checkClass True qcls QualTypeExpr _ cx' inst' <- checkQualType $ QualTypeExpr NoSpanInfo cx inst checkSimpleContext cx' checkInstanceType p inst' - InstanceDecl p cx' qcls inst' <$> mapM checkDecl ds -checkDecl d = return d + InstanceDecl p li cx' qcls inst' <$> mapM checkDecl ds +checkDecl d = return d checkConstrDecl :: [Ident] -> ConstrDecl -> TSCM ConstrDecl checkConstrDecl tvs (ConstrDecl p c tys) = do @@ -390,10 +205,9 @@ checkClassMethod :: Ident -> Decl a -> TSCM () checkClassMethod tv (TypeSig spi _ qty) = do - unless (tv `elem` fv qty) $ report $ errAmbiguousType p tv + unless (tv `elem` fv qty) $ report $ errAmbiguousType spi tv let QualTypeExpr _ cx _ = qty - when (tv `elem` fv cx) $ report $ errConstrainedClassVariable p tv - where p = spanInfo2Pos spi + when (tv `elem` fv cx) $ report $ errConstrainedClassVariable spi tv checkClassMethod _ _ = ok checkInstanceType :: SpanInfo -> InstanceType -> TSCM () @@ -403,7 +217,7 @@ not (isTypeSyn (typeConstr inst) tEnv) && not (any isAnonId $ typeVariables inst) && isNothing (findDouble $ fv inst)) $ - report $ errIllegalInstanceType (spanInfo2Pos p) inst + report $ errIllegalInstanceType p inst checkTypeLhs :: [Ident] -> TSCM () checkTypeLhs = checkTypeVars "left hand side of type declaration" @@ -416,7 +230,7 @@ checkTypeVars _ [] = ok checkTypeVars what (tv : tvs) = do unless (isAnonId tv) $ do - isTypeConstrOrClass <- (not . null . lookupTypeKind tv) <$> getTypeEnv + isTypeConstrOrClass <- not . null . lookupTypeKind tv <$> getTypeEnv when isTypeConstrOrClass $ report $ errNoVariable tv what when (tv `elem` tvs) $ report $ errNonLinear tv what checkTypeVars what tvs @@ -429,10 +243,10 @@ checkEquation (Equation p lhs rhs) = Equation p lhs <$> checkRhs rhs checkRhs :: Rhs a -> TSCM (Rhs a) -checkRhs (SimpleRhs spi e ds) = SimpleRhs spi <$> checkExpr e - <*> mapM checkDecl ds -checkRhs (GuardedRhs spi es ds) = GuardedRhs spi <$> mapM checkCondExpr es - <*> mapM checkDecl ds +checkRhs (SimpleRhs spi li e ds) = + SimpleRhs spi li <$> checkExpr e <*> mapM checkDecl ds +checkRhs (GuardedRhs spi li es ds) = + GuardedRhs spi li <$> mapM checkCondExpr es <*> mapM checkDecl ds checkCondExpr :: CondExpr a -> TSCM (CondExpr a) checkCondExpr (CondExpr spi g e) = CondExpr spi <$> checkExpr g <*> checkExpr e @@ -466,24 +280,24 @@ checkExpr (InfixApply spi e1 op e2) = InfixApply spi <$> checkExpr e1 <*> return op <*> checkExpr e2 -checkExpr (LeftSection spi e op) = - flip (LeftSection spi) op <$> checkExpr e -checkExpr (RightSection spi op e) = RightSection spi op <$> checkExpr e -checkExpr (Lambda spi ts e) = Lambda spi ts <$> checkExpr e -checkExpr (Let spi ds e) = Let spi <$> mapM checkDecl ds - <*> checkExpr e -checkExpr (Do spi sts e) = Do spi <$> mapM checkStmt sts - <*> checkExpr e -checkExpr (IfThenElse spi e1 e2 e3) = IfThenElse spi <$> checkExpr e1 +checkExpr (LeftSection spi e op) = flip (LeftSection spi) op <$> + checkExpr e +checkExpr (RightSection spi op e) = RightSection spi op <$> checkExpr e +checkExpr (Lambda spi ts e) = Lambda spi ts <$> checkExpr e +checkExpr (Let spi li ds e) = Let spi li <$> mapM checkDecl ds + <*> checkExpr e +checkExpr (Do spi li sts e) = Do spi li <$> mapM checkStmt sts + <*> checkExpr e +checkExpr (IfThenElse spi e1 e2 e3) = IfThenElse spi <$> checkExpr e1 <*> checkExpr e2 <*> checkExpr e3 -checkExpr (Case spi ct e alts) = Case spi ct <$> checkExpr e - <*> mapM checkAlt alts +checkExpr (Case spi li ct e alts) = Case spi li ct <$> checkExpr e + <*> mapM checkAlt alts checkStmt :: Statement a -> TSCM (Statement a) -checkStmt (StmtExpr spi e) = StmtExpr spi <$> checkExpr e -checkStmt (StmtBind spi t e) = StmtBind spi t <$> checkExpr e -checkStmt (StmtDecl spi ds) = StmtDecl spi <$> mapM checkDecl ds +checkStmt (StmtExpr spi e) = StmtExpr spi <$> checkExpr e +checkStmt (StmtBind spi t e) = StmtBind spi t <$> checkExpr e +checkStmt (StmtDecl spi li ds) = StmtDecl spi li <$> mapM checkDecl ds checkAlt :: Alt a -> TSCM (Alt a) checkAlt (Alt spi t rhs) = Alt spi t <$> checkRhs rhs @@ -513,7 +327,7 @@ checkConstraint :: Constraint -> TSCM Constraint checkConstraint c@(Constraint spi qcls ty) = do - checkClass qcls + checkClass False qcls ty' <- checkType ty unless (isVariableType $ rootType ty') $ report $ errIllegalConstraint c return $ Constraint spi qcls ty' @@ -521,16 +335,22 @@ rootType (ApplyType _ ty' _) = ty' rootType ty' = ty' -checkClass :: QualIdent -> TSCM () -checkClass qcls = do +checkClass :: Bool -> QualIdent -> TSCM () +checkClass isInstDecl qcls = do m <- getModuleIdent tEnv <- getTypeEnv case qualLookupTypeKind qcls tEnv of [] -> report $ errUndefinedClass qcls - [Class _ _] -> ok + [Class c _] + | c == qDataId -> when (isInstDecl && m /= preludeMIdent) $ report $ + errIllegalDataInstance qcls + | otherwise -> ok [_] -> report $ errUndefinedClass qcls tks -> case qualLookupTypeKind (qualQualify m qcls) tEnv of - [Class _ _] -> ok + [Class c _] + | c == qDataId -> when (isInstDecl && m /= preludeMIdent) $ report $ + errIllegalDataInstance qcls + | otherwise -> ok [_] -> report $ errUndefinedClass qcls _ -> report $ errAmbiguousIdent qcls $ map origName tks @@ -557,9 +377,9 @@ _ -> report (errAmbiguousIdent tc $ map origName tks) >> return c checkType (ApplyType spi ty1 ty2) = ApplyType spi <$> checkType ty1 <*> checkType ty2 -checkType v@(VariableType spi tv) - | isAnonId tv = return v - | otherwise = checkType $ ConstructorType spi (qualify tv) +checkType (VariableType spi tv) + | isAnonId tv = (VariableType spi . renameIdent tv) <$> newId + | otherwise = checkType $ ConstructorType spi (qualify tv) checkType (TupleType spi tys) = TupleType spi <$> mapM checkType tys checkType (ListType spi ty) = ListType spi <$> checkType ty checkType (ArrowType spi ty1 ty2) = ArrowType spi <$> checkType ty1 @@ -578,13 +398,6 @@ checkClosed tvs (ParenType _ ty) = checkClosed tvs ty checkClosed tvs (ForallType _ vs ty) = checkClosed (tvs ++ vs) ty -checkUsedExtension :: Position -> String -> KnownExtension -> TSCM () -checkUsedExtension pos msg ext = do - enabled <- hasExtension ext - unless enabled $ do - report $ errMissingLanguageExtension pos msg ext - enableExtension ext - -- --------------------------------------------------------------------------- -- Auxiliary definitions -- --------------------------------------------------------------------------- @@ -592,11 +405,11 @@ getIdent :: Decl a -> Ident getIdent (DataDecl _ tc _ _ _) = tc getIdent (ExternalDataDecl _ tc _) = tc -getIdent (NewtypeDecl _ tc _ _ _) = tc -getIdent (TypeDecl _ tc _ _) = tc -getIdent (ClassDecl _ _ cls _ _) = cls -getIdent _ = - internalError "Checks.TypeSyntaxCheck.getIdent: no type or class declaration" +getIdent (NewtypeDecl _ tc _ _ _) = tc +getIdent (TypeDecl _ tc _ _) = tc +getIdent (ClassDecl _ _ _ cls _ _) = cls +getIdent _ = internalError + "Checks.TypeSyntaxCheck.getIdent: no type or class declaration" isTypeSyn :: QualIdent -> TypeEnv -> Bool isTypeSyn tc tEnv = case qualLookupTypeKind tc tEnv of @@ -607,27 +420,21 @@ -- Error messages -- --------------------------------------------------------------------------- -errMultipleDefaultDeclarations :: [Position] -> Message -errMultipleDefaultDeclarations ps = posMessage (head ps) $ +errMultipleDefaultDeclarations :: [SpanInfo] -> Message +errMultipleDefaultDeclarations spis = spanInfoMessage (head spis) $ text "More than one default declaration:" $+$ - nest 2 (vcat $ map showPos ps) - where showPos = text . showLine + nest 2 (vcat $ map showPos spis) + where showPos = text . showLine . getPosition errMultipleDeclarations :: [Ident] -> Message -errMultipleDeclarations is = posMessage i $ +errMultipleDeclarations is = spanInfoMessage i $ text "Multiple declarations of" <+> text (escName i) <+> text "at:" $+$ nest 2 (vcat $ map showPos is) where i = head is showPos = text . showLine . getPosition -errMissingLanguageExtension :: Position -> String -> KnownExtension -> Message -errMissingLanguageExtension p what ext = posMessage p $ - text what <+> text "are not supported in standard Curry." $+$ - nest 2 (text "Use flag -X" <+> text (show ext) - <+> text "to enable this extension.") - errUndefined :: String -> QualIdent -> Message -errUndefined what qident = posMessage qident $ hsep $ map text +errUndefined what qident = spanInfoMessage qident $ hsep $ map text ["Undefined", what, qualName qident] errUndefinedClass :: QualIdent -> Message @@ -637,48 +444,55 @@ errUndefinedType = errUndefined "type" errAmbiguousIdent :: QualIdent -> [QualIdent] -> Message -errAmbiguousIdent qident qidents = posMessage qident $ +errAmbiguousIdent qident qidents = spanInfoMessage qident $ text "Ambiguous identifier" <+> text (escQualName qident) $+$ text "It could refer to:" $+$ nest 2 (vcat (map (text . qualName) qidents)) -errAmbiguousType :: Position -> Ident -> Message -errAmbiguousType p ident = posMessage p $ hsep $ map text +errAmbiguousType :: SpanInfo -> Ident -> Message +errAmbiguousType spi ident = spanInfoMessage spi $ hsep $ map text [ "Method type does not mention class variable", idName ident ] -errConstrainedClassVariable :: Position -> Ident -> Message -errConstrainedClassVariable p ident = posMessage p $ hsep $ map text +errConstrainedClassVariable :: SpanInfo -> Ident -> Message +errConstrainedClassVariable spi ident = spanInfoMessage spi $ hsep $ map text [ "Method context must not constrain class variable", idName ident ] errNonLinear :: Ident -> String -> Message -errNonLinear tv what = posMessage tv $ hsep $ map text +errNonLinear tv what = spanInfoMessage tv $ hsep $ map text [ "Type variable", idName tv, "occurs more than once in", what ] errNoVariable :: Ident -> String -> Message -errNoVariable tv what = posMessage tv $ hsep $ map text $ - [ "Type constructor or type class identifier", idName tv, "used in", what ] +errNoVariable tv what = spanInfoMessage tv $ hsep $ map text + ["Type constructor or type class identifier", idName tv, "used in", what] errUnboundVariable :: Ident -> Message -errUnboundVariable tv = posMessage tv $ hsep $ map text +errUnboundVariable tv = spanInfoMessage tv $ hsep $ map text [ "Unbound type variable", idName tv ] errIllegalConstraint :: Constraint -> Message -errIllegalConstraint c@(Constraint _ qcls _) = posMessage qcls $ vcat - [ text "Illegal class constraint" <+> ppConstraint c +errIllegalConstraint c@(Constraint _ qcls _) = spanInfoMessage qcls $ vcat + [ text "Illegal class constraint" <+> pPrint c , text "Constraints must be of the form C u or C (u t1 ... tn)," , text "where C is a type class, u is a type variable and t1, ..., tn are types." ] errIllegalSimpleConstraint :: Constraint -> Message -errIllegalSimpleConstraint c@(Constraint _ qcls _) = posMessage qcls $ vcat - [ text "Illegal class constraint" <+> ppConstraint c +errIllegalSimpleConstraint c@(Constraint _ qcls _) = spanInfoMessage qcls $ vcat + [ text "Illegal class constraint" <+> pPrint c , text "Constraints in class and instance declarations must be of" , text "the form C u, where C is a type class and u is a type variable." ] -errIllegalInstanceType :: Position -> InstanceType -> Message -errIllegalInstanceType p inst = posMessage p $ vcat +errIllegalInstanceType :: SpanInfo -> InstanceType -> Message +errIllegalInstanceType spi inst = spanInfoMessage spi $ vcat [ text "Illegal instance type" <+> ppInstanceType inst , text "The instance type must be of the form (T u_1 ... u_n)," , text "where T is not a type synonym and u_1, ..., u_n are" , text "mutually distinct, non-anonymous type variables." + ] + +errIllegalDataInstance :: QualIdent -> Message +errIllegalDataInstance qcls = spanInfoMessage qcls $ vcat + [ text "Illegal instance of" <+> ppQIdent qcls + , text "Instances of this class cannot be defined." + , text "Instead, they are automatically derived if possible." ] diff --git a/src/Checks/WarnCheck.hs b/src/Checks/WarnCheck.hs --- a/src/Checks/WarnCheck.hs +++ b/src/Checks/WarnCheck.hs @@ -21,28 +21,34 @@ import Prelude hiding ((<>)) #endif +import Control.Applicative + ((<|>)) import Control.Monad - (filterM, foldM_, guard, liftM, liftM2, when, unless) + (filterM, foldM_, guard, liftM, liftM2, when, unless, void) import Control.Monad.State.Strict (State, execState, gets, modify) import qualified Data.IntSet as IntSet (IntSet, empty, insert, notMember, singleton, union, unions) -import qualified Data.Map as Map (empty, insert, lookup) +import qualified Data.Map as Map (empty, insert, lookup, (!)) import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import Data.List ((\\), intersect, intersectBy, nub, sort, unionBy) import Data.Char (isLower, isUpper, toLower, toUpper, isAlpha) +import qualified Data.Set.Extra as Set +import Data.Tuple.Extra + (snd3) import Curry.Base.Ident import Curry.Base.Position import Curry.Base.Pretty import Curry.Base.SpanInfo import Curry.Syntax -import Curry.Syntax.Pretty (ppDecl, ppPattern, ppExpr, ppIdent) +import Curry.Syntax.Utils (typeVariables) +import Curry.Syntax.Pretty (pPrint) -import Base.CurryTypes (ppTypeScheme) -import Base.Messages (Message, posMessage, internalError) +import Base.CurryTypes (ppTypeScheme, fromPred, toPredSet) +import Base.Messages (Message, spanInfoMessage, internalError) import Base.NestEnv ( NestEnv, emptyEnv, localNestEnv, nestEnv, unnestEnv , qualBindNestEnv, qualInLocalNestEnv, qualLookupNestEnv , qualModifyNestEnv) @@ -66,6 +72,7 @@ -- - overlapping case alternatives -- - non-adjacent function rules -- - wrong case mode +-- - redundant context warnCheck :: WarnOpts -> CaseMode -> AliasEnv -> ValueEnv -> TCEnv -> ClassEnv -> Module a -> [Message] warnCheck wOpts cOpts aEnv valEnv tcEnv clsEnv mdl @@ -76,7 +83,8 @@ checkMissingTypeSignatures ds checkModuleAlias is checkCaseMode ds - where Module _ _ mid es is ds = fmap (const ()) mdl + checkRedContext ds + where Module _ _ _ mid es is ds = fmap (const ()) mdl type ScopeEnv = NestEnv IdInfo @@ -196,16 +204,16 @@ impName (ImportTypeWith _ t _) = t warnMultiplyImportedModule :: ModuleIdent -> Message -warnMultiplyImportedModule mid = posMessage mid $ hsep $ map text +warnMultiplyImportedModule mid = spanInfoMessage mid $ hsep $ map text ["Module", moduleName mid, "is imported more than once"] warnMultiplyImportedSymbol :: ModuleIdent -> Ident -> Message -warnMultiplyImportedSymbol mid ident = posMessage ident $ hsep $ map text +warnMultiplyImportedSymbol mid ident = spanInfoMessage ident $ hsep $ map text [ "Symbol", escName ident, "from module", moduleName mid , "is imported more than once" ] warnMultiplyHiddenSymbol :: ModuleIdent -> Ident -> Message -warnMultiplyHiddenSymbol mid ident = posMessage ident $ hsep $ map text +warnMultiplyHiddenSymbol mid ident = spanInfoMessage ident $ hsep $ map text [ "Symbol", escName ident, "from module", moduleName mid , "is hidden more than once" ] @@ -244,28 +252,28 @@ check (_ , env) _ = return (mkIdent "", env) warnDisjoinedFunctionRules :: Ident -> Position -> Message -warnDisjoinedFunctionRules ident pos = posMessage ident $ hsep (map text +warnDisjoinedFunctionRules ident pos = spanInfoMessage ident $ hsep (map text [ "Rules for function", escName ident, "are disjoined" ]) <+> parens (text "first occurrence at" <+> text (showLine pos)) checkDecl :: Decl () -> WCM () -checkDecl (DataDecl _ _ vs cs _) = inNestedScope $ do +checkDecl (DataDecl _ _ vs cs _) = inNestedScope $ do mapM_ insertTypeVar vs mapM_ checkConstrDecl cs reportUnusedTypeVars vs -checkDecl (NewtypeDecl _ _ vs nc _) = inNestedScope $ do +checkDecl (NewtypeDecl _ _ vs nc _) = inNestedScope $ do mapM_ insertTypeVar vs checkNewConstrDecl nc reportUnusedTypeVars vs -checkDecl (TypeDecl _ _ vs ty) = inNestedScope $ do +checkDecl (TypeDecl _ _ vs ty) = inNestedScope $ do mapM_ insertTypeVar vs checkTypeExpr ty reportUnusedTypeVars vs -checkDecl (FunctionDecl p _ f eqs) = checkFunctionDecl p f eqs -checkDecl (PatternDecl _ p rhs) = checkPattern p >> checkRhs rhs -checkDecl (DefaultDecl _ tys) = mapM_ checkTypeExpr tys -checkDecl (ClassDecl _ _ _ _ ds) = mapM_ checkDecl ds -checkDecl (InstanceDecl p cx cls ty ds) = do +checkDecl (FunctionDecl p _ f eqs) = checkFunctionDecl p f eqs +checkDecl (PatternDecl _ p rhs) = checkPattern p >> checkRhs rhs +checkDecl (DefaultDecl _ tys) = mapM_ checkTypeExpr tys +checkDecl (ClassDecl _ _ _ _ _ ds) = mapM_ checkDecl ds +checkDecl (InstanceDecl p _ cx cls ty ds) = do checkOrphanInstance p cx cls ty checkMissingMethodImplementations p cls ds mapM_ checkDecl ds @@ -322,12 +330,15 @@ checkFunctionPatternMatch :: SpanInfo -> Ident -> [Equation ()] -> WCM () checkFunctionPatternMatch spi f eqs = do let pats = map (\(Equation _ lhs _) -> snd (flatLhs lhs)) eqs - (nonExhaustive, overlapped, nondet) <- checkPatternMatching pats + let guards = map eq2Guards eqs + (nonExhaustive, overlapped, nondet) <- checkPatternMatching pats guards unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $ - warnMissingPattern p ("an equation for " ++ escName f) nonExhaustive + warnMissingPattern spi ("an equation for " ++ escName f) nonExhaustive when (nondet || not (null overlapped)) $ warnFor WarnOverlapping $ report $ - warnNondetOverlapping p ("Function " ++ escName f) - where p = spanInfo2Pos spi + warnNondetOverlapping spi ("Function " ++ escName f) + where eq2Guards :: Equation () -> [CondExpr ()] + eq2Guards (Equation _ _ (GuardedRhs _ _ conds _)) = conds + eq2Guards _ = [] -- Check an equation for warnings. -- This is done in a seperate scope as the left-hand-side may introduce @@ -368,11 +379,11 @@ -- Because local declarations may introduce new variables, we need -- another scope nesting. checkRhs :: Rhs () -> WCM () -checkRhs (SimpleRhs _ e ds) = inNestedScope $ do +checkRhs (SimpleRhs _ _ e ds) = inNestedScope $ do checkLocalDeclGroup ds checkExpr e reportUnusedVars -checkRhs (GuardedRhs _ ce ds) = inNestedScope $ do +checkRhs (GuardedRhs _ _ ce ds) = inNestedScope $ do checkLocalDeclGroup ds mapM_ checkCondExpr ce reportUnusedVars @@ -407,16 +418,16 @@ mapM_ (insertPattern False) ps checkExpr e reportUnusedVars -checkExpr (Let _ ds e) = inNestedScope $ do +checkExpr (Let _ _ ds e) = inNestedScope $ do checkLocalDeclGroup ds checkExpr e reportUnusedVars -checkExpr (Do _ sts e) = checkStatements sts e +checkExpr (Do _ _ sts e) = checkStatements sts e checkExpr (IfThenElse _ e1 e2 e3) = mapM_ checkExpr [e1, e2, e3] -checkExpr (Case _ ct e alts) = do +checkExpr (Case spi _ ct e alts) = do checkExpr e mapM_ checkAlt alts - checkCaseAlts ct alts + checkCaseAlts spi ct alts checkExpr _ = ok checkStatements :: [Statement ()] -> Expression () -> WCM () @@ -426,9 +437,9 @@ reportUnusedVars checkStatement :: Statement () -> WCM () -checkStatement (StmtExpr _ e) = checkExpr e -checkStatement (StmtDecl _ ds) = checkLocalDeclGroup ds -checkStatement (StmtBind _ p e) = do +checkStatement (StmtExpr _ e) = checkExpr e +checkStatement (StmtDecl _ _ ds) = checkLocalDeclGroup ds +checkStatement (StmtBind _ p e) = do checkPattern p >> insertPattern False p checkExpr e @@ -452,11 +463,12 @@ let ocls = getOrigName m cls tcEnv otc = getOrigName m tc tcEnv unless (isLocalIdent m ocls || isLocalIdent m otc) $ report $ - warnOrphanInstance (spanInfo2Pos p) $ ppDecl $ InstanceDecl p cx cls ty [] + warnOrphanInstance p $ pPrint $ + InstanceDecl p WhitespaceLayout cx cls ty [] where tc = typeConstr ty -warnOrphanInstance :: Position -> Doc -> Message -warnOrphanInstance p doc = posMessage p $ text "Orphan instance:" <+> doc +warnOrphanInstance :: SpanInfo -> Doc -> Message +warnOrphanInstance spi doc = spanInfoMessage spi $ text "Orphan instance:" <+> doc -- ----------------------------------------------------------------------------- -- Check for missing method implementations @@ -469,12 +481,12 @@ clsEnv <- gets classEnv let ocls = getOrigName m cls tcEnv ms = classMethods ocls clsEnv - mapM_ (report . warnMissingMethodImplementation (spanInfo2Pos p)) $ + mapM_ (report . warnMissingMethodImplementation p) $ filter ((null fs ||) . not . flip (hasDefaultImpl ocls) clsEnv) $ ms \\ fs where fs = map unRenameIdent $ concatMap impls ds -warnMissingMethodImplementation :: Position -> Ident -> Message -warnMissingMethodImplementation p f = posMessage p $ hsep $ map text +warnMissingMethodImplementation :: SpanInfo -> Ident -> Message +warnMissingMethodImplementation spi f = spanInfoMessage spi $ hsep $ map text ["No explicit implementation for method", escName f] -- ----------------------------------------------------------------------------- @@ -502,7 +514,7 @@ _ -> internalError $ "Checks.WarnCheck.getTyScheme: " ++ show q warnMissingTypeSignature :: ModuleIdent -> Ident -> TypeScheme -> Message -warnMissingTypeSignature mid i tys = posMessage i $ fsep +warnMissingTypeSignature mid i tys = spanInfoMessage i $ fsep [ text "Top-level binding with no type signature:" , nest 2 $ text (showIdent i) <+> text "::" <+> ppTypeScheme mid tys ] @@ -524,14 +536,14 @@ unless (null aliasClash) $ mapM_ (report . warnAliasNameClash ) aliasClash warnModuleNameClash :: ModuleIdent -> Message -warnModuleNameClash mid = posMessage mid $ hsep $ map text +warnModuleNameClash mid = spanInfoMessage mid $ hsep $ map text ["The module alias", escModuleName mid , "overlaps with the current module name"] warnAliasNameClash :: [ModuleIdent] -> Message warnAliasNameClash [] = internalError "WarnCheck.warnAliasNameClash: empty list" -warnAliasNameClash mids = posMessage (head mids) $ text +warnAliasNameClash mids = spanInfoMessage (head mids) $ text "Overlapping module aliases" $+$ nest 2 (vcat (map myppAlias mids)) where myppAlias mid = ppLine (getPosition mid) <> text ":" <+> text (escModuleName mid) @@ -540,23 +552,27 @@ -- Check for overlapping/unreachable and non-exhaustive case alternatives -- ----------------------------------------------------------------------------- -checkCaseAlts :: CaseType -> [Alt ()] -> WCM () -checkCaseAlts _ [] = ok -checkCaseAlts ct alts@(Alt spi _ _ : _) = do +checkCaseAlts :: SpanInfo -> CaseType -> [Alt ()] -> WCM () +checkCaseAlts _ _ [] = ok +checkCaseAlts spi ct alts = do + let spis = map (\(Alt s _ _) -> s) alts let pats = map (\(Alt _ pat _) -> [pat]) alts - (nonExhaustive, overlapped, nondet) <- checkPatternMatching pats + let guards = map alt2Guards alts + (nonExhaustive, overlapped, nondet) <- checkPatternMatching pats guards case ct of Flex -> do unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $ - warnMissingPattern p "an fcase alternative" nonExhaustive + warnMissingPattern spi "an fcase alternative" nonExhaustive when (nondet || not (null overlapped)) $ warnFor WarnOverlapping $ report - $ warnNondetOverlapping p "An fcase expression" + $ warnNondetOverlapping spi "An fcase expression" Rigid -> do unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $ - warnMissingPattern p "a case alternative" nonExhaustive - unless (null overlapped) $ warnFor WarnOverlapping $ report $ - warnUnreachablePattern p overlapped - where p = spanInfo2Pos spi + warnMissingPattern spi "a case alternative" nonExhaustive + unless (null overlapped) $ void $ mapM (warnFor WarnOverlapping . report) $ + map (\(i, pat) -> warnUnreachablePattern (spis !! i) pat) overlapped + where alt2Guards :: Alt () -> [CondExpr ()] + alt2Guards (Alt _ _ (GuardedRhs _ _ conds _)) = conds + alt2Guards _ = [] -- ----------------------------------------------------------------------------- -- Check for non-exhaustive and overlapping patterns. @@ -574,19 +590,19 @@ -- matching in function declarations and (f)case expressions. -- ----------------------------------------------------------------------------- -checkPatternMatching :: [[Pattern ()]] - -> WCM ([ExhaustivePats], [[Pattern ()]], Bool) -checkPatternMatching pats = do +checkPatternMatching :: [[Pattern ()]] -> [[CondExpr ()]] + -> WCM ([ExhaustivePats], [OverlappingPats], Bool) +checkPatternMatching pats guards = do -- 1. We simplify the patterns by removing syntactic sugar temporarily -- for a simpler implementation. simplePats <- mapM (mapM simplifyPat) pats -- 2. We compute missing and used pattern matching alternatives - (missing, used, nondet) <- processEqs (zip [1..] simplePats) + (missing, used, nondet) <- processEqs (zip3 [0..] simplePats guards) -- 3. If any, we report the missing patterns, whereby we re-add the syntactic -- sugar removed in step (1) for a more precise output. nonExhaustive <- mapM tidyExhaustivePats missing - let overlap = [ eqn | (i, eqn) <- zip [1..] pats, i `IntSet.notMember` used] - return (nonExhaustive , overlap, nondet) + let overlap = [(i, eqn) | (i, eqn) <- zip [0..] pats, i `IntSet.notMember` used] + return (nonExhaustive, overlap, nondet) -- |Simplify a 'Pattern' until it only consists of -- * Variables @@ -649,23 +665,38 @@ -- number of possible patterns. Missing literals are therefore converted -- into the form @ ... x ... with x `notElem` [l1, ..., ln]@. type EqnPats = [Pattern ()] +type EqnGuards = [CondExpr ()] type EqnNo = Int -type EqnInfo = (EqnNo, EqnPats) +type EqnInfo = (EqnNo, EqnPats, EqnGuards) type ExhaustivePats = (EqnPats, [(Ident, [Literal])]) +type OverlappingPats = (EqnNo, EqnPats) type EqnSet = IntSet.IntSet -- |Compute the missing pattern by inspecting the first patterns and -- categorize them as literal, constructor or variable patterns. processEqs :: [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool) processEqs [] = return ([], IntSet.empty, False) -processEqs eqs@((n, ps):_) - | null ps = return ([], IntSet.singleton n, length eqs > 1) - | any isLitPat firstPats = processLits eqs - | any isConPat firstPats = processCons eqs - | all isVarPat firstPats = processVars eqs - | otherwise = internalError "Checks.WarnCheck.processEqs" +processEqs eqs@((n, ps, gs):eqs') + | null ps = if guardsExhaustive then return ([], IntSet.singleton n, length eqs > 1) + else do -- Current expression is guarded, thus potentially + -- non-exhaustive. Therefore process remaining expressions. + (missing', used', _) <- processEqs eqs' + return (missing', IntSet.insert n used', length eqs > 1) + | any isLitPat firstPats = processLits eqs + | any isConPat firstPats = processCons eqs + | all isVarPat firstPats = processVars eqs + | otherwise = internalError "Checks.WarnCheck.processEqs" where firstPats = map firstPat eqs + guardsExhaustive = null gs || any guardAlwaysTrue gs + guardAlwaysTrue :: CondExpr () -> Bool + guardAlwaysTrue (CondExpr _ e _) = case e of + Constructor _ _ q -> qidAlwaysTrue q + Variable _ _ q -> qidAlwaysTrue q + _ -> False + qidAlwaysTrue :: QualIdent -> Bool + qidAlwaysTrue q = elem (idName $ qidIdent q) ["True", "success", "otherwise"] + -- |Literal patterns are checked by extracting the matched literals -- and constructing a pattern for any missing case. @@ -688,7 +719,7 @@ defaults = [ shiftPat q' | q' <- qs, isVarPat (firstPat q') ] -- Pattern for all non-matched literals defaultPat = ( VariablePattern NoSpanInfo () newVar : - replicate (length (snd q) - 1) wildPat + replicate (length (snd3 q) - 1) wildPat , [(newVar, usedLits)] ) newVar = mkIdent "x" @@ -735,7 +766,7 @@ -- default alternatives (variable pattern) defaults = [ shiftPat q' | q' <- qs, isVarPat (firstPat q') ] -- Pattern for a non-matched constructors - defaultPat c = (mkPattern c : replicate (length (snd q) - 1) wildPat, []) + defaultPat c = (mkPattern c : replicate (length (snd3 q) - 1) wildPat, []) mkPattern c = ConstructorPattern NoSpanInfo () (qualifyLike (fst $ head used_cons) (constrIdent c)) (replicate (length $ constrTypes c) wildPat) @@ -755,17 +786,17 @@ makeCon c a ps = let (args, rest) = splitAt a ps in ConstructorPattern NoSpanInfo () c args : rest - - removeFirstCon c a (n, p:ps) - | isVarPat p = (n, replicate a wildPat ++ ps) - | isCon c p = (n, patArgs p ++ ps) + + removeFirstCon c a (n, p:ps, gs) + | isVarPat p = (n, replicate a wildPat ++ ps, gs) + | isCon c p = (n, patArgs p ++ ps, gs) removeFirstCon _ _ _ = internalError "Checks.WarnCheck.removeFirstCon" -- |Variable patterns are exhaustive, so they are checked by simply -- checking the following patterns. processVars :: [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool) processVars [] = error "WarnCheck.processVars" -processVars eqs@((n, _) : _) = do +processVars eqs@((n, _, _) : _) = do let ovlp = length eqs > 1 (missing, used, nd) <- processEqs (map shiftPat eqs) return ( map (\(xs, ys) -> (wildPat : xs, ys)) missing @@ -795,14 +826,17 @@ getTyCons tc = do tc' <- unAlias tc tcEnv <- gets tyConsEnv - return $ case lookupTypeInfo (unqualify tc) tcEnv of - [DataType _ _ cs] -> cs - [RenamingType _ _ nc] -> [nc] - _ -> case qualLookupTypeInfo tc' tcEnv of - [DataType _ _ cs] -> cs - [RenamingType _ _ nc] -> [nc] - err -> internalError $ "Checks.WarnCheck.getTyCons: " ++ - show tc ++ ' ' : show err ++ '\n' : show tcEnv + let getTyCons' :: [TypeInfo] -> Either String [DataConstr] + getTyCons' ti = case ti of + [DataType _ _ cs] -> Right cs + [RenamingType _ _ nc] -> Right $ [nc] + _ -> Left $ "Checks.WarnCheck.getTyCons: " ++ show tc ++ ' ' : show ti ++ '\n' : show tcEnv + csResult = getTyCons' (qualLookupTypeInfo tc tcEnv) + <|> getTyCons' (qualLookupTypeInfo tc' tcEnv) + <|> getTyCons' (lookupTypeInfo (unqualify tc) tcEnv) -- Fall back on unqualified lookup if qualified doesn't work + case csResult of + Right cs -> return cs + Left err -> internalError err -- |Resugar the exhaustive patterns previously desugared at 'simplifyPat'. tidyExhaustivePats :: ExhaustivePats -> WCM ExhaustivePats @@ -842,13 +876,13 @@ -- |Get the first pattern of a list. firstPat :: EqnInfo -> Pattern () -firstPat (_, [] ) = internalError "Checks.WarnCheck.firstPat: empty list" -firstPat (_, (p:_)) = p +firstPat (_, [], _) = internalError "Checks.WarnCheck.firstPat: empty list" +firstPat (_, (p:_), _) = p -- |Drop the first pattern of a list. shiftPat :: EqnInfo -> EqnInfo -shiftPat (_, [] ) = internalError "Checks.WarnCheck.shiftPat: empty list" -shiftPat (n, (_:ps)) = (n, ps) +shiftPat (_, [], _ ) = internalError "Checks.WarnCheck.shiftPat: empty list" +shiftPat (n, (_:ps), gs) = (n, ps, gs) -- |Wildcard pattern. wildPat :: Pattern () @@ -905,8 +939,8 @@ -- |Warning message for non-exhaustive patterns. -- To shorten the output only the first 'maxPattern' are printed, -- additional pattern are abbreviated by dots. -warnMissingPattern :: Position -> String -> [ExhaustivePats] -> Message -warnMissingPattern p loc pats = posMessage p +warnMissingPattern :: SpanInfo -> String -> [ExhaustivePats] -> Message +warnMissingPattern spi loc pats = spanInfoMessage spi $ text "Pattern matches are non-exhaustive" $+$ text "In" <+> text loc <> char ':' $+$ nest 2 (text "Patterns not matched:" $+$ nest 2 (vcat (ppExPats pats))) @@ -918,31 +952,27 @@ ppExPat (ps, cs) | null cs = ppPats | otherwise = ppPats <+> text "with" <+> hsep (map ppCons cs) - where ppPats = hsep (map (ppPattern 2) ps) - ppCons (i, lits) = ppIdent i <+> text "`notElem`" - <+> ppExpr 0 (List NoSpanInfo () (map (Literal NoSpanInfo ()) lits)) + where ppPats = hsep (map (pPrintPrec 2) ps) + ppCons (i, lits) = pPrint i <+> text "`notElem`" + <+> pPrintPrec 0 (List NoSpanInfo () (map (Literal NoSpanInfo ()) lits)) -- |Warning message for unreachable patterns. -- To shorten the output only the first 'maxPattern' are printed, -- additional pattern are abbreviated by dots. -warnUnreachablePattern :: Position -> [[Pattern a]] -> Message -warnUnreachablePattern p pats = posMessage p +warnUnreachablePattern :: SpanInfo -> [Pattern a] -> Message +warnUnreachablePattern spi pats = spanInfoMessage spi $ text "Pattern matches are potentially unreachable" $+$ text "In a case alternative:" - $+$ nest 2 (vcat (ppExPats pats) <+> text "->" <+> text "...") + $+$ nest 2 (ppPat pats <+> text "->" <+> text "...") where - ppExPats ps - | length ps > maxPattern = ppPats ++ [text "..."] - | otherwise = ppPats - where ppPats = map ppPat (take maxPattern ps) - ppPat ps = hsep (map (ppPattern 2) ps) + ppPat ps = hsep (map (pPrintPrec 2) ps) -- |Maximum number of missing patterns to be shown. maxPattern :: Int maxPattern = 4 -warnNondetOverlapping :: Position -> String -> Message -warnNondetOverlapping p loc = posMessage p $ +warnNondetOverlapping :: SpanInfo -> String -> Message +warnNondetOverlapping spi loc = spanInfoMessage spi $ text loc <+> text "is potentially non-deterministic due to overlapping rules" -- ----------------------------------------------------------------------------- @@ -951,10 +981,6 @@ checkShadowing x = warnFor WarnNameShadowing $ shadowsVar x >>= maybe ok (report . warnShadowing x) -checkTypeShadowing :: Ident -> WCM () -checkTypeShadowing x = warnFor WarnNameShadowing $ - shadowsTypeVar x >>= maybe ok (report . warnTypeShadowing x) - reportUnusedVars :: WCM () reportUnusedVars = reportAllUnusedVars WarnUnusedBindings @@ -977,26 +1003,26 @@ -- sides. insertDecl :: Decl a -> WCM () -insertDecl (DataDecl _ d _ cs _) = do +insertDecl (DataDecl _ d _ cs _) = do insertTypeConsId d mapM_ insertConstrDecl cs -insertDecl (ExternalDataDecl _ d _) = insertTypeConsId d -insertDecl (NewtypeDecl _ d _ nc _) = do +insertDecl (ExternalDataDecl _ d _) = insertTypeConsId d +insertDecl (NewtypeDecl _ d _ nc _) = do insertTypeConsId d insertNewConstrDecl nc -insertDecl (TypeDecl _ t _ ty) = do +insertDecl (TypeDecl _ t _ ty) = do insertTypeConsId t insertTypeExpr ty -insertDecl (FunctionDecl _ _ f _) = do +insertDecl (FunctionDecl _ _ f _) = do cons <- isConsId f unless cons $ insertVar f -insertDecl (ExternalDecl _ vs) = mapM_ (insertVar . varIdent) vs -insertDecl (PatternDecl _ p _) = insertPattern False p -insertDecl (FreeDecl _ vs) = mapM_ (insertVar . varIdent) vs -insertDecl (ClassDecl _ _ cls _ ds) = do +insertDecl (ExternalDecl _ vs) = mapM_ (insertVar . varIdent) vs +insertDecl (PatternDecl _ p _) = insertPattern False p +insertDecl (FreeDecl _ vs) = mapM_ (insertVar . varIdent) vs +insertDecl (ClassDecl _ _ _ cls _ ds) = do insertTypeConsId cls mapM_ insertVar $ concatMap methods ds -insertDecl _ = ok +insertDecl _ = ok insertTypeExpr :: TypeExpr -> WCM () insertTypeExpr (VariableType _ _) = ok @@ -1116,9 +1142,6 @@ shadowsVar :: Ident -> WCM (Maybe Ident) shadowsVar v = gets (shadows $ commonId v) -shadowsTypeVar :: Ident -> WCM (Maybe Ident) -shadowsTypeVar v = gets (shadows $ typeId v) - visitId :: Ident -> WCM () visitId v = modifyScope (qualModifyNestEnv visitVariable (commonId v)) @@ -1163,7 +1186,7 @@ isUnref :: WcState -> QualIdent -> Bool isUnref s qid = let sc = scope s - in (any (not . variableVisited) (qualLookupNestEnv qid sc)) + in any (not . variableVisited) (qualLookupNestEnv qid sc) && qualInLocalNestEnv qid sc isVar :: QualIdent -> WcState -> Bool @@ -1229,12 +1252,12 @@ checkCaseModeDecl (FreeDecl _ vs) = mapM_ (checkCaseModeID isVarName . varIdent) vs checkCaseModeDecl (DefaultDecl _ tys) = mapM_ checkTypeExpr tys -checkCaseModeDecl (ClassDecl _ cx cls tv ds) = do +checkCaseModeDecl (ClassDecl _ _ cx cls tv ds) = do checkCaseModeContext cx checkCaseModeID isClassDeclName cls checkCaseModeID isVarName tv mapM_ checkCaseModeDecl ds -checkCaseModeDecl (InstanceDecl _ cx _ inst ds) = do +checkCaseModeDecl (InstanceDecl _ _ cx _ inst ds) = do checkCaseModeContext cx checkCaseModeTypeExpr inst mapM_ checkCaseModeDecl ds @@ -1311,10 +1334,10 @@ mapM_ checkCaseModePattern ts checkCaseModeRhs :: Rhs a -> WCM () -checkCaseModeRhs (SimpleRhs _ e ds) = do +checkCaseModeRhs (SimpleRhs _ _ e ds) = do checkCaseModeExpr e mapM_ checkCaseModeDecl ds -checkCaseModeRhs (GuardedRhs _ es ds) = do +checkCaseModeRhs (GuardedRhs _ _ es ds) = do mapM_ checkCaseModeCondExpr es mapM_ checkCaseModeDecl ds @@ -1382,25 +1405,25 @@ checkCaseModeExpr (Lambda _ ts e) = do mapM_ checkCaseModePattern ts checkCaseModeExpr e -checkCaseModeExpr (Let _ ds e) = do +checkCaseModeExpr (Let _ _ ds e) = do mapM_ checkCaseModeDecl ds checkCaseModeExpr e -checkCaseModeExpr (Do _ stms e) = do +checkCaseModeExpr (Do _ _ stms e) = do mapM_ checkCaseModeStatement stms checkCaseModeExpr e checkCaseModeExpr (IfThenElse _ e1 e2 e3) = do checkCaseModeExpr e1 checkCaseModeExpr e2 checkCaseModeExpr e3 -checkCaseModeExpr (Case _ _ e as) = do +checkCaseModeExpr (Case _ _ _ e as) = do mapM_ checkCaseModeAlt as checkCaseModeExpr e checkCaseModeExpr _ = ok checkCaseModeStatement :: Statement a -> WCM () -checkCaseModeStatement (StmtExpr _ e) = checkCaseModeExpr e -checkCaseModeStatement (StmtDecl _ ds) = mapM_ checkCaseModeDecl ds -checkCaseModeStatement (StmtBind _ t e) = do +checkCaseModeStatement (StmtExpr _ e) = checkCaseModeExpr e +checkCaseModeStatement (StmtDecl _ _ ds) = mapM_ checkCaseModeDecl ds +checkCaseModeStatement (StmtBind _ t e) = do checkCaseModePattern t checkCaseModeExpr e @@ -1443,11 +1466,151 @@ isDataDeclName _ _ = True -- --------------------------------------------------------------------------- +-- Warn for redundant context +-- --------------------------------------------------------------------------- + +--traverse the AST for QualTypeExpr/Context and check for redundancy +checkRedContext :: [Decl a] -> WCM () +checkRedContext = warnFor WarnRedundantContext . mapM_ checkRedContextDecl + +getRedPredSet :: ModuleIdent -> ClassEnv -> TCEnv -> PredSet -> PredSet +getRedPredSet m cenv tcEnv ps = + Set.map (pm Map.!) $ Set.difference qps $ minPredSet cenv qps --or fromJust $ Map.lookup + where (qps, pm) = Set.foldr qualifyAndAddPred (Set.empty, Map.empty) ps + qualifyAndAddPred p@(Pred qid ty) (ps', pm') = + let qp = Pred (getOrigName m qid tcEnv) ty + in (Set.insert qp ps', Map.insert qp p pm') + +getPredFromContext :: Context -> ([Ident], PredSet) +getPredFromContext cx = + let vs = concatMap (\(Constraint _ _ ty) -> typeVariables ty) cx + in (vs, toPredSet vs cx) + +checkRedContext' :: (Pred -> Message) -> PredSet -> WCM () +checkRedContext' f ps = do + m <- gets moduleId + cenv <- gets classEnv + tcEnv <- gets tyConsEnv + mapM_ (report . f) (getRedPredSet m cenv tcEnv ps) + +checkRedContextDecl :: Decl a -> WCM () +checkRedContextDecl (TypeSig _ ids (QualTypeExpr _ cx _)) = + checkRedContext' (warnRedContext (warnRedFuncString ids) vs) ps + where (vs, ps) = getPredFromContext cx +checkRedContextDecl (FunctionDecl _ _ _ eqs) = mapM_ checkRedContextEq eqs +checkRedContextDecl (PatternDecl _ _ rhs) = checkRedContextRhs rhs +checkRedContextDecl (ClassDecl _ _ cx i _ ds) = do + checkRedContext' + (warnRedContext (text ("class declaration " ++ escName i)) vs) + ps + mapM_ checkRedContextDecl ds + where (vs, ps) = getPredFromContext cx +checkRedContextDecl (InstanceDecl _ _ cx qid _ ds) = do + checkRedContext' + (warnRedContext (text ("instance declaration " ++ escQualName qid)) vs) + ps + mapM_ checkRedContextDecl ds + where (vs, ps) = getPredFromContext cx +checkRedContextDecl _ = return () + +checkRedContextEq :: Equation a -> WCM () +checkRedContextEq (Equation _ _ rhs) = checkRedContextRhs rhs + +checkRedContextRhs :: Rhs a -> WCM () +checkRedContextRhs (SimpleRhs _ _ e ds) = do + checkRedContextExpr e + mapM_ checkRedContextDecl ds +checkRedContextRhs (GuardedRhs _ _ cs ds) = do + mapM_ checkRedContextCond cs + mapM_ checkRedContextDecl ds + +checkRedContextCond :: CondExpr a -> WCM () +checkRedContextCond (CondExpr _ e1 e2) = do + checkRedContextExpr e1 + checkRedContextExpr e2 + +checkRedContextExpr :: Expression a -> WCM () +checkRedContextExpr (Paren _ e) = checkRedContextExpr e +checkRedContextExpr (Typed _ e (QualTypeExpr _ cx _)) = do + checkRedContextExpr e + checkRedContext' (warnRedContext (text "type signature") vs) ps + where (vs, ps) = getPredFromContext cx +checkRedContextExpr (Record _ _ _ fs) = mapM_ checkRedContextFieldExpr fs +checkRedContextExpr (RecordUpdate _ e fs) = do + checkRedContextExpr e + mapM_ checkRedContextFieldExpr fs +checkRedContextExpr (Tuple _ es) = mapM_ checkRedContextExpr es +checkRedContextExpr (List _ _ es) = mapM_ checkRedContextExpr es +checkRedContextExpr (ListCompr _ e sts) = do + checkRedContextExpr e + mapM_ checkRedContextStmt sts +checkRedContextExpr (EnumFrom _ e) = checkRedContextExpr e +checkRedContextExpr (EnumFromThen _ e1 e2) = do + checkRedContextExpr e1 + checkRedContextExpr e2 +checkRedContextExpr (EnumFromTo _ e1 e2) = do + checkRedContextExpr e1 + checkRedContextExpr e2 +checkRedContextExpr (EnumFromThenTo _ e1 e2 e3) = do + checkRedContextExpr e1 + checkRedContextExpr e2 + checkRedContextExpr e3 +checkRedContextExpr (UnaryMinus _ e) = checkRedContextExpr e +checkRedContextExpr (Apply _ e1 e2) = do + checkRedContextExpr e1 + checkRedContextExpr e2 +checkRedContextExpr (InfixApply _ e1 _ e2) = do + checkRedContextExpr e1 + checkRedContextExpr e2 +checkRedContextExpr (LeftSection _ e _) = checkRedContextExpr e +checkRedContextExpr (RightSection _ _ e) = checkRedContextExpr e +checkRedContextExpr (Lambda _ _ e) = checkRedContextExpr e +checkRedContextExpr (Let _ _ ds e) = do + mapM_ checkRedContextDecl ds + checkRedContextExpr e +checkRedContextExpr (IfThenElse _ e1 e2 e3) = do + checkRedContextExpr e1 + checkRedContextExpr e2 + checkRedContextExpr e3 +checkRedContextExpr (Case _ _ _ e as) = do + checkRedContextExpr e + mapM_ checkRedContextAlt as +checkRedContextExpr _ = return () + +checkRedContextStmt :: Statement a -> WCM () +checkRedContextStmt (StmtExpr _ e) = checkRedContextExpr e +checkRedContextStmt (StmtDecl _ _ ds) = mapM_ checkRedContextDecl ds +checkRedContextStmt (StmtBind _ _ e) = checkRedContextExpr e + +checkRedContextAlt :: Alt a -> WCM () +checkRedContextAlt (Alt _ _ rhs) = checkRedContextRhs rhs + +checkRedContextFieldExpr :: Field (Expression a) -> WCM () +checkRedContextFieldExpr (Field _ _ e) = checkRedContextExpr e + +-- --------------------------------------------------------------------------- -- Warnings messages -- --------------------------------------------------------------------------- +warnRedFuncString :: [Ident] -> Doc +warnRedFuncString is = text "type signature for function" <> + text (if length is == 1 then [] else "s") <+> + csep (map (text . escName) is) + +-- Doc description -> TypeVars -> Pred -> Warning +warnRedContext :: Doc -> [Ident] -> Pred -> Message +warnRedContext d vs p@(Pred qid _) = spanInfoMessage qid $ + text "Redundant context in" <+> d <> colon <+> + quotes (pPrint $ fromPred vs p) -- idents use ` ' as quotes not ' ' + +-- seperate a list by ', ' +csep :: [Doc] -> Doc +csep [] = empty +csep [x] = x +csep (x:xs) = x <> comma <+> csep xs + warnCaseMode :: Ident -> CaseMode -> Message -warnCaseMode i@(Ident _ name _ ) c = posMessage i $ +warnCaseMode i@(Ident _ name _ ) c = spanInfoMessage i $ text "Wrong case mode in symbol" <+> text (escName i) <+> text "due to selected case mode" <+> text (escapeCaseMode c) <> comma <+> text "try renaming to" <+> text (caseSuggestion name) <+> text "instead" @@ -1465,19 +1628,14 @@ escapeCaseMode CaseModeGoedel = "`goedel`" warnUnrefTypeVar :: Ident -> Message -warnUnrefTypeVar v = posMessage v $ hsep $ map text +warnUnrefTypeVar v = spanInfoMessage v $ hsep $ map text [ "Unreferenced type variable", escName v ] warnUnrefVar :: Ident -> Message -warnUnrefVar v = posMessage v $ hsep $ map text +warnUnrefVar v = spanInfoMessage v $ hsep $ map text [ "Unused declaration of variable", escName v ] warnShadowing :: Ident -> Ident -> Message -warnShadowing x v = posMessage x $ +warnShadowing x v = spanInfoMessage x $ text "Shadowing symbol" <+> text (escName x) - <> comma <+> text "bound at:" <+> ppPosition (getPosition v) - -warnTypeShadowing :: Ident -> Ident -> Message -warnTypeShadowing x v = posMessage x $ - text "Shadowing type variable" <+> text (escName x) <> comma <+> text "bound at:" <+> ppPosition (getPosition v) diff --git a/src/CompilerOpts.hs b/src/CompilerOpts.hs --- a/src/CompilerOpts.hs +++ b/src/CompilerOpts.hs @@ -18,8 +18,9 @@ -} module CompilerOpts ( Options (..), CppOpts (..), PrepOpts (..), WarnOpts (..), DebugOpts (..) - , CaseMode (..), CymakeMode (..), Verbosity (..), TargetType (..) - , WarnFlag (..), KnownExtension (..), DumpLevel (..), dumpLevel + , OptimizationOpts(..), CaseMode (..), CymakeMode (..), Verbosity (..) + , TargetType (..), WarnFlag (..), KnownExtension (..), DumpLevel (..) + , dumpLevel , defaultOptions, defaultPrepOpts, defaultWarnOpts, defaultDebugOpts , getCompilerOpts, updateOpts, usage ) where @@ -33,7 +34,7 @@ import System.FilePath ( addTrailingPathSeparator, normalise , splitSearchPath ) -import Curry.Files.Filenames (currySubdir) +import Curry.Files.Filenames (defaultOutDir) import Curry.Syntax.Extension -- ----------------------------------------------------------------------------- @@ -43,24 +44,26 @@ -- |Compiler options data Options = Options -- general - { optMode :: CymakeMode -- ^ modus operandi - , optVerbosity :: Verbosity -- ^ verbosity level + { optMode :: CymakeMode -- ^ modus operandi + , optVerbosity :: Verbosity -- ^ verbosity level -- compilation - , optForce :: Bool -- ^ force (re-)compilation of target - , optLibraryPaths :: [FilePath] -- ^ directories to search in - -- for libraries - , optImportPaths :: [FilePath] -- ^ directories to search in - -- for imports - , optHtmlDir :: Maybe FilePath -- ^ output directory for HTML - , optUseSubdir :: Bool -- ^ use subdir for output? - , optInterface :: Bool -- ^ create a FlatCurry interface file? - , optPrepOpts :: PrepOpts -- ^ preprocessor options - , optWarnOpts :: WarnOpts -- ^ warning options - , optTargetTypes :: [TargetType] -- ^ what to generate - , optExtensions :: [KnownExtension] -- ^ enabled language extensions - , optDebugOpts :: DebugOpts -- ^ debug options - , optCaseMode :: CaseMode -- ^ case mode - , optCppOpts :: CppOpts -- ^ C preprocessor options + , optForce :: Bool -- ^ force (re-)compilation of target + , optLibraryPaths :: [FilePath] -- ^ directories to search in + -- for libraries + , optImportPaths :: [FilePath] -- ^ directories to search in + -- for imports + , optOutDir :: FilePath -- ^ output directory for FlatCurry, ... + , optHtmlDir :: Maybe FilePath -- ^ output directory for HTML + , optUseOutDir :: Bool -- ^ use subdir for output? + , optInterface :: Bool -- ^ create a FlatCurry interface file? + , optPrepOpts :: PrepOpts -- ^ preprocessor options + , optWarnOpts :: WarnOpts -- ^ warning options + , optTargetTypes :: [TargetType] -- ^ what to generate + , optExtensions :: [KnownExtension] -- ^ enabled language extensions + , optDebugOpts :: DebugOpts -- ^ debug options + , optCaseMode :: CaseMode -- ^ case mode + , optCppOpts :: CppOpts -- ^ C preprocessor options + , optOptimizations :: OptimizationOpts -- ^ Optimization options } deriving Show -- |C preprocessor options @@ -100,24 +103,32 @@ , dbDumpSimple :: Bool -- ^ print more readable environments } deriving Show +data OptimizationOpts = OptimizationOpts + { optDesugarNewtypes :: Bool -- ^ Desugar newtypes + , optInlineDictionaries :: Bool -- ^ Inline type class dictionaries + , optRemoveUnusedImports :: Bool -- ^ Remove unused imports in IL + } deriving Show + -- | Default compiler options defaultOptions :: Options defaultOptions = Options - { optMode = ModeMake - , optVerbosity = VerbStatus - , optForce = False - , optLibraryPaths = [] - , optImportPaths = [] - , optHtmlDir = Nothing - , optUseSubdir = True - , optInterface = True - , optPrepOpts = defaultPrepOpts - , optWarnOpts = defaultWarnOpts - , optTargetTypes = [] - , optExtensions = [] - , optDebugOpts = defaultDebugOpts - , optCaseMode = CaseModeFree - , optCppOpts = defaultCppOpts + { optMode = ModeMake + , optVerbosity = VerbStatus + , optForce = False + , optLibraryPaths = [] + , optImportPaths = [] + , optOutDir = defaultOutDir + , optHtmlDir = Nothing + , optUseOutDir = True + , optInterface = True + , optPrepOpts = defaultPrepOpts + , optWarnOpts = defaultWarnOpts + , optTargetTypes = [] + , optExtensions = [] + , optDebugOpts = defaultDebugOpts + , optCaseMode = CaseModeFree + , optCppOpts = defaultCppOpts + , optOptimizations = defaultOptimizationOpts } -- | Default C preprocessor options @@ -153,6 +164,13 @@ , dbDumpSimple = False } +defaultOptimizationOpts :: OptimizationOpts +defaultOptimizationOpts = OptimizationOpts + { optDesugarNewtypes = False + , optInlineDictionaries = True + , optRemoveUnusedImports = True + } + -- |Modus operandi of the program data CymakeMode = ModeHelp -- ^ Show help information and exit @@ -179,11 +197,11 @@ | Comments -- ^ Source code comments | Parsed -- ^ Parsed source code | FlatCurry -- ^ FlatCurry + | AnnotatedFlatCurry -- ^ Annotated FlatCurry | TypedFlatCurry -- ^ Typed FlatCurry - | TypeAnnotatedFlatCurry -- ^ Type-annotated FlatCurry - | AbstractCurry -- ^ AbstractCurry - | UntypedAbstractCurry -- ^ Untyped AbstractCurry - | Html -- ^ HTML documentation + | AbstractCurry -- ^ AbstractCurry + | UntypedAbstractCurry -- ^ Untyped AbstractCurry + | Html -- ^ HTML documentation | AST -- ^ Abstract-Syntax-Tree after checks | ShortAST -- ^ Abstract-Syntax-Tree with shortened decls deriving (Eq, Show) @@ -200,7 +218,8 @@ | WarnMissingSignatures -- ^ Warn for missing type signatures | WarnMissingMethods -- ^ Warn for missing method implementations | WarnOrphanInstances -- ^ Warn for orphan instances - | WarnIrregularCaseMode + | WarnIrregularCaseMode -- ^ Warn for irregular case mode + | WarnRedundantContext -- ^ Warn for redundant context in type signatures deriving (Eq, Bounded, Enum, Show) -- |Warning flags enabled by default @@ -209,7 +228,7 @@ [ WarnMultipleImports , WarnDisjoinedRules --, WarnUnusedGlobalBindings , WarnUnusedBindings , WarnNameShadowing , WarnOverlapping , WarnIncompletePatterns, WarnMissingSignatures, WarnMissingMethods - , WarnIrregularCaseMode + , WarnIrregularCaseMode , WarnRedundantContext ] -- |Description and flag of warnings flags @@ -237,6 +256,8 @@ , "orphan instances" ) , ( WarnIrregularCaseMode , "irregular-case-mode" , "irregular case mode") + , ( WarnRedundantContext , "redundant-context" + , "redundant context") ] -- |Dump level @@ -340,6 +361,10 @@ onDebugOpts f (opts, errs) = (opts { optDebugOpts = f (optDebugOpts opts) }, errs) +onOptimOpts :: (OptimizationOpts -> OptimizationOpts) -> OptErr -> OptErr +onOptimOpts f (opts, errs) + = (opts { optOptimizations = f (optOptimizations opts) }, errs) + withArg :: ((a -> b) -> OptErr -> OptErr) -> (String -> a -> b) -> String -> OptErr -> OptErr withArg lift f arg = lift (f arg) @@ -405,13 +430,16 @@ map (normalise . addTrailingPathSeparator) (splitSearchPath arg) }) "dir[:dir]") "search for imports in dir[:dir]" + , Option "o" ["outdir"] + (ReqArg (withArg onOpts $ \ arg opts -> opts { optOutDir = arg }) "dir") + "write compilation artifacts (FlatCurry, ...) into directory `dir'" , Option [] ["htmldir"] (ReqArg (withArg onOpts $ \ arg opts -> opts { optHtmlDir = Just arg }) "dir") "write HTML documentation into directory `dir'" - , Option "" ["no-subdir"] - (NoArg (onOpts $ \ opts -> opts { optUseSubdir = False })) - ("disable writing to `" ++ currySubdir ++ "' subdirectory") + , Option "" ["no-outdir", "no-subdir"] + (NoArg (onOpts $ \ opts -> opts { optUseOutDir = False })) + ("disable writing to `" ++ defaultOutDir ++ "' subdirectory") , Option "" ["no-intf"] (NoArg (onOpts $ \ opts -> opts { optInterface = False })) "do not create an interface file" @@ -434,7 +462,7 @@ "generate FlatCurry code" , targetOption TypedFlatCurry "typed-flat" "generate typed FlatCurry code" - , targetOption TypeAnnotatedFlatCurry "type-annotated-flat" + , targetOption AnnotatedFlatCurry "type-annotated-flat" "generate type-annotated FlatCurry code" , targetOption AbstractCurry "acy" "generate typed AbstractCurry" @@ -462,10 +490,11 @@ (NoArg (onOpts $ \ opts -> opts { optExtensions = nub $ kielExtensions ++ optExtensions opts })) "enable extended Curry functionalities" - , mkOptDescr onOpts "c" ["case-mode"] "mode" "case mode" caseModeDescriptions - , mkOptDescr onOpts "X" [] "ext" "language extension" extDescriptions - , mkOptDescr onWarnOpts "W" [] "opt" "warning option" warnDescriptions - , mkOptDescr onDebugOpts "d" [] "opt" "debug option" debugDescriptions + , mkOptDescr onOpts "c" ["case-mode"] "mode" "case mode" caseModeDescriptions + , mkOptDescr onOpts "X" [] "ext" "language extension" extDescriptions + , mkOptDescr onWarnOpts "W" [] "opt" "warning option" warnDescriptions + , mkOptDescr onDebugOpts "d" [] "opt" "debug option" debugDescriptions + , mkOptDescr onOptimOpts "O" [] "opt" "optimization option" optimizeDescriptions , Option "" ["cpp"] (NoArg (onCppOpts $ \ opts -> opts { cppRun = True })) "run C preprocessor" @@ -480,7 +509,7 @@ = onCppOpts (addCppDefinition s v) optErr | otherwise = addErr (cppDefinitionErr arg) optErr - where (s, v) = fmap (drop 1) $ break ('=' ==) arg + where (s, v) = drop 1 <$> break ('=' ==) arg addCppDefinition :: String -> String -> CppOpts -> CppOpts addCppDefinition s v opts = @@ -490,9 +519,9 @@ cppDefinitionErr = (++) "Invalid format for option '-D': " targetOption :: TargetType -> String -> String -> OptDescr (OptErr -> OptErr) -targetOption ty flag desc +targetOption ty flag = Option "" [flag] (NoArg (onOpts $ \ opts -> opts { optTargetTypes = - nub $ ty : optTargetTypes opts })) desc + nub $ ty : optTargetTypes opts })) verbDescriptions :: OptErrTable Options verbDescriptions = map toDescr verbosities @@ -562,11 +591,27 @@ = (name , "dump code after " ++ desc , \ opts -> opts { dbDumpLevels = addFlag flag (dbDumpLevels opts)}) +optimizeDescriptions :: OptErrTable OptimizationOpts +optimizeDescriptions = + [ ( "desugar-newtypes" , "desugars newtypes in FlatCurry" + , \ opts -> opts { optDesugarNewtypes = True }) + , ( "inline-dictionaries" , "inlines type class dictionaries" + , \ opts -> opts { optInlineDictionaries = True }) + , ( "remove-unused-imports" , "removes unused imports" + , \ opts -> opts { optRemoveUnusedImports = True }) + , ( "no-desugar-newtypes" , "prevents desugaring of newtypes in FlatCurry" + , \ opts -> opts { optDesugarNewtypes = False }) + , ( "no-inline-dictionaries" , "prevents inlining of type class dictionaries" + , \ opts -> opts { optInlineDictionaries = False }) + , ( "no-remove-unused-imports", "prevents removing of unused imports" + , \ opts -> opts { optRemoveUnusedImports = False }) + ] + addFlag :: Eq a => a -> [a] -> [a] addFlag o opts = nub $ o : opts removeFlag :: Eq a => a -> [a] -> [a] -removeFlag o opts = filter (/= o) opts +removeFlag o = filter (/= o) -- |Update the 'Options' record by the parsed and processed arguments updateOpts :: Options -> [String] -> (Options, [String], [String]) diff --git a/src/Curry/AbstractCurry.hs b/src/Curry/AbstractCurry.hs new file mode 100644 --- /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 --- /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 --- /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 3.0" + +-- |A module name. +type MName = String + +-- |A qualified name. +-- In AbstractCurry all names are qualified to avoid name clashes. +-- The first component is the module name and the second component the +-- unqualified name as it occurs in the source program. +type QName = (MName, String) + +-- |Data type to specify the visibility of various entities. +data CVisibility + = Public -- ^ exported entity + | Private -- ^ private entity + deriving (Eq, Read, Show) + +-- |A Curry module in the intermediate form. A value of this type has the form +-- @ +-- CurryProg modname imports dfltdecl clsdecls instdecls typedecls funcdecls opdecls +-- @ +-- where +-- [@modname@] Name of this module +-- [@imports@] List of modules names that are imported +-- [@dfltdecl@] Optional default declaration +-- [@clsdecls@] Class declarations +-- [@instdecls@] Instance declarations +-- [@typedecls@] Type declarations +-- [@funcdecls@] Function declarations +-- [@opdecls@] Operator precedence declarations +data CurryProg = CurryProg MName [MName] (Maybe CDefaultDecl) [CClassDecl] + [CInstanceDecl] [CTypeDecl] [CFuncDecl] [COpDecl] + deriving (Eq, Read, Show) + +-- |Default declaration. +data CDefaultDecl = CDefaultDecl [CTypeExpr] + deriving (Eq, Read, Show) + +-- |Definitions of type classes. +-- A type class definition of the form +-- @ +-- class cx => c a where { ...;f :: t;... } +-- @ +-- is represented by the Curry term +-- @ +-- (CClass c v cx tv [...(CFunc f ar v t [...,CRule r,...])...]) +-- @ +-- where @tv@ is the index of the type variable @a@ and @v@ is the +-- visibility of the type class resp. method. +-- /Note:/ The type variable indices are unique inside each class +-- declaration and are usually numbered from 0. +-- The methods' types share the type class' type variable index +-- as the class variable has to occur in a method's type signature. +-- The list of rules for a method's declaration may be empty if +-- no default implementation is provided. The arity @ar@ is +-- determined by a given default implementation or 0. +-- Regardless of whether typed or untyped abstract curry is generated, +-- the methods' declarations are always typed. +data CClassDecl = CClass QName CVisibility CContext CTVarIName [CFuncDecl] + deriving (Eq, Read, Show) + +-- |Definitions of instances. +-- An instance definition of the form +-- @ +-- instance cx => c ty where { ...;fundecl;... } +-- @ +-- is represented by the Curry term +-- @ +-- (CInstance c cx ty [...fundecl...]) +-- @ +-- /Note:/ The type variable indices are unique inside each instance +-- declaration and are usually numbered from 0. +-- The methods' types use the instance's type variable indices +-- (if typed abstract curry is generated). +data CInstanceDecl = CInstance QName CContext CTypeExpr [CFuncDecl] + deriving (Eq, Read, Show) + +-- |Definitions of algebraic data types and type synonyms. +-- A data type definition of the form +-- @ +-- data t x1...xn = ...| forall y1...ym . cx => c t1....tkc |... +-- deriving (d1,...,dp) +-- @ +-- is represented by the Curry term +-- @ +-- (CType t v [i1,...,in] [...(CCons [l1,...,lm] cx c kc v [t1,...,tkc])...] +-- [d1,...,dp]) +-- @ +-- where each @ij@ is the index of the type variable @xj@, each @lj@ is the +-- index of the existentially quantified type variable @yj@ and @v@ is the +-- visibility of the type resp. constructor. +-- /Note:/ The type variable indices are unique inside each type declaration +-- and are usually numbered from 0. +-- Thus, a data type declaration consists of the name of the data type, +-- a list of type parameters and a list of constructor declarations. +data CTypeDecl + -- |algebraic data type + = CType QName CVisibility [CTVarIName] [CConsDecl] [QName] + -- |type synonym + | CTypeSyn QName CVisibility [CTVarIName] CTypeExpr + -- |renaming type, may have only exactly one type expression + -- in the constructor declaration and no existentially type variables and + -- no context + | CNewType QName CVisibility [CTVarIName] CConsDecl [QName] + deriving (Eq, Read, Show) + +-- |The type for representing type variables. +-- They are represented by @(i,n)@ where @i@ is a type variable index +-- which is unique inside a function and @n@ is a name (if possible, +-- the name written in the source program). +type CTVarIName = (Int, String) + +-- |A constructor declaration consists of the name of the constructor +-- and a list of the argument types of the constructor. +-- The arity equals the number of types. +data CConsDecl + = CCons QName CVisibility [CTypeExpr] + | CRecord QName CVisibility [CFieldDecl] + deriving (Eq, Read, Show) + +-- |A record field declaration consists of the name of the +-- the label, the visibility and its corresponding type. +data CFieldDecl = CField QName CVisibility CTypeExpr + deriving (Eq, Read, Show) + +-- |The type for representing a class constraint. +type CConstraint = (QName, CTypeExpr) + +-- |The type for representing a context. +data CContext = CContext [CConstraint] + deriving (Eq, Read, Show) + +-- |Type expression. +-- A type expression is either a type variable, a function type, +-- a type constructor or a type application. +data CTypeExpr + -- |Type variable + = CTVar CTVarIName + -- |Function type @t1 -> t2@ + | CFuncType CTypeExpr CTypeExpr + -- |Type constructor + | CTCons QName + -- |Type application + | CTApply CTypeExpr CTypeExpr + deriving (Eq, Read, Show) + +-- |Qualified type expression. +data CQualTypeExpr = CQualType CContext CTypeExpr + deriving (Eq, Read, Show) + +-- |Labeled record fields +type CField a = (QName, a) + +-- |Operator precedence declaration. +-- An operator precedence declaration @fix p n@ in Curry corresponds to the +-- AbstractCurry term @(COp n fix p)@. +data COpDecl = COp QName CFixity Int + deriving (Eq, Read, Show) + +-- |Fixity declarations of infix operators +data CFixity + = CInfixOp -- ^ non-associative infix operator + | CInfixlOp -- ^ left-associative infix operator + | CInfixrOp -- ^ right-associative infix operator + deriving (Eq, Read, Show) + +-- |Function arity +type Arity = Int + +-- |Data type for representing function declarations. +-- A function declaration in FlatCurry is a term of the form +-- @ +-- (CFunc name arity visibility type (CRules eval [CRule rule1,...,rulek])) +-- @ +-- and represents the function @name@ with definition +-- @ +-- name :: type +-- rule1 +-- ... +-- rulek +-- @ +-- /Note:/ The variable indices are unique inside each rule. +-- External functions are represented as +-- @ +-- (CFunc name arity type (CExternal s)) +-- @ +-- where s is the external name associated to this function. +-- Thus, a function declaration consists of the name, arity, type, and +-- a list of rules. +-- If the list of rules is empty, the function is considered +-- to be externally defined. +data CFuncDecl = CFunc QName Arity CVisibility CQualTypeExpr [CRule] + deriving (Eq, Read, Show) + +-- |The general form of a function rule. It consists of a list of patterns +-- (left-hand side), a list of guards (@success@ if not present in the +-- source text) with their corresponding right-hand sides, and +-- a list of local declarations. +data CRule = CRule [CPattern] CRhs + deriving (Eq, Read, Show) + +-- |Right-hand-side of a 'CRule' or an @case@ expression +data CRhs + = CSimpleRhs CExpr [CLocalDecl] -- @expr where decls@ + | CGuardedRhs [(CExpr, CExpr)] [CLocalDecl] -- @| cond = expr where decls@ + deriving (Eq, Read, Show) + +-- | Local (let/where) declarations +data CLocalDecl + = CLocalFunc CFuncDecl -- ^ local function declaration + | CLocalPat CPattern CRhs -- ^ local pattern declaration + | CLocalVars [CVarIName] -- ^ local free variable declarations + deriving (Eq, Read, Show) + +-- |Variable names. +-- Object variables occurring in expressions are represented by @(Var i)@ +-- where @i@ is a variable index. +type CVarIName = (Int, String) + +-- |Pattern expressions. +data CPattern + -- |pattern variable (unique index / name) + = CPVar CVarIName + -- |literal (Integer/Float/Char constant) + | CPLit CLiteral + -- |application @(m.c e1 ... en)@ of n-ary constructor @m.c@ + -- (@CPComb (m,c) [e1,...,en]@) + | CPComb QName [CPattern] + -- |as-pattern (extended Curry) + | CPAs CVarIName CPattern + -- |functional pattern (extended Curry) + | CPFuncComb QName [CPattern] + -- |lazy pattern (extended Curry) + | CPLazy CPattern + -- |record pattern (extended curry) + | CPRecord QName [CField CPattern] + deriving (Eq, Read, Show) + +-- | Curry expressions. +data CExpr + -- |variable (unique index / name) + = CVar CVarIName + -- |literal (Integer/Float/Char/String constant) + | CLit CLiteral + -- |a defined symbol with module and name, i.e., a function or a constructor + | CSymbol QName + -- |application (e1 e2) + | CApply CExpr CExpr + -- |lambda abstraction + | CLambda [CPattern] CExpr + -- |local let declarations + | CLetDecl [CLocalDecl] CExpr + -- |do block + | CDoExpr [CStatement] + -- |list comprehension + | CListComp CExpr [CStatement] + -- |case expression + | CCase CCaseType CExpr [(CPattern, CRhs)] + -- |typed expression + | CTyped CExpr CQualTypeExpr + -- |record construction (extended Curry) + | CRecConstr QName [CField CExpr] + -- |record update (extended Curry) + | CRecUpdate CExpr [CField CExpr] + deriving (Eq, Read, Show) + +-- |Literals occurring in an expression or a pattern, +-- either an integer, a float, a character, or a string constant. +-- /Note:/ The constructor definition of 'CIntc' differs from the original +-- PAKCS definition. It uses Haskell type 'Integer' instead of 'Int' +-- to provide an unlimited range of integer numbers. Furthermore, +-- float values are represented with Haskell type 'Double' instead of +-- 'Float' to gain double precision. +data CLiteral + = CIntc Integer -- ^ Int literal + | CFloatc Double -- ^ Float literal + | CCharc Char -- ^ Char literal + | CStringc String -- ^ String literal + deriving (Eq, Read, Show) + +-- |Statements in do expressions and list comprehensions. +data CStatement + = CSExpr CExpr -- ^ an expression (I/O action or boolean) + | CSPat CPattern CExpr -- ^ a pattern definition + | CSLet [CLocalDecl] -- ^ a local let declaration + deriving (Eq, Read, Show) + +-- |Type of case expressions +data CCaseType + = CRigid -- ^ rigid case expression + | CFlex -- ^ flexible case expression + deriving (Eq, Read, Show) diff --git a/src/Curry/Base/Ident.hs b/src/Curry/Base/Ident.hs new file mode 100644 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /dev/null +++ b/src/Curry/Base/Span.hs @@ -0,0 +1,180 @@ +{- | + Module : $Header$ + Description : Spans in a source file + Copyright : (c) 2016 Jan Tikovsky + 2016 Finn Teegen + License : BSD-3-clause + + Maintainer : jrt@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This module implements a data type for span information in a source file and + respective functions to operate on them. A source file span consists + of a filename, a start position and an end position. + + In addition, the type 'SrcRef' identifies the path to an expression in + the abstract syntax tree by argument positions, which is used for + debugging purposes. +-} +module Curry.Base.Span where + +import Prelude hiding ((<>)) + +import Data.Binary +import Data.List (transpose) +import Control.Monad +import System.FilePath + +import Curry.Base.Position hiding (file) +import Curry.Base.Pretty + +data Span + -- |Normal source code span + = Span + { file :: FilePath -- ^ 'FilePath' of the source file + , start :: Position -- ^ start position + , end :: Position -- ^ end position + } + -- |no span + | NoSpan + deriving (Eq, Ord, Read, Show) + +instance Pretty Span where + pPrint = ppSpan + +instance HasPosition Span where + setPosition p NoSpan = Span "" p NoPos + setPosition p (Span f _ e) = Span f p e + + getPosition NoSpan = NoPos + getPosition (Span _ p _) = p + +instance Binary Span where + put (Span _ s e) = putWord8 0 >> put s >> put e + put NoSpan = putWord8 1 + + get = do + x <- getWord8 + case x of + 0 -> liftM2 (Span "") get get + 1 -> return NoSpan + _ -> fail "Not a valid encoding for a Span" + +-- |Show a 'Span' as a 'String' +showSpan :: Span -> String +showSpan = show . ppSpan + +-- |Pretty print a 'Span' +ppSpan :: Span -> Doc +ppSpan s@(Span f _ _) + | null f = startEnd + | otherwise = text (normalise f) <> comma <+> startEnd + where startEnd = ppPositions s +ppSpan _ = empty + +-- |Pretty print a span with it's file path and position compactly. +ppCompactSpan :: Span -> Doc +ppCompactSpan s@(Span f _ _) + | null f = ppCompactPositions s + | otherwise = text (normalise f) <> colon <> ppCompactPositions s +ppCompactSpan _ = empty + +-- |Pretty print a source preview of a span +ppSpanPreview :: Span -> IO Doc +ppSpanPreview (Span f (Position _ sl sc) (Position _ el ec)) + | null f = return empty + | otherwise = do + fileContents <- readFile f + + let lns = lines fileContents + lnContent | sl <= 0 || sl > length lns = "" + | otherwise = lns !! (sl - 1) + lnNum = text <$> lPadStr lnNumWidth <$> (vPad ++ [show sl] ++ vPad) + ec' = if isMultiline then length lnContent else ec + gutter = text <$> replicate (1 + 2 * vPadCount) "|" + highlight = replicate (sc - 1) ' ' ++ replicate (1 + ec' - sc) '^' ++ if isMultiline then "..." else "" + previews = text <$> (vPad ++ [lnContent, highlight] ++ replicate (vPadCount - 1) "") + + return $ vcat $ map hsep $ transpose [lnNum, gutter, previews] + where vPadCount = 1 -- Number of padding lines at the top and bottom + isMultiline = el - sl > 0 + numWidth = length . show + lnNumWidth = 1 + numWidth el + vPad = replicate vPadCount "" + lPadStr n s = replicate (n - length s) ' ' ++ s +ppSpanPreview _ = return empty + +-- |Pretty print the positions compactly. +ppCompactPositions :: Span -> Doc +ppCompactPositions (Span _ s e) | s == e = ppCompactLine s + | otherwise = ppCompactLine s <> text "-" <> ppCompactLine e +ppCompactPositions _ = empty + +-- |Pretty print the start and end position of a 'Span' +ppPositions :: Span -> Doc +ppPositions (Span _ s e) = text "startPos:" <+> ppLine s <> comma + <+> text "endPos:" <+> ppLine e +ppPositions _ = empty + +fstSpan :: FilePath -> Span +fstSpan fn = Span fn (first fn) (first fn) + +-- |Compute the column of the start position of a 'Span' +startCol :: Span -> Int +startCol (Span _ p _) = column p +startCol _ = 0 + +nextSpan :: Span -> Span +nextSpan sp = incrSpan sp 1 + +incrSpan :: Span -> Int -> Span +incrSpan (Span fn s e) n = Span fn (incr s n) (incr e n) +incrSpan sp _ = sp + +-- TODO: Rename to tab and nl as soon as positions are completely replaced by spans + +-- |Convert a position to a single character span. +pos2Span :: Position -> Span +pos2Span p@(Position f _ _) = Span f p p +pos2Span _ = NoSpan + +-- |Convert a span to a (start) position +-- TODO: This function should be removed as soon as positions are completely replaced by spans +-- in the frontend +span2Pos :: Span -> Position +span2Pos (Span _ p _) = p +span2Pos NoSpan = NoPos + +combineSpans :: Span -> Span -> Span +combineSpans sp1 sp2 = Span f s e + where s = start sp1 + e = end sp2 + f = file sp1 + +-- |First position after the next tabulator +tabSpan :: Span -> Span +tabSpan (Span fn s e) = Span fn (tab s) (tab e) +tabSpan sp = sp + +-- |First position of the next line +nlSpan :: Span -> Span +nlSpan (Span fn s e) = Span fn (nl s) (nl e) +nlSpan sp = sp + +addSpan :: Span -> (a, [Span]) -> (a, [Span]) +addSpan sp (a, ss) = (a, sp:ss) + +-- |Distance of a span, i.e. the line and column distance between start +-- and end position +type Distance = (Int, Int) + +-- |Set the distance of a span, i.e. update its end position +setDistance :: Span -> Distance -> Span +setDistance (Span fn p _) d = Span fn p (p `moveBy` d) +setDistance s _ = s + +-- |Move position by given distance +moveBy :: Position -> Distance -> Position +moveBy (Position fn l c) (ld, cd) = Position fn (l + ld) (c + cd) +moveBy p _ = p diff --git a/src/Curry/Base/SpanInfo.hs b/src/Curry/Base/SpanInfo.hs new file mode 100644 --- /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 --- /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 --- /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 --- /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 --- /dev/null +++ b/src/Curry/Files/Filenames.hs @@ -0,0 +1,256 @@ +{- | + Module : $Header$ + Description : File names for several intermediate file formats. + Copyright : (c) 2009 Holger Siegel + 2013 - 2014 Björn Peemöller + 2018 Kai-Oliver Prott + License : BSD-3-clause + + Maintainer : fte@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + The functions in this module were collected from several compiler modules + in order to provide a unique accessing point for this functionality. +-} +module Curry.Files.Filenames + ( -- * Re-exports from 'System.FilePath' + FilePath, takeBaseName, dropExtension, takeExtension, takeFileName + + -- * Conversion between 'ModuleIdent' and 'FilePath' + , moduleNameToFile, fileNameToModule, splitModuleFileName, isCurryFilePath + + -- * Curry sub-directory + , defaultOutDir, hasOutDir, addOutDir, addOutDirModule + , ensureOutDir + + -- * File name extensions + -- ** Curry files + , curryExt, lcurryExt, icurryExt + + -- ** FlatCurry files + , annotatedFlatExt, typedFlatExt, flatExt, flatIntExt + + -- ** AbstractCurry files + , acyExt, uacyExt + + -- ** Source and object files + , sourceRepExt, sourceExts, moduleExts + + -- * Functions for computing file names + , interfName, typedFlatName, annotatedFlatName, flatName, flatIntName + , acyName, uacyName, sourceRepName, tokensName, commentsName + , astName, shortASTName, htmlName + ) where + +import System.FilePath + +import Curry.Base.Ident + +-- ----------------------------------------------------------------------------- +-- Conversion between ModuleIdent and FilePath +-- ----------------------------------------------------------------------------- + +-- |Create a 'FilePath' from a 'ModuleIdent' using the hierarchical module +-- system +moduleNameToFile :: ModuleIdent -> FilePath +moduleNameToFile = foldr1 () . midQualifiers + +-- |Extract the 'ModuleIdent' from a 'FilePath' +fileNameToModule :: FilePath -> ModuleIdent +fileNameToModule = mkMIdent . splitDirectories . dropExtension . dropDrive + +-- |Split a 'FilePath' into a prefix directory part and those part that +-- corresponds to the 'ModuleIdent'. This is especially useful for +-- hierarchically module names. +splitModuleFileName :: ModuleIdent -> FilePath -> (FilePath, FilePath) +splitModuleFileName m fn = case midQualifiers m of + [_] -> splitFileName fn + ms -> let (base, ext) = splitExtension fn + dirs = splitDirectories base + (pre, suf) = splitAt (length dirs - length ms) dirs + path = if null pre then "" + else addTrailingPathSeparator (joinPath pre) + in (path, joinPath suf <.> ext) + +-- |Checks whether a 'String' represents a 'FilePath' to a Curry module +isCurryFilePath :: String -> Bool +isCurryFilePath str = isValid str + && takeExtension str `elem` ("" : moduleExts) + +-- ----------------------------------------------------------------------------- +-- Curry sub-directory +-- ----------------------------------------------------------------------------- + +-- |The standard hidden subdirectory for curry files +defaultOutDir :: String +defaultOutDir = ".curry" + +-- |Does the given 'FilePath' contain the 'outDir' +-- as its last directory component? +hasOutDir :: String -> FilePath -> Bool +hasOutDir outDir f = not (null dirs) && last dirs == outDir + where dirs = splitDirectories $ takeDirectory f + +-- |Add the 'outDir' to the given 'FilePath' if the flag is 'True' and +-- the path does not already contain it, otherwise leave the path untouched. +addOutDir :: Bool -> String -> FilePath -> FilePath +addOutDir b outDir fn = if b then ensureOutDir outDir fn else fn + +-- |Add the 'outDir' to the given 'FilePath' if the flag is 'True' and +-- the path does not already contain it, otherwise leave the path untouched. +addOutDirModule :: Bool -> String -> ModuleIdent -> FilePath -> FilePath +addOutDirModule b outDir m fn + | b = let (pre, file) = splitModuleFileName m fn + in ensureOutDir outDir pre file + | otherwise = fn + +-- | Ensure that the 'outDir' is the last component of the +-- directory structure of the given 'FilePath'. If the 'FilePath' already +-- contains the sub-directory, it remains unchanged. +ensureOutDir :: String -- ^ the 'outDir' + -> FilePath -- ^ original 'FilePath' + -> FilePath -- ^ new 'FilePath' +ensureOutDir outDir fn = normalise $ addSub (splitDirectories d) f + where + (d, f) = splitFileName fn + addSub dirs | null dirs = outDir + | last dirs == outDir = joinPath dirs + | otherwise = joinPath dirs outDir + +-- ----------------------------------------------------------------------------- +-- File name extensions +-- ----------------------------------------------------------------------------- + +-- |Filename extension for non-literate curry files +curryExt :: String +curryExt = ".curry" + +-- |Filename extension for literate curry files +lcurryExt :: String +lcurryExt = ".lcurry" + +-- |Filename extension for curry interface files +icurryExt :: String +icurryExt = ".icurry" + +-- |Filename extension for curry source files. +-- +-- /Note:/ The order of the extensions defines the order in which source files +-- should be searched for, i.e. given a module name @M@, the search order +-- should be the following: +-- +-- 1. @M.curry@ +-- 2. @M.lcurry@ +-- +sourceExts :: [String] +sourceExts = [curryExt, lcurryExt] + +-- |Filename extension for curry module files +-- TODO: Is the order correct? +moduleExts :: [String] +moduleExts = sourceExts ++ [icurryExt] + +-- |Filename extension for typed flat-curry files +typedFlatExt :: String +typedFlatExt = ".tfcy" + +-- |Filename extension for type-annotated flat-curry files +annotatedFlatExt :: String +annotatedFlatExt = ".tafcy" + +-- |Filename extension for flat-curry files +flatExt :: String +flatExt = ".fcy" + +-- |Filename extension for extended-flat-curry interface files +flatIntExt :: String +flatIntExt = ".fint" + +-- |Filename extension for abstract-curry files +acyExt :: String +acyExt = ".acy" + +-- |Filename extension for untyped-abstract-curry files +uacyExt :: String +uacyExt = ".uacy" + +-- |Filename extension for curry source representation files +sourceRepExt :: String +sourceRepExt = ".cy" + +-- |Filename extension for token files +tokensExt :: String +tokensExt = ".tokens" + +-- |Filename extension for comment token files +commentsExt :: String +commentsExt = ".cycom" + +-- |Filename extension for AST files +astExt :: String +astExt = ".ast" + +-- |Filename extension for shortened AST files +shortASTExt :: String +shortASTExt = ".sast" + +-- --------------------------------------------------------------------------- +-- Computation of file names for a given source file +-- --------------------------------------------------------------------------- + +-- |Compute the filename of the interface file for a source file +interfName :: FilePath -> FilePath +interfName = replaceExtensionWith icurryExt + +-- |Compute the filename of the typed flat curry file for a source file +typedFlatName :: FilePath -> FilePath +typedFlatName = replaceExtensionWith typedFlatExt + +-- |Compute the filename of the typed flat curry file for a source file +annotatedFlatName :: FilePath -> FilePath +annotatedFlatName = replaceExtensionWith annotatedFlatExt + +-- |Compute the filename of the flat curry file for a source file +flatName :: FilePath -> FilePath +flatName = replaceExtensionWith flatExt + +-- |Compute the filename of the flat curry interface file for a source file +flatIntName :: FilePath -> FilePath +flatIntName = replaceExtensionWith flatIntExt + +-- |Compute the filename of the abstract curry file for a source file +acyName :: FilePath -> FilePath +acyName = replaceExtensionWith acyExt + +-- |Compute the filename of the untyped abstract curry file for a source file +uacyName :: FilePath -> FilePath +uacyName = replaceExtensionWith uacyExt + +-- |Compute the filename of the source representation file for a source file +sourceRepName :: FilePath -> FilePath +sourceRepName = replaceExtensionWith sourceRepExt + +-- |Compute the filename of the tokens file for a source file +tokensName :: FilePath -> FilePath +tokensName = replaceExtensionWith tokensExt + +-- |Compute the filename of the comment tokens file for a source file +commentsName :: FilePath -> FilePath +commentsName = replaceExtensionWith commentsExt + +-- |Compute the filename of the ast file for a source file +astName :: FilePath -> FilePath +astName = replaceExtensionWith astExt + +-- |Compute the filename of the ast file for a source file +shortASTName :: FilePath -> FilePath +shortASTName = replaceExtensionWith shortASTExt + +-- |Compute the filename of the HTML file for a source file +htmlName :: ModuleIdent -> String +htmlName m = moduleName m ++ "_curry.html" + +-- |Replace a filename extension with a new extension +replaceExtensionWith :: String -> FilePath -> FilePath +replaceExtensionWith = flip replaceExtension diff --git a/src/Curry/Files/PathUtils.hs b/src/Curry/Files/PathUtils.hs new file mode 100644 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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/src/CurryBuilder.hs b/src/CurryBuilder.hs --- a/src/CurryBuilder.hs +++ b/src/CurryBuilder.hs @@ -23,8 +23,7 @@ import Curry.Base.Ident import Curry.Base.Monad -import Curry.Base.Position (Position) -import Curry.Base.SpanInfo (spanInfo2Pos) +import Curry.Base.SpanInfo (SpanInfo) import Curry.Base.Pretty import Curry.Files.Filenames import Curry.Files.PathUtils @@ -83,7 +82,7 @@ makeCurry opts srcs = mapM_ process' (zip [1 ..] srcs) where total = length srcs - tgtDir m = addCurrySubdirModule (optUseSubdir opts) m + tgtDir m = addOutDirModule (optUseOutDir opts) (optOutDir opts) m process' :: (Int, (ModuleIdent, Source)) -> CYIO () process' (n, (m, Source fn ps is)) = do @@ -101,9 +100,9 @@ adjustOptions :: Bool -> Options -> Options adjustOptions final opts - | final = opts { optForce = optForce opts || isDump } - | otherwise = opts { optForce = False - , optDebugOpts = defaultDebugOpts + | final = opts { optForce = optForce opts || isDump } + | otherwise = opts { optForce = False + , optDebugOpts = defaultDebugOpts } where isDump = not $ null $ dbDumpLevels $ optDebugOpts opts @@ -114,8 +113,8 @@ let opts1 = foldl processLanguagePragma opts0 [ e | LanguagePragma _ es <- ps, KnownExtension _ e <- es ] foldM processOptionPragma opts1 $ - [ (spanInfo2Pos p, s) | OptionsPragma p (Just FRONTEND) s <- ps ] ++ - [ (spanInfo2Pos p, s) | OptionsPragma p (Just CYMAKE) s <- ps ] + [ (p, s) | OptionsPragma p (Just FRONTEND) s <- ps ] ++ + [ (p, s) | OptionsPragma p (Just CYMAKE) s <- ps ] where processLanguagePragma opts CPP = opts { optCppOpts = (optCppOpts opts) { cppRun = True } } @@ -163,7 +162,7 @@ status opts $ compMessage idx "Compiling" m (fn, head destFiles) compileModule opts m fn - tgtDir = addCurrySubdirModule (optUseSubdir opts) m + tgtDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) m destFiles = [ gen fn | (t, gen) <- nameGens, t `elem` optTargetTypes opts] nameGens = @@ -172,7 +171,7 @@ , (Parsed , tgtDir . sourceRepName ) , (FlatCurry , tgtDir . flatName ) , (TypedFlatCurry , tgtDir . typedFlatName ) - , (TypeAnnotatedFlatCurry, tgtDir . typeAnnFlatName) + , (AnnotatedFlatCurry , tgtDir . annotatedFlatName) , (AbstractCurry , tgtDir . acyName ) , (UntypedAbstractCurry, tgtDir . uacyName ) , (AST , tgtDir . astName ) @@ -216,13 +215,13 @@ Nothing -> failMessages [errModificationTime f] Just val -> ok val -errUnknownOptions :: Position -> [String] -> Message -errUnknownOptions p errs = posMessage p $ +errUnknownOptions :: SpanInfo -> [String] -> Message +errUnknownOptions spi errs = spanInfoMessage spi $ text "Unknown flag(s) in {-# OPTIONS_FRONTEND #-} pragma:" <+> sep (punctuate comma $ map text errs) -errIllegalOption :: Position -> String -> Message -errIllegalOption p err = posMessage p $ +errIllegalOption :: SpanInfo -> String -> Message +errIllegalOption spi err = spanInfoMessage spi $ text "Illegal option in {-# OPTIONS_FRONTEND #-} pragma:" <+> text err errMissing :: String -> String -> Message diff --git a/src/CurryDeps.hs b/src/CurryDeps.hs --- a/src/CurryDeps.hs +++ b/src/CurryDeps.hs @@ -100,7 +100,7 @@ -- |Retrieve the dependencies of a given module moduleDeps :: Options -> SourceEnv -> FilePath -> Module a -> CYIO SourceEnv -moduleDeps opts sEnv fn mdl@(Module _ ps m _ _ _) = case Map.lookup m sEnv of +moduleDeps opts sEnv fn mdl@(Module _ _ ps m _ _ _) = case Map.lookup m sEnv of Just _ -> return sEnv Nothing -> do let imps = imports opts mdl @@ -110,7 +110,7 @@ -- |Retrieve the imported modules and add the import of the Prelude -- according to the compiler options. imports :: Options -> Module a -> [ModuleIdent] -imports opts mdl@(Module _ _ m _ is _) = nub $ +imports opts mdl@(Module _ _ _ m _ is _) = nub $ [preludeMIdent | m /= preludeMIdent && not noImplicitPrelude] ++ [m' | ImportDecl _ m' _ _ _ <- is] where noImplicitPrelude = NoImplicitPrelude `elem` optExtensions opts @@ -129,7 +129,7 @@ | icurryExt `isSuffixOf` fn -> return $ Map.insert m (Interface fn) sEnv | otherwise -> do - hdr@(Module _ _ m' _ _ _) <- readHeader opts fn + hdr@(Module _ _ _ m' _ _ _) <- readHeader opts fn if m == m' then moduleDeps opts sEnv fn hdr else failMessages [errWrongModule m m'] diff --git a/src/Env/Class.hs b/src/Env/Class.hs --- a/src/Env/Class.hs +++ b/src/Env/Class.hs @@ -1,20 +1,19 @@ {- | Module : $Header$ Description : Environment of classes - Copyright : (c) 2016 Finn Teegen + Copyright : (c) 2016 - 2020 Finn Teegen License : BSD-3-clause - Maintainer : bjp@informatik.uni-kiel.de + Maintainer : fte@informatik.uni-kiel.de Stability : experimental Portability : portable The compiler maintains information about all type classes in an - environment that maps type classes to a list of their direct - superclasses and all their associated class methods with an - additional boolean flag stating whether an default implementation - has been provided or not. For both the type class identifier and - the list of super classes original names are used. Thus, the use - of a flat environment is sufficient. + environment that maps type classes to a sorted list of their direct + superclasses and all their associated class methods with an additional + flag stating whether an default implementation has been provided or not. + For both the type class identifier and the list of super classes original + names are used. Thus, the use of a flat environment is sufficient. -} module Env.Class diff --git a/src/Env/Instance.hs b/src/Env/Instance.hs --- a/src/Env/Instance.hs +++ b/src/Env/Instance.hs @@ -1,10 +1,10 @@ {- | Module : $Header$ Description : Environment of instances - Copyright : (c) 2016 Finn Teegen + Copyright : (c) 2016 - 2020 Finn Teegen License : BSD-3-clause - Maintainer : bjp@informatik.uni-kiel.de + Maintainer : fte@informatik.uni-kiel.de Stability : experimental Portability : portable @@ -15,15 +15,16 @@ implemented in the specific instance along with their arity. A flat environment is sufficient because instances are visible globally and cannot be hidden. Instances are recorded only with the original names - of the type class and type constructor involved. + of the type class and type constructor involved. The context also uses + original names and is already minimized. -} module Env.Instance ( InstIdent, ppInstIdent, InstInfo - , InstEnv, initInstEnv, bindInstInfo, lookupInstInfo + , InstEnv, initInstEnv, bindInstInfo, removeInstInfo, lookupInstInfo ) where -import qualified Data.Map as Map (Map, empty, insert, lookup) +import qualified Data.Map as Map (Map, empty, insert, delete, lookup) import Curry.Base.Ident import Curry.Base.Pretty @@ -45,6 +46,9 @@ bindInstInfo :: InstIdent -> InstInfo -> InstEnv -> InstEnv bindInstInfo = Map.insert + +removeInstInfo :: InstIdent -> InstEnv -> InstEnv +removeInstInfo = Map.delete lookupInstInfo :: InstIdent -> InstEnv -> Maybe InstInfo lookupInstInfo = Map.lookup diff --git a/src/Env/Value.hs b/src/Env/Value.hs --- a/src/Env/Value.hs +++ b/src/Env/Value.hs @@ -48,15 +48,15 @@ data ValueInfo -- |Data constructor with original name, arity, list of record labels and type - = DataConstructor QualIdent Int [Ident] TypeScheme + = DataConstructor QualIdent Int [Ident] TypeScheme -- |Newtype constructor with original name, record label and type -- (arity is always 1) - | NewtypeConstructor QualIdent Ident TypeScheme - -- |Value with original name, class method flag, arity and type - | Value QualIdent Bool Int TypeScheme + | NewtypeConstructor QualIdent Ident TypeScheme + -- |Value with original name, class method name, arity and type + | Value QualIdent (Maybe QualIdent) Int TypeScheme -- |Record label with original name, list of constructors for which label - -- is valid field and type (arity is always 1) - | Label QualIdent [QualIdent] TypeScheme + -- is a valid field and type (arity is always 1) + | Label QualIdent [QualIdent] TypeScheme deriving Show instance Entity ValueInfo where @@ -115,21 +115,21 @@ where qc = qualifyWith m c v = f qc ty -bindFun :: ModuleIdent -> Ident -> Bool -> Int -> TypeScheme -> ValueEnv - -> ValueEnv +bindFun :: ModuleIdent -> Ident -> Maybe QualIdent -> Int -> TypeScheme + -> ValueEnv -> ValueEnv bindFun m f cm a ty | hasGlobalScope f = bindTopEnv f v . qualBindTopEnv qf v | otherwise = bindTopEnv f v where qf = qualifyWith m f v = Value qf cm a ty -qualBindFun :: ModuleIdent -> Ident -> Bool -> Int -> TypeScheme -> ValueEnv - -> ValueEnv +qualBindFun :: ModuleIdent -> Ident -> Maybe QualIdent -> Int -> TypeScheme + -> ValueEnv -> ValueEnv qualBindFun m f cm a ty = qualBindTopEnv qf $ Value qf cm a ty where qf = qualifyWith m f -rebindFun :: ModuleIdent -> Ident -> Bool -> Int -> TypeScheme -> ValueEnv - -> ValueEnv +rebindFun :: ModuleIdent -> Ident -> Maybe QualIdent -> Int -> TypeScheme + -> ValueEnv -> ValueEnv rebindFun m f cm a ty | hasGlobalScope f = rebindTopEnv f v . qualRebindTopEnv qf v | otherwise = rebindTopEnv f v @@ -204,4 +204,4 @@ bindLocalVar :: ValueType t => (Ident, Int, t) -> ValueEnv -> ValueEnv bindLocalVar (v, a, ty) = - bindTopEnv v $ Value (qualify v) False a $ typeScheme $ fromValueType ty + bindTopEnv v $ Value (qualify v) Nothing a $ typeScheme $ fromValueType ty diff --git a/src/Exports.hs b/src/Exports.hs --- a/src/Exports.hs +++ b/src/Exports.hs @@ -63,10 +63,10 @@ -- exported function. exportInterface :: CompilerEnv -> Module a -> Interface -exportInterface env (Module _ _ m (Just (Exporting _ es)) _ _) = +exportInterface env (Module _ _ _ m (Just (Exporting _ es)) _ _) = exportInterface' m es (opPrecEnv env) (tyConsEnv env) (valueEnv env) (classEnv env) (instEnv env) -exportInterface _ (Module _ _ _ Nothing _ _) = +exportInterface _ (Module _ _ _ _ Nothing _ _) = internalError "Exports.exportInterface: no export specification" exportInterface' :: ModuleIdent -> [Export] -> OpPrecEnv -> TCEnv -> ValueEnv @@ -178,7 +178,8 @@ valueDecl m vEnv tvs (Export _ f) ds = case qualLookupValue f vEnv of [Value _ cm a (ForAll _ pty)] -> IFunctionDecl NoPos (qualUnqualify m f) - (if cm then Just (head tvs) else Nothing) a (fromQualPredType m tvs pty) : ds + (fmap (const (head tvs)) cm) a (fromQualPredType m tvs pty) : ds + [Label _ _ _ ] -> ds -- Record labels are collected somewhere else. _ -> internalError $ "Exports.valueDecl: " ++ show f valueDecl _ _ _ (ExportTypeWith _ _ _) ds = ds valueDecl _ _ _ _ _ = internalError "Exports.valueDecl: no pattern match" diff --git a/src/Generators.hs b/src/Generators.hs --- a/src/Generators.hs +++ b/src/Generators.hs @@ -20,18 +20,18 @@ import qualified Curry.FlatCurry.Typed.Type as TFC (TProg) import qualified Curry.Syntax as CS (Module) -import qualified Generators.GenAbstractCurry as GAC (genAbstractCurry) -import qualified Generators.GenFlatCurry as GFC ( genFlatCurry - , genFlatInterface - ) -import qualified Generators.GenTypeAnnotatedFlatCurry - as GTAFC (genTypeAnnotatedFlatCurry) -import qualified Generators.GenTypedFlatCurry as GTFC (genTypedFlatCurry) +import qualified Generators.GenAbstractCurry as GAC (genAbstractCurry) +import qualified Generators.GenFlatCurry as GFC ( genFlatCurry + , genFlatInterface + ) +import qualified Generators.GenAnnotatedFlatCurry + as GAFC (genAnnotatedFlatCurry) +import qualified Generators.GenTypedFlatCurry as GTFC (genTypedFlatCurry) -import Base.Types (Type, PredType) +import Base.Types (Type, PredType) -import CompilerEnv (CompilerEnv (..)) -import qualified IL (Module) +import CompilerEnv (CompilerEnv (..)) +import qualified IL (Module) -- |Generate typed AbstractCurry genTypedAbstractCurry :: CompilerEnv -> CS.Module PredType -> AC.CurryProg @@ -42,17 +42,16 @@ genUntypedAbstractCurry = GAC.genAbstractCurry True -- |Generate typed FlatCurry -genTypedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module - -> TFC.TProg +genTypedFlatCurry :: AFC.AProg FC.TypeExpr -> TFC.TProg genTypedFlatCurry = GTFC.genTypedFlatCurry -- |Generate type-annotated FlatCurry -genTypeAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module - -> AFC.AProg FC.TypeExpr -genTypeAnnotatedFlatCurry = GTAFC.genTypeAnnotatedFlatCurry +genAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module + -> AFC.AProg FC.TypeExpr +genAnnotatedFlatCurry = GAFC.genAnnotatedFlatCurry -- |Generate FlatCurry -genFlatCurry :: TFC.TProg -> FC.Prog +genFlatCurry :: AFC.AProg FC.TypeExpr -> FC.Prog genFlatCurry = GFC.genFlatCurry -- |Generate a FlatCurry interface diff --git a/src/Generators/GenAbstractCurry.hs b/src/Generators/GenAbstractCurry.hs --- a/src/Generators/GenAbstractCurry.hs +++ b/src/Generators/GenAbstractCurry.hs @@ -63,7 +63,7 @@ -- --------------------------------------------------------------------------- trModule :: Module PredType -> GAC CurryProg -trModule (Module _ _ mid _ is ds) = +trModule (Module _ _ _ mid _ is ds) = CurryProg mid' is' <$> dflt' <*> cds' <*> ids' <*> ts' <*> fs' <*> os' where mid' = moduleName mid @@ -84,7 +84,7 @@ trDefaultDecl _ = return [] trClassDecl :: Decl PredType -> GAC [CClassDecl] -trClassDecl (ClassDecl _ cx cls tv ds) = +trClassDecl (ClassDecl _ _ cx cls tv ds) = (\cls' v' cx' tv' ds' -> [CClass cls' v' cx' tv' ds']) <$> trGlobalIdent cls <*> getTypeVisibility cls <*> trContext cx <*> getTVarIndex tv <*> concatMapM (trClassMethodDecl sigs fs) ds @@ -111,7 +111,7 @@ trClassMethodDecl _ _ _ = return [] trInstanceDecl :: Decl PredType -> GAC [CInstanceDecl] -trInstanceDecl (InstanceDecl _ cx qcls ty ds) = +trInstanceDecl (InstanceDecl _ _ cx qcls ty ds) = (\qcls' cx' ty' ds' -> [CInstance qcls' cx' ty' ds']) <$> trQual qcls <*> trContext cx <*> trTypeExpr ty <*> mapM (trInstanceMethodDecl qcls ty) ds trInstanceDecl _ = return [] @@ -157,25 +157,22 @@ <$> trGlobalIdent t <*> getTypeVisibility t <*> mapM genTVarIndex vs trTypeDecl _ = return [] - --- TODO: Remove context and existential quantified type variables. trConsDecl :: ConstrDecl -> GAC CConsDecl -trConsDecl (ConstrDecl _ c tys) = inNestedTScope $ CCons [] (CContext []) +trConsDecl (ConstrDecl _ c tys) = inNestedTScope $ CCons <$> trGlobalIdent c <*> getVisibility c <*> mapM trTypeExpr tys trConsDecl (ConOpDecl p ty1 op ty2) = inNestedTScope $ trConsDecl $ ConstrDecl p op [ty1, ty2] -trConsDecl (RecordDecl _ c fs) = inNestedTScope $ CRecord [] (CContext []) +trConsDecl (RecordDecl _ c fs) = inNestedTScope $ CRecord <$> trGlobalIdent c <*> getVisibility c <*> concatMapM trFieldDecl fs trFieldDecl :: FieldDecl -> GAC [CFieldDecl] trFieldDecl (FieldDecl _ ls ty) = T.forM ls $ \l -> CField <$> trGlobalIdent l <*> getVisibility l <*> trTypeExpr ty --- TODO: Remove context and existential quantified type variables. trNewConsDecl :: NewConstrDecl -> GAC CConsDecl -trNewConsDecl (NewConstrDecl _ nc ty) = CCons [] (CContext []) +trNewConsDecl (NewConstrDecl _ nc ty) = CCons <$> trGlobalIdent nc <*> getVisibility nc <*> ((:[]) <$> trTypeExpr ty) -trNewConsDecl (NewRecordDecl p nc (l, ty)) = CRecord [] (CContext []) +trNewConsDecl (NewRecordDecl p nc (l, ty)) = CRecord <$> trGlobalIdent nc <*> getVisibility nc <*> trFieldDecl (FieldDecl p [l] ty) trTypeExpr :: TypeExpr -> GAC CTypeExpr @@ -233,10 +230,10 @@ trLhs = mapM trPat . snd . flatLhs trRhs :: Rhs PredType -> GAC CRhs -trRhs (SimpleRhs _ e ds) = inNestedScope $ do +trRhs (SimpleRhs _ _ e ds) = inNestedScope $ do mapM_ insertDeclLhs ds CSimpleRhs <$> trExpr e <*> concatMapM trLocalDecl ds -trRhs (GuardedRhs _ gs ds) = inNestedScope $ do +trRhs (GuardedRhs _ _ gs ds) = inNestedScope $ do mapM_ insertDeclLhs ds CGuardedRhs <$> mapM trCondExpr gs <*> concatMapM trLocalDecl ds @@ -313,14 +310,14 @@ trExpr $ apply (Variable NoSpanInfo undefined qFlip) [infixOp op, e] trExpr (Lambda _ ps e) = inNestedScope $ CLambda <$> mapM trPat ps <*> trExpr e -trExpr (Let _ ds e) = inNestedScope $ +trExpr (Let _ _ ds e) = inNestedScope $ CLetDecl <$> trLocalDecls ds <*> trExpr e -trExpr (Do _ ss e) = inNestedScope $ +trExpr (Do _ _ ss e) = inNestedScope $ (\ss' e' -> CDoExpr (ss' ++ [CSExpr e'])) <$> mapM trStatement ss <*> trExpr e trExpr (IfThenElse _ e1 e2 e3) = trExpr $ apply (Variable NoSpanInfo undefined qIfThenElseId) [e1, e2, e3] -trExpr (Case _ ct e bs) = CCase (cvCaseType ct) +trExpr (Case _ _ ct e bs) = CCase (cvCaseType ct) <$> trExpr e <*> mapM trAlt bs cvCaseType :: CaseType -> CCaseType @@ -328,9 +325,9 @@ cvCaseType Rigid = CRigid trStatement :: Statement PredType -> GAC CStatement -trStatement (StmtExpr _ e) = CSExpr <$> trExpr e -trStatement (StmtDecl _ ds) = CSLet <$> trLocalDecls ds -trStatement (StmtBind _ p e) = flip CSPat <$> trExpr e <*> trPat p +trStatement (StmtExpr _ e) = CSExpr <$> trExpr e +trStatement (StmtDecl _ _ ds) = CSLet <$> trLocalDecls ds +trStatement (StmtBind _ p e) = flip CSPat <$> trExpr e <*> trPat p trAlt :: Alt PredType -> GAC (CPattern, CRhs) trAlt (Alt _ p rhs) = inNestedScope $ (,) <$> trPat p <*> trRhs rhs @@ -393,7 +390,7 @@ qNegateId = qualifyWith preludeMIdent (mkIdent "negate") qIfThenElseId :: QualIdent -qIfThenElseId = qualifyWith preludeMIdent (mkIdent "if_then_else") +qIfThenElseId = qualifyWith preludeMIdent (mkIdent "ifThenElse") prelUntyped :: QualIdent prelUntyped = qualifyWith preludeMIdent $ mkIdent "untyped" @@ -419,7 +416,7 @@ -- |Initialize the AbstractCurry generator environment abstractEnv :: Bool -> CompilerEnv -> Module a -> AbstractEnv -abstractEnv uacy env (Module _ _ mid es _ ds) = AbstractEnv +abstractEnv uacy env (Module _ _ _ mid es _ ds) = AbstractEnv { moduleId = mid , typeEnv = valueEnv env , tyExports = foldr (buildTypeExports mid) Set.empty es' diff --git a/src/Generators/GenAnnotatedFlatCurry.hs b/src/Generators/GenAnnotatedFlatCurry.hs new file mode 100644 --- /dev/null +++ b/src/Generators/GenAnnotatedFlatCurry.hs @@ -0,0 +1,488 @@ +{- | + Module : $Header$ + Description : Generation of typed FlatCurry program terms + Copyright : (c) 2017 Finn Teegen + 2018 Kai-Oliver Prott + License : BSD-3-clause + + Maintainer : fte@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + This module contains the generation of a type-annotated 'FlatCurry' + program term for a given module in the intermediate language. +-} +{-# LANGUAGE CPP #-} +module Generators.GenAnnotatedFlatCurry (genAnnotatedFlatCurry) where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>), (<*>)) +#endif +import Control.Monad ((<=<)) +import Control.Monad.Extra (concatMapM) +import qualified Control.Monad.State as S ( State, evalState, get, gets + , modify, put ) +import Data.Function (on) +import Data.List (nub, sortBy) +import Data.Maybe (fromMaybe) +import qualified Data.Map as Map (Map, empty, insert, lookup) +import qualified Data.Set as Set (Set, empty, insert, member) + +import Curry.Base.Ident +import Curry.FlatCurry.Annotated.Goodies (typeName) +import Curry.FlatCurry.Annotated.Type +import qualified Curry.Syntax as CS + +import Base.Messages (internalError) +import Base.NestEnv ( NestEnv, emptyEnv, bindNestEnv, lookupNestEnv + , nestEnv, unnestEnv ) +import Base.Types + +import CompilerEnv +import Env.TypeConstructor (TCEnv) + +import qualified IL + +-- transforms intermediate language code (IL) to type-annotated FlatCurry code +genAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module + -> AProg TypeExpr +genAnnotatedFlatCurry env mdl il = patchPrelude $ run env mdl (trModule il) + +-- ----------------------------------------------------------------------------- +-- Addition of primitive types for lists and tuples to the Prelude +-- ----------------------------------------------------------------------------- + +patchPrelude :: AProg a -> AProg a +patchPrelude p@(AProg n _ ts fs os) + | n == prelude = AProg n [] ts' fs os + | otherwise = p + where ts' = sortBy (compare `on` typeName) pts + pts = primTypes ++ ts + +primTypes :: [TypeDecl] +primTypes = + [ Type arrow Public [(0, KStar), (1, KStar)] [] + , Type unit Public [] [(Cons unit 0 Public [])] + , Type nil Public [(0, KStar)] [ Cons nil 0 Public [] + , Cons cons 2 Public [TVar 0, TCons nil [TVar 0]] + ] + ] ++ map mkTupleType [2 .. maxTupleArity] + where arrow = mkPreludeQName "(->)" + unit = mkPreludeQName "()" + nil = mkPreludeQName "[]" + cons = mkPreludeQName ":" + +mkTupleType :: Int -> TypeDecl +mkTupleType arity = Type tuple Public [(i, KStar) | i <- [0 .. arity - 1]] + [Cons tuple arity Public $ map TVar [0 .. arity - 1]] + where tuple = mkPreludeQName $ '(' : replicate (arity - 1) ',' ++ ")" + +mkPreludeQName :: String -> QName +mkPreludeQName n = (prelude, n) + +prelude :: String +prelude = "Prelude" + +-- |Maximal arity of tuples +maxTupleArity :: Int +maxTupleArity = 15 + +-- ----------------------------------------------------------------------------- + +-- The environment 'FlatEnv' is embedded in the monadic representation +-- 'FlatState' which allows the usage of 'do' expressions. +type FlatState a = S.State FlatEnv a + +-- Data type for representing an environment which contains information needed +-- for generating FlatCurry code. +data FlatEnv = FlatEnv + { modIdent :: ModuleIdent -- current module + -- for visibility calculation + , tyExports :: Set.Set Ident -- exported types + , valExports :: Set.Set Ident -- exported values (functions + constructors) + , tcEnv :: TCEnv -- type constructor environment + , typeSynonyms :: [CS.Decl Type] -- type synonyms + , imports :: [ModuleIdent] -- module imports + -- state for mapping identifiers to indexes + , nextVar :: Int -- fresh variable index counter + , varMap :: NestEnv VarIndex -- map of identifier to variable index + } + +-- Runs a 'FlatState' action and returns the result +run :: CompilerEnv -> CS.Module Type -> FlatState a -> a +run env (CS.Module _ _ _ mid es is ds) act = S.evalState act env0 + where + es' = case es of Just (CS.Exporting _ e) -> e + _ -> [] + env0 = FlatEnv + { modIdent = mid + -- for visibility calculation + , tyExports = foldr (buildTypeExports mid) Set.empty es' + , valExports = foldr (buildValueExports mid) Set.empty es' + -- This includes *all* imports, even unused ones + , imports = nub [ m | CS.ImportDecl _ m _ _ _ <- is ] + -- Environment to retrieve the type of identifiers + , tcEnv = tyConsEnv env + -- Type synonyms in the module + , typeSynonyms = [ d | d@CS.TypeDecl{} <- ds ] + , nextVar = 0 + , varMap = emptyEnv + } + +-- Builds a table containing all exported identifiers from a module. +buildTypeExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident +buildTypeExports mid (CS.ExportTypeWith _ tc _) + | isLocalIdent mid tc = Set.insert (unqualify tc) +buildTypeExports _ _ = id + +-- Builds a table containing all exported identifiers from a module. +buildValueExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident +buildValueExports mid (CS.Export _ q) + | isLocalIdent mid q = Set.insert (unqualify q) +buildValueExports mid (CS.ExportTypeWith _ tc cs) + | isLocalIdent mid tc = flip (foldr Set.insert) cs +buildValueExports _ _ = id + +getModuleIdent :: FlatState ModuleIdent +getModuleIdent = S.gets modIdent + +-- Retrieve imports +getImports :: [ModuleIdent] -> FlatState [String] +getImports imps = (nub . map moduleName . (imps ++)) <$> S.gets imports + +-- ----------------------------------------------------------------------------- +-- Stateful part, used for translation of rules and expressions +-- ----------------------------------------------------------------------------- + +-- resets var index and environment +withFreshEnv :: FlatState a -> FlatState a +withFreshEnv act = S.modify (\ s -> s { nextVar = 0, varMap = emptyEnv }) >> act + +-- Execute an action in a nested variable mapping +inNestedEnv :: FlatState a -> FlatState a +inNestedEnv act = do + S.modify $ \ s -> s { varMap = nestEnv $ varMap s } + res <- act + S.modify $ \ s -> s { varMap = unnestEnv $ varMap s } + return res + +-- Generates a new variable index for an identifier +newVar :: IL.Type -> Ident -> FlatState (VarIndex, TypeExpr) +newVar ty i = do + idx <- (+1) <$> S.gets nextVar + S.modify $ \ s -> s { nextVar = idx, varMap = bindNestEnv i idx (varMap s) } + ty' <- trType ty + return (idx, ty') + +-- Retrieve the variable index assigned to an identifier +getVarIndex :: Ident -> FlatState VarIndex +getVarIndex i = S.gets varMap >>= \ varEnv -> case lookupNestEnv i varEnv of + [v] -> return v + _ -> internalError $ "GenTypeAnnotatedFlatCurry.getVarIndex: " ++ escName i + +-- ----------------------------------------------------------------------------- +-- Translation of a module +-- ----------------------------------------------------------------------------- + +trModule :: IL.Module -> FlatState (AProg TypeExpr) +trModule (IL.Module mid is ds) = do + is' <- getImports is + tds <- concatMapM trTypeDecl ds + fds <- concatMapM (return . map runNormalization <=< trAFuncDecl) ds + return $ AProg (moduleName mid) is' tds fds [] + +-- Translate a data declaration +-- For empty data declarations, an additional constructor is generated. This +-- is due to the fact that external data declarations are translated into data +-- declarations with zero constructors and without the additional constructor +-- empty data declarations could not be distinguished from external ones. +trTypeDecl :: IL.Decl -> FlatState [TypeDecl] +trTypeDecl (IL.DataDecl qid ks []) = do + q' <- trQualIdent qid + vis <- getTypeVisibility qid + c <- trQualIdent $ qualify (mkIdent $ "_Constr#" ++ idName (unqualify qid)) + let ks' = trKind <$> ks + tvs = zip [0..] ks' + return [Type q' vis tvs [Cons c 1 Private [TCons q' $ TVar <$> fst <$> tvs]]] +trTypeDecl (IL.DataDecl qid ks cs) = do + q' <- trQualIdent qid + vis <- getTypeVisibility qid + cs' <- mapM trConstrDecl cs + let ks' = trKind <$> ks + tvs = zip [0..] ks' + return [Type q' vis tvs cs'] +trTypeDecl (IL.NewtypeDecl qid ks nc) = do + q' <- trQualIdent qid + vis <- getTypeVisibility qid + nc' <- trNewConstrDecl nc + let ks' = trKind <$> ks + tvs = zip [0..] ks' + return [TypeNew q' vis tvs nc'] +trTypeDecl (IL.ExternalDataDecl qid ks) = do + q' <- trQualIdent qid + vis <- getTypeVisibility qid + let ks' = trKind <$> ks + tvs = zip [0..] ks' + return [Type q' vis tvs []] +trTypeDecl _ = return [] + +-- Translate a constructor declaration +trConstrDecl :: IL.ConstrDecl -> FlatState ConsDecl +trConstrDecl (IL.ConstrDecl qid tys) = flip Cons (length tys) + <$> trQualIdent qid + <*> getVisibility qid + <*> mapM trType tys + +-- Translate a constructor declaration for newtypes +trNewConstrDecl :: IL.NewConstrDecl -> FlatState NewConsDecl +trNewConstrDecl (IL.NewConstrDecl qid ty) = NewCons + <$> trQualIdent qid + <*> getVisibility qid + <*> trType ty + +-- Translate a type expression +trType :: IL.Type -> FlatState TypeExpr +trType (IL.TypeConstructor t tys) = TCons <$> trQualIdent t <*> mapM trType tys +trType (IL.TypeVariable idx) = return $ TVar $ abs idx +trType (IL.TypeArrow ty1 ty2) = FuncType <$> trType ty1 <*> trType ty2 +trType (IL.TypeForall idxs ty) = ForallType (map trTVarWithKind idxs) <$> trType ty + +-- Translates a type variable with kind. +trTVarWithKind :: (Int, IL.Kind) -> (Int, Kind) +trTVarWithKind (i, k) = (abs i, trKind k) + +-- Translate a kind +trKind :: IL.Kind -> Kind +trKind IL.KindStar = KStar +trKind (IL.KindVariable _) = KStar +trKind (IL.KindArrow k1 k2) = KArrow (trKind k1) (trKind k2) + +-- ----------------------------------------------------------------------------- +-- Function declarations +-- ----------------------------------------------------------------------------- + +-- Translate a function declaration +trAFuncDecl :: IL.Decl -> FlatState [AFuncDecl TypeExpr] +trAFuncDecl (IL.FunctionDecl f vs ty e) = do + f' <- trQualIdent f + vis <- getVisibility f + ty' <- trType ty + r' <- trARule ty vs e + return [AFunc f' (length vs) vis ty' r'] +trAFuncDecl (IL.ExternalDecl f a ty) = do + f' <- trQualIdent f + vis <- getVisibility f + ty' <- trType ty + r' <- trAExternal ty f --TODO: get arity from type? + return [AFunc f' a vis ty' r'] +trAFuncDecl _ = return [] + +-- Translate a function rule. +-- Resets variable index so that for every rule variables start with index 1 +trARule :: IL.Type -> [(IL.Type, Ident)] -> IL.Expression + -> FlatState (ARule TypeExpr) +trARule ty vs e = withFreshEnv $ ARule <$> trType ty + <*> mapM (uncurry newVar) vs + <*> trAExpr e + +trAExternal :: IL.Type -> QualIdent -> FlatState (ARule TypeExpr) +trAExternal ty f = flip AExternal (qualName f) <$> trType ty + +-- Translate an expression +trAExpr :: IL.Expression -> FlatState (AExpr TypeExpr) +trAExpr (IL.Literal ty l) = ALit <$> trType ty <*> trLiteral l +trAExpr (IL.Variable ty v) = AVar <$> trType ty <*> getVarIndex v +trAExpr (IL.Function ty f a) = genCall Fun ty f a [] +trAExpr (IL.Constructor ty c a) = genCall Con ty c a [] +trAExpr (IL.Apply e1 e2) = trApply e1 e2 +trAExpr c@(IL.Case t e bs) = flip ACase (cvEval t) <$> trType (IL.typeOf c) <*> trAExpr e + <*> mapM (inNestedEnv . trAlt) bs +trAExpr (IL.Or e1 e2) = AOr <$> trType (IL.typeOf e1) <*> trAExpr e1 <*> trAExpr e2 +trAExpr (IL.Exist v ty e) = inNestedEnv $ do + v' <- newVar ty v + e' <- trAExpr e + ty' <- trType (IL.typeOf e) + return $ case e' of AFree ty'' vs e'' -> AFree ty'' (v' : vs) e'' + _ -> AFree ty' (v' : []) e' +trAExpr (IL.Let (IL.Binding v b) e) = inNestedEnv $ do + v' <- newVar (IL.typeOf b) v + b' <- trAExpr b + e' <- trAExpr e + ty' <- trType $ IL.typeOf e + return $ case e' of ALet ty'' bs e'' -> ALet ty'' ((v', b'):bs) e'' + _ -> ALet ty' ((v', b'):[]) e' +trAExpr (IL.Letrec bs e) = inNestedEnv $ do + let (vs, es) = unzip [ ((IL.typeOf b, v), b) | IL.Binding v b <- bs] + ALet <$> trType (IL.typeOf e) + <*> (zip <$> mapM (uncurry newVar) vs <*> mapM trAExpr es) + <*> trAExpr e +trAExpr (IL.Typed e ty) = ATyped <$> ty' <*> trAExpr e <*> ty' + where ty' = trType $ ty + +-- Translate a literal +trLiteral :: IL.Literal -> FlatState Literal +trLiteral (IL.Char c) = return $ Charc c +trLiteral (IL.Int i) = return $ Intc i +trLiteral (IL.Float f) = return $ Floatc f + +-- Translate a higher-order application +trApply :: IL.Expression -> IL.Expression -> FlatState (AExpr TypeExpr) +trApply e1 e2 = genFlatApplic e1 [e2] + where + genFlatApplic e es = case e of + IL.Apply ea eb -> genFlatApplic ea (eb:es) + IL.Function ty f a -> genCall Fun ty f a es + IL.Constructor ty c a -> genCall Con ty c a es + _ -> do + expr <- trAExpr e + genApply expr es + +-- Translate an alternative +trAlt :: IL.Alt -> FlatState (ABranchExpr TypeExpr) +trAlt (IL.Alt p e) = ABranch <$> trPat p <*> trAExpr e + +-- Translate a pattern +trPat :: IL.ConstrTerm -> FlatState (APattern TypeExpr) +trPat (IL.LiteralPattern ty l) = ALPattern <$> trType ty <*> trLiteral l +trPat (IL.ConstructorPattern ty c vs) = do + qty <- trType $ foldr IL.TypeArrow ty $ map fst vs + APattern <$> trType ty <*> ((\q -> (q, qty)) <$> trQualIdent c) <*> mapM (uncurry newVar) vs +trPat (IL.VariablePattern _ _) = internalError "GenTypeAnnotatedFlatCurry.trPat" + +-- Convert a case type +cvEval :: IL.Eval -> CaseType +cvEval IL.Rigid = Rigid +cvEval IL.Flex = Flex + +data Call = Fun | Con + +-- Generate a function or constructor call +genCall :: Call -> IL.Type -> QualIdent -> Int -> [IL.Expression] + -> FlatState (AExpr TypeExpr) +genCall call ty f arity es = do + f' <- trQualIdent f + case compare supplied arity of + LT -> genAComb ty f' es (part call (arity - supplied)) + EQ -> genAComb ty f' es (full call) + GT -> do + let (es1, es2) = splitAt arity es + funccall <- genAComb ty f' es1 (full call) + genApply funccall es2 + where + supplied = length es + full Fun = FuncCall + full Con = ConsCall + part Fun = FuncPartCall + part Con = ConsPartCall + +genAComb :: IL.Type -> QName -> [IL.Expression] -> CombType -> FlatState (AExpr TypeExpr) +genAComb ty qid es ct = do + ty' <- trType ty + let ty'' = defunc ty' (length es) + AComb ty'' ct (qid, ty') <$> mapM trAExpr es + where + defunc t 0 = t + defunc (FuncType _ t2) n = defunc t2 (n - 1) + defunc _ _ = internalError "GenTypeAnnotatedFlatCurry.genAComb.defunc" + +genApply :: AExpr TypeExpr -> [IL.Expression] -> FlatState (AExpr TypeExpr) +genApply e es = do + ap <- trQualIdent $ qApplyId + es' <- mapM trAExpr es + return $ foldl (\e1 e2 -> let FuncType ty1 ty2 = typeOf e1 in AComb ty2 FuncCall (ap, FuncType (FuncType ty1 ty2) (FuncType ty1 ty2)) [e1, e2]) e es' + +-- ----------------------------------------------------------------------------- +-- Normalization +-- ----------------------------------------------------------------------------- + +runNormalization :: Normalize a => a -> a +runNormalization x = S.evalState (normalize x) (0, Map.empty) + +type NormState a = S.State (Int, Map.Map Int Int) a + +class Normalize a where + normalize :: a -> NormState a + +instance Normalize a => Normalize [a] where + normalize = mapM normalize + +instance Normalize Int where + normalize i = do + (n, m) <- S.get + case Map.lookup i m of + Nothing -> do + S.put (n + 1, Map.insert i n m) + return n + Just n' -> return n' + +instance Normalize TypeExpr where + normalize (TVar i) = TVar <$> normalize i + normalize (TCons q tys) = TCons q <$> normalize tys + normalize (FuncType ty1 ty2) = FuncType <$> normalize ty1 <*> normalize ty2 + normalize (ForallType is ty) = ForallType <$> mapM normalizeTypeVar is + <*> normalize ty + where normalizeTypeVar (tv, k) = (,) <$> normalize tv <*> pure k + +instance Normalize a => Normalize (AFuncDecl a) where + normalize (AFunc f a v ty r) = AFunc f a v <$> normalize ty <*> normalize r + +instance Normalize a => Normalize (ARule a) where + normalize (ARule ty vs e) = ARule <$> normalize ty + <*> mapM normalizeTuple vs + <*> normalize e + normalize (AExternal ty s) = flip AExternal s <$> normalize ty + +normalizeTuple :: Normalize b => (a, b) -> NormState (a, b) +normalizeTuple (a, b) = (,) <$> pure a <*> normalize b + +instance Normalize a => Normalize (AExpr a) where + normalize (AVar ty v) = flip AVar v <$> normalize ty + normalize (ALit ty l) = flip ALit l <$> normalize ty + normalize (AComb ty ct f es) = flip AComb ct <$> normalize ty + <*> normalizeTuple f + <*> normalize es + normalize (ALet ty ds e) = ALet <$> normalize ty + <*> mapM normalizeBinding ds + <*> normalize e + where normalizeBinding (v, b) = (,) <$> normalizeTuple v <*> normalize b + normalize (AOr ty a b) = AOr <$> normalize ty <*> normalize a + <*> normalize b + normalize (ACase ty ct e bs) = flip ACase ct <$> normalize ty <*> normalize e + <*> normalize bs + normalize (AFree ty vs e) = AFree <$> normalize ty + <*> mapM normalizeTuple vs + <*> normalize e + normalize (ATyped ty e ty') = ATyped <$> normalize ty <*> normalize e + <*> normalize ty' + +instance Normalize a => Normalize (ABranchExpr a) where + normalize (ABranch p e) = ABranch <$> normalize p <*> normalize e + +instance Normalize a => Normalize (APattern a) where + normalize (APattern ty c vs) = APattern <$> normalize ty + <*> normalizeTuple c + <*> mapM normalizeTuple vs + normalize (ALPattern ty l) = flip ALPattern l <$> normalize ty + +-- ----------------------------------------------------------------------------- +-- Helper functions +-- ----------------------------------------------------------------------------- + +trQualIdent :: QualIdent -> FlatState QName +trQualIdent qid = do + mid <- getModuleIdent + return $ (moduleName $ fromMaybe mid mid', idName i) + where + mid' | i `elem` [listId, consId, nilId, unitId] || isTupleId i + = Just preludeMIdent + | otherwise + = qidModule qid + i = qidIdent qid + +getTypeVisibility :: QualIdent -> FlatState Visibility +getTypeVisibility i = S.gets $ \s -> + if Set.member (unqualify i) (tyExports s) then Public else Private + +getVisibility :: QualIdent -> FlatState Visibility +getVisibility i = S.gets $ \s -> + if Set.member (unqualify i) (valExports s) then Public else Private diff --git a/src/Generators/GenFlatCurry.hs b/src/Generators/GenFlatCurry.hs --- a/src/Generators/GenFlatCurry.hs +++ b/src/Generators/GenFlatCurry.hs @@ -15,39 +15,39 @@ import Curry.FlatCurry.Goodies import Curry.FlatCurry.Type -import Curry.FlatCurry.Typed.Goodies -import Curry.FlatCurry.Typed.Type +import Curry.FlatCurry.Annotated.Goodies +import Curry.FlatCurry.Annotated.Type -- transforms annotated FlatCurry code to FlatCurry code -genFlatCurry :: TProg -> Prog -genFlatCurry = trTProg +genFlatCurry :: AProg TypeExpr -> Prog +genFlatCurry = trAProg (\name imps types funcs ops -> Prog name imps types (map genFlatFuncDecl funcs) ops) -genFlatFuncDecl :: TFuncDecl -> FuncDecl -genFlatFuncDecl = trTFunc +genFlatFuncDecl :: AFuncDecl TypeExpr -> FuncDecl +genFlatFuncDecl = trAFunc (\name arity vis ty rule -> Func name arity vis ty $ genFlatRule rule) -genFlatRule :: TRule -> Rule -genFlatRule = trTRule - (\args e -> Rule (map fst args) $ genFlatExpr e) +genFlatRule :: ARule TypeExpr -> Rule +genFlatRule = trARule + (\_ args e -> Rule (map fst args) $ genFlatExpr e) (const External) -genFlatExpr :: TExpr -> Expr -genFlatExpr = trTExpr +genFlatExpr :: AExpr TypeExpr -> Expr +genFlatExpr = trAExpr (const Var) (const Lit) - (\_ ct name args -> Comb ct name args) - (\bs e -> Let (map (\(v, e') -> (fst v, e')) bs) e) - (\vs e -> Free (map fst vs) e) - Or - Case - (\pat e -> Branch (genFlatPattern pat) e) - Typed + (\_ ct (name, _) args -> Comb ct name args) + (const $ Let . map (\(v, e') -> (fst v, e'))) + (const $ Free . map fst) + (const Or) + (const Case) + (Branch . genFlatPattern) + (const Typed) -genFlatPattern :: TPattern -> Pattern -genFlatPattern = trTPattern - (\_ name args -> Pattern name $ map fst args) +genFlatPattern :: APattern TypeExpr -> Pattern +genFlatPattern = trAPattern + (\_ (name, _) args -> Pattern name $ map fst args) (const LPattern) -- transforms a FlatCurry module to a FlatCurry interface diff --git a/src/Generators/GenTypeAnnotatedFlatCurry.hs b/src/Generators/GenTypeAnnotatedFlatCurry.hs deleted file mode 100644 --- a/src/Generators/GenTypeAnnotatedFlatCurry.hs +++ /dev/null @@ -1,517 +0,0 @@ -{- | - Module : $Header$ - Description : Generation of typed FlatCurry program terms - Copyright : (c) 2017 Finn Teegen - 2018 Kai-Oliver Prott - License : BSD-3-clause - - Maintainer : fte@informatik.uni-kiel.de - Stability : experimental - Portability : portable - - This module contains the generation of a type-annotated 'FlatCurry' - program term for a given module in the intermediate language. --} -{-# LANGUAGE CPP #-} -module Generators.GenTypeAnnotatedFlatCurry (genTypeAnnotatedFlatCurry) where - -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<*>)) -#endif -import Control.Monad ((<=<)) -import Control.Monad.Extra (concatMapM) -import qualified Control.Monad.State as S ( State, evalState, get, gets - , modify, put ) -import Data.Function (on) -import Data.List (nub, sortBy) -import Data.Maybe (fromMaybe) -import qualified Data.Map as Map (Map, empty, insert, lookup) -import qualified Data.Set as Set (Set, empty, insert, member) - -import Curry.Base.Ident -import Curry.Base.SpanInfo -import Curry.FlatCurry.Annotated.Goodies (typeName) -import Curry.FlatCurry.Annotated.Type -import qualified Curry.Syntax as CS - -import Base.CurryTypes (toType) -import Base.Messages (internalError) -import Base.NestEnv ( NestEnv, emptyEnv, bindNestEnv, lookupNestEnv - , nestEnv, unnestEnv ) -import Base.TypeExpansion -import Base.Types - -import CompilerEnv -import Env.OpPrec (mkPrec) -import Env.TypeConstructor (TCEnv) -import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue) - -import qualified IL -import Transformations (transType) - --- TODO: Translate from TypedFlatCurry --- transforms intermediate language code (IL) to type-annotated FlatCurry code -genTypeAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module - -> AProg TypeExpr -genTypeAnnotatedFlatCurry env mdl il = patchPrelude $ run env mdl (trModule il) - --- ----------------------------------------------------------------------------- --- Addition of primitive types for lists and tuples to the Prelude --- ----------------------------------------------------------------------------- - -patchPrelude :: AProg a -> AProg a -patchPrelude p@(AProg n _ ts fs os) - | n == prelude = AProg n [] ts' fs os - | otherwise = p - where ts' = sortBy (compare `on` typeName) pts - pts = primTypes ++ ts - -primTypes :: [TypeDecl] -primTypes = - [ Type arrow Public [0, 1] [] - , Type unit Public [] [(Cons unit 0 Public [])] - , Type nil Public [0] [ Cons nil 0 Public [] - , Cons cons 2 Public [TVar 0, TCons nil [TVar 0]] - ] - ] ++ map mkTupleType [2 .. maxTupleArity] - where arrow = mkPreludeQName "(->)" - unit = mkPreludeQName "()" - nil = mkPreludeQName "[]" - cons = mkPreludeQName ":" - -mkTupleType :: Int -> TypeDecl -mkTupleType arity = Type tuple Public [0 .. arity - 1] - [Cons tuple arity Public (map TVar [0 .. arity - 1])] - where tuple = mkPreludeQName $ '(' : replicate (arity - 1) ',' ++ ")" - -mkPreludeQName :: String -> QName -mkPreludeQName n = (prelude, n) - -prelude :: String -prelude = "Prelude" - --- |Maximal arity of tuples -maxTupleArity :: Int -maxTupleArity = 15 - --- ----------------------------------------------------------------------------- - --- The environment 'FlatEnv' is embedded in the monadic representation --- 'FlatState' which allows the usage of 'do' expressions. -type FlatState a = S.State FlatEnv a - --- Data type for representing an environment which contains information needed --- for generating FlatCurry code. -data FlatEnv = FlatEnv - { modIdent :: ModuleIdent -- current module - -- for visibility calculation - , tyExports :: Set.Set Ident -- exported types - , valExports :: Set.Set Ident -- exported values (functions + constructors) - , tcEnv :: TCEnv -- type constructor environment - , tyEnv :: ValueEnv -- type environment - , fixities :: [CS.IDecl] -- fixity declarations - , typeSynonyms :: [CS.Decl Type] -- type synonyms - , imports :: [ModuleIdent] -- module imports - -- state for mapping identifiers to indexes - , nextVar :: Int -- fresh variable index counter - , varMap :: NestEnv VarIndex -- map of identifier to variable index - } - --- Runs a 'FlatState' action and returns the result -run :: CompilerEnv -> CS.Module Type -> FlatState a -> a -run env (CS.Module _ _ mid es is ds) act = S.evalState act env0 - where - es' = case es of Just (CS.Exporting _ e) -> e - _ -> [] - env0 = FlatEnv - { modIdent = mid - -- for visibility calculation - , tyExports = foldr (buildTypeExports mid) Set.empty es' - , valExports = foldr (buildValueExports mid) Set.empty es' - -- This includes *all* imports, even unused ones - , imports = nub [ m | CS.ImportDecl _ m _ _ _ <- is ] - -- Environment to retrieve the type of identifiers - , tyEnv = valueEnv env - , tcEnv = tyConsEnv env - -- Fixity declarations - , fixities = [ CS.IInfixDecl (spanInfo2Pos p) fix (mkPrec mPrec) (qualifyWith mid o) - | CS.InfixDecl p fix mPrec os <- ds, o <- os - ] - -- Type synonyms in the module - , typeSynonyms = [ d | d@CS.TypeDecl{} <- ds ] - , nextVar = 0 - , varMap = emptyEnv - } - --- Builds a table containing all exported identifiers from a module. -buildTypeExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident -buildTypeExports mid (CS.ExportTypeWith _ tc _) - | isLocalIdent mid tc = Set.insert (unqualify tc) -buildTypeExports _ _ = id - --- Builds a table containing all exported identifiers from a module. -buildValueExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident -buildValueExports mid (CS.Export _ q) - | isLocalIdent mid q = Set.insert (unqualify q) -buildValueExports mid (CS.ExportTypeWith _ tc cs) - | isLocalIdent mid tc = flip (foldr Set.insert) cs -buildValueExports _ _ = id - -getModuleIdent :: FlatState ModuleIdent -getModuleIdent = S.gets modIdent - -getArity :: QualIdent -> FlatState Int -getArity qid = S.gets tyEnv >>= \ env -> return $ case qualLookupValue qid env of - [DataConstructor _ a _ _] -> a - [NewtypeConstructor _ _ _] -> 1 - [Value _ _ a _] -> a - [Label _ _ _] -> 1 - _ -> - internalError ("GenTypeAnnotatedFlatCurry.getArity: " ++ qualName qid) - -getFixities :: FlatState [CS.IDecl] -getFixities = S.gets fixities - --- The function 'typeSynonyms' returns the list of type synonyms. -getTypeSynonyms :: FlatState [CS.Decl Type] -getTypeSynonyms = S.gets typeSynonyms - --- Retrieve imports -getImports :: [ModuleIdent] -> FlatState [String] -getImports imps = (nub . map moduleName . (imps ++)) <$> S.gets imports - --- ----------------------------------------------------------------------------- --- Stateful part, used for translation of rules and expressions --- ----------------------------------------------------------------------------- - --- resets var index and environment -withFreshEnv :: FlatState a -> FlatState a -withFreshEnv act = S.modify (\ s -> s { nextVar = 0, varMap = emptyEnv }) >> act - --- Execute an action in a nested variable mapping -inNestedEnv :: FlatState a -> FlatState a -inNestedEnv act = do - S.modify $ \ s -> s { varMap = nestEnv $ varMap s } - res <- act - S.modify $ \ s -> s { varMap = unnestEnv $ varMap s } - return res - --- Generates a new variable index for an identifier -newVar :: IL.Type -> Ident -> FlatState (VarIndex, TypeExpr) -newVar ty i = do - idx <- (+1) <$> S.gets nextVar - S.modify $ \ s -> s { nextVar = idx, varMap = bindNestEnv i idx (varMap s) } - ty' <- trType ty - return (idx, ty') - --- Retrieve the variable index assigned to an identifier -getVarIndex :: Ident -> FlatState VarIndex -getVarIndex i = S.gets varMap >>= \ varEnv -> case lookupNestEnv i varEnv of - [v] -> return v - _ -> internalError $ "GenTypeAnnotatedFlatCurry.getVarIndex: " ++ escName i - --- ----------------------------------------------------------------------------- --- Translation of an interface --- ----------------------------------------------------------------------------- - --- Translate an operator declaration -trIOpDecl :: CS.IDecl -> FlatState [OpDecl] -trIOpDecl (CS.IInfixDecl _ fix prec op) - = (\op' -> [Op op' (cvFixity fix) prec]) <$> trQualIdent op -trIOpDecl _ = return [] - --- ----------------------------------------------------------------------------- --- Translation of a module --- ----------------------------------------------------------------------------- - -trModule :: IL.Module -> FlatState (AProg TypeExpr) -trModule (IL.Module mid is ds) = do - is' <- getImports is - sns <- getTypeSynonyms >>= concatMapM trTypeSynonym - tds <- concatMapM trTypeDecl ds - fds <- concatMapM (return . map runNormalization <=< trAFuncDecl) ds - ops <- getFixities >>= concatMapM trIOpDecl - return $ AProg (moduleName mid) is' (sns ++ tds) fds ops - --- Translate a type synonym -trTypeSynonym :: CS.Decl a -> FlatState [TypeDecl] -trTypeSynonym (CS.TypeDecl _ t tvs ty) = do - m <- getModuleIdent - qid <- flip qualifyWith t <$> getModuleIdent - t' <- trQualIdent qid - vis <- getTypeVisibility qid - tEnv <- S.gets tcEnv - ty' <- trType (transType $ expandType m tEnv $ toType tvs ty) - return [TypeSyn t' vis [0 .. length tvs - 1] ty'] -trTypeSynonym _ = return [] - --- Translate a data declaration --- For empty data declarations, an additional constructor is generated. This --- is due to the fact that external data declarations are translated into data --- declarations with zero constructors and without the additional constructor --- empty data declarations could not be distinguished from external ones. -trTypeDecl :: IL.Decl -> FlatState [TypeDecl] -trTypeDecl (IL.DataDecl qid a []) = do - q' <- trQualIdent qid - vis <- getTypeVisibility qid - c <- trQualIdent $ qualify (mkIdent $ "_Constr#" ++ idName (unqualify qid)) - let tvs = [0 .. a - 1] - return [Type q' vis tvs [Cons c 1 Private [TCons q' $ map TVar tvs]]] -trTypeDecl (IL.DataDecl qid a cs) = do - q' <- trQualIdent qid - vis <- getTypeVisibility qid - cs' <- mapM trConstrDecl cs - return [Type q' vis [0 .. a - 1] cs'] -trTypeDecl (IL.ExternalDataDecl qid a) = do - q' <- trQualIdent qid - vis <- getTypeVisibility qid - return [Type q' vis [0 .. a - 1] []] -trTypeDecl _ = return [] - --- Translate a constructor declaration -trConstrDecl :: IL.ConstrDecl -> FlatState ConsDecl -trConstrDecl (IL.ConstrDecl qid tys) = flip Cons (length tys) - <$> trQualIdent qid - <*> getVisibility qid - <*> mapM trType tys - --- Translate a type expression -trType :: IL.Type -> FlatState TypeExpr -trType (IL.TypeConstructor t tys) = TCons <$> trQualIdent t <*> mapM trType tys -trType (IL.TypeVariable idx) = return $ TVar $ abs idx -trType (IL.TypeArrow ty1 ty2) = FuncType <$> trType ty1 <*> trType ty2 -trType (IL.TypeForall idxs ty) = ForallType (map abs idxs) <$> trType ty - --- Convert a fixity -cvFixity :: CS.Infix -> Fixity -cvFixity CS.InfixL = InfixlOp -cvFixity CS.InfixR = InfixrOp -cvFixity CS.Infix = InfixOp - --- ----------------------------------------------------------------------------- --- Function declarations --- ----------------------------------------------------------------------------- - --- Translate a function declaration -trAFuncDecl :: IL.Decl -> FlatState [AFuncDecl TypeExpr] -trAFuncDecl (IL.FunctionDecl f vs _ e) = do - f' <- trQualIdent f - a <- getArity f - vis <- getVisibility f - ty' <- trType ty - r' <- trARule ty vs e - return [AFunc f' a vis ty' r'] - where ty = foldr IL.TypeArrow (IL.typeOf e) $ map fst vs -trAFuncDecl (IL.ExternalDecl f ty) = do - f' <- trQualIdent f - a <- getArity f - vis <- getVisibility f - ty' <- trType ty - r' <- trAExternal ty f - return [AFunc f' a vis ty' r'] -trAFuncDecl _ = return [] - --- Translate a function rule. --- Resets variable index so that for every rule variables start with index 1 -trARule :: IL.Type -> [(IL.Type, Ident)] -> IL.Expression - -> FlatState (ARule TypeExpr) -trARule ty vs e = withFreshEnv $ ARule <$> trType ty - <*> mapM (uncurry newVar) vs - <*> trAExpr e - -trAExternal :: IL.Type -> QualIdent -> FlatState (ARule TypeExpr) -trAExternal ty f = flip AExternal (qualName f) <$> trType ty - --- Translate an expression -trAExpr :: IL.Expression -> FlatState (AExpr TypeExpr) -trAExpr (IL.Literal ty l) = ALit <$> trType ty <*> trLiteral l -trAExpr (IL.Variable ty v) = AVar <$> trType ty <*> getVarIndex v -trAExpr (IL.Function ty f _) = genCall Fun ty f [] -trAExpr (IL.Constructor ty c _) = genCall Con ty c [] -trAExpr (IL.Apply e1 e2) = trApply e1 e2 -trAExpr c@(IL.Case t e bs) = flip ACase (cvEval t) <$> trType (IL.typeOf c) <*> trAExpr e - <*> mapM (inNestedEnv . trAlt) bs -trAExpr (IL.Or e1 e2) = AOr <$> trType (IL.typeOf e1) <*> trAExpr e1 <*> trAExpr e2 -trAExpr (IL.Exist v ty e) = inNestedEnv $ do - v' <- newVar ty v - e' <- trAExpr e - ty' <- trType (IL.typeOf e) - return $ case e' of AFree ty'' vs e'' -> AFree ty'' (v' : vs) e'' - _ -> AFree ty' (v' : []) e' -trAExpr (IL.Let (IL.Binding v b) e) = inNestedEnv $ do - v' <- newVar (IL.typeOf b) v - b' <- trAExpr b - e' <- trAExpr e - ty' <- trType $ IL.typeOf e - return $ case e' of ALet ty'' bs e'' -> ALet ty'' ((v', b'):bs) e'' - _ -> ALet ty' ((v', b'):[]) e' -trAExpr (IL.Letrec bs e) = inNestedEnv $ do - let (vs, es) = unzip [ ((IL.typeOf b, v), b) | IL.Binding v b <- bs] - ALet <$> trType (IL.typeOf e) - <*> (zip <$> mapM (uncurry newVar) vs <*> mapM trAExpr es) - <*> trAExpr e -trAExpr (IL.Typed e _) = ATyped <$> ty' <*> trAExpr e <*> ty' - where ty' = trType $ IL.typeOf e - --- Translate a literal -trLiteral :: IL.Literal -> FlatState Literal -trLiteral (IL.Char c) = return $ Charc c -trLiteral (IL.Int i) = return $ Intc i -trLiteral (IL.Float f) = return $ Floatc f - --- Translate a higher-order application -trApply :: IL.Expression -> IL.Expression -> FlatState (AExpr TypeExpr) -trApply e1 e2 = genFlatApplic e1 [e2] - where - genFlatApplic e es = case e of - IL.Apply ea eb -> genFlatApplic ea (eb:es) - IL.Function ty f _ -> genCall Fun ty f es - IL.Constructor ty c _ -> genCall Con ty c es - _ -> do - expr <- trAExpr e - genApply expr es - --- Translate an alternative -trAlt :: IL.Alt -> FlatState (ABranchExpr TypeExpr) -trAlt (IL.Alt p e) = ABranch <$> trPat p <*> trAExpr e - --- Translate a pattern -trPat :: IL.ConstrTerm -> FlatState (APattern TypeExpr) -trPat (IL.LiteralPattern ty l) = ALPattern <$> trType ty <*> trLiteral l -trPat (IL.ConstructorPattern ty c vs) = do - qty <- trType $ foldr IL.TypeArrow ty $ map fst vs - APattern <$> trType ty <*> ((\q -> (q, qty)) <$> trQualIdent c) <*> mapM (uncurry newVar) vs -trPat (IL.VariablePattern _ _) = internalError "GenTypeAnnotatedFlatCurry.trPat" - --- Convert a case type -cvEval :: IL.Eval -> CaseType -cvEval IL.Rigid = Rigid -cvEval IL.Flex = Flex - -data Call = Fun | Con - --- Generate a function or constructor call -genCall :: Call -> IL.Type -> QualIdent -> [IL.Expression] - -> FlatState (AExpr TypeExpr) -genCall call ty f es = do - f' <- trQualIdent f - arity <- getArity f - case compare supplied arity of - LT -> genAComb ty f' es (part call (arity - supplied)) - EQ -> genAComb ty f' es (full call) - GT -> do - let (es1, es2) = splitAt arity es - funccall <- genAComb ty f' es1 (full call) - genApply funccall es2 - where - supplied = length es - full Fun = FuncCall - full Con = ConsCall - part Fun = FuncPartCall - part Con = ConsPartCall - -genAComb :: IL.Type -> QName -> [IL.Expression] -> CombType -> FlatState (AExpr TypeExpr) -genAComb ty qid es ct = do - ty' <- trType ty - let ty'' = defunc ty' (length es) - AComb ty'' ct (qid, ty') <$> mapM trAExpr es - where - defunc t 0 = t - defunc (FuncType _ t2) n = defunc t2 (n - 1) - defunc _ _ = internalError "GenTypeAnnotatedFlatCurry.genAComb.defunc" - -genApply :: AExpr TypeExpr -> [IL.Expression] -> FlatState (AExpr TypeExpr) -genApply e es = do - ap <- trQualIdent $ qApplyId - es' <- mapM trAExpr es - return $ foldl (\e1 e2 -> let FuncType ty1 ty2 = typeOf e1 in AComb ty2 FuncCall (ap, FuncType (FuncType ty1 ty2) (FuncType ty1 ty2)) [e1, e2]) e es' - --- ----------------------------------------------------------------------------- --- Normalization --- ----------------------------------------------------------------------------- - -runNormalization :: Normalize a => a -> a -runNormalization x = S.evalState (normalize x) (0, Map.empty) - -type NormState a = S.State (Int, Map.Map Int Int) a - -class Normalize a where - normalize :: a -> NormState a - -instance Normalize Int where - normalize i = do - (n, m) <- S.get - case Map.lookup i m of - Nothing -> do - S.put (n + 1, Map.insert i n m) - return n - Just n' -> return n' - -instance Normalize TypeExpr where - normalize (TVar i) = TVar <$> normalize i - normalize (TCons q tys) = TCons q <$> mapM normalize tys - normalize (FuncType ty1 ty2) = FuncType <$> normalize ty1 <*> normalize ty2 - normalize (ForallType is ty) = - ForallType <$> mapM normalize is <*> normalize ty - -instance Normalize b => Normalize (a, b) where - normalize (x, y) = ((,) x) <$> normalize y - -instance Normalize a => Normalize (AFuncDecl a) where - normalize (AFunc f a v ty r) = AFunc f a v <$> normalize ty <*> normalize r - -instance Normalize a => Normalize (ARule a) where - normalize (ARule ty vs e) = ARule <$> normalize ty - <*> mapM normalize vs - <*> normalize e - normalize (AExternal ty s) = flip AExternal s <$> normalize ty - -instance Normalize a => Normalize (AExpr a) where - normalize (AVar ty v) = flip AVar v <$> normalize ty - normalize (ALit ty l) = flip ALit l <$> normalize ty - normalize (AComb ty ct f es) = flip AComb ct <$> normalize ty - <*> normalize f - <*> mapM normalize es - normalize (ALet ty ds e) = ALet <$> normalize ty - <*> mapM normalizeBinding ds - <*> normalize e - where normalizeBinding (v, b) = (,) <$> normalize v <*> normalize b - normalize (AOr ty a b) = AOr <$> normalize ty <*> normalize a - <*> normalize b - normalize (ACase ty ct e bs) = flip ACase ct <$> normalize ty <*> normalize e - <*> mapM normalize bs - normalize (AFree ty vs e) = AFree <$> normalize ty <*> mapM normalize vs - <*> normalize e - normalize (ATyped ty e ty') = ATyped <$> normalize ty <*> normalize e - <*> normalize ty' - -instance Normalize a => Normalize (ABranchExpr a) where - normalize (ABranch p e) = ABranch <$> normalize p <*> normalize e - -instance Normalize a => Normalize (APattern a) where - normalize (APattern ty c vs) = APattern <$> normalize ty <*> normalize c - <*> mapM normalize vs - normalize (ALPattern ty l) = flip ALPattern l <$> normalize ty - --- ----------------------------------------------------------------------------- --- Helper functions --- ----------------------------------------------------------------------------- - -trQualIdent :: QualIdent -> FlatState QName -trQualIdent qid = do - mid <- getModuleIdent - return $ (moduleName $ fromMaybe mid mid', idName i) - where - mid' | i `elem` [listId, consId, nilId, unitId] || isTupleId i - = Just preludeMIdent - | otherwise - = qidModule qid - i = qidIdent qid - -getTypeVisibility :: QualIdent -> FlatState Visibility -getTypeVisibility i = S.gets $ \s -> - if Set.member (unqualify i) (tyExports s) then Public else Private - -getVisibility :: QualIdent -> FlatState Visibility -getVisibility i = S.gets $ \s -> - if Set.member (unqualify i) (valExports s) then Public else Private diff --git a/src/Generators/GenTypedFlatCurry.hs b/src/Generators/GenTypedFlatCurry.hs --- a/src/Generators/GenTypedFlatCurry.hs +++ b/src/Generators/GenTypedFlatCurry.hs @@ -15,498 +15,39 @@ {-# LANGUAGE CPP #-} module Generators.GenTypedFlatCurry (genTypedFlatCurry) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<*>)) -#endif -import Control.Monad ((<=<)) -import Control.Monad.Extra (concatMapM) -import qualified Control.Monad.State as S ( State, evalState, get, gets - , modify, put ) -import Data.Function (on) -import Data.List (nub, sortBy) -import Data.Maybe (fromMaybe) -import qualified Data.Map as Map (Map, empty, insert, lookup) -import qualified Data.Set as Set (Set, empty, insert, member) - -import Curry.Base.Ident -import Curry.Base.SpanInfo -import Curry.FlatCurry.Typed.Goodies (typeName) -import Curry.FlatCurry.Typed.Type -import qualified Curry.Syntax as CS - -import Base.CurryTypes (toType) -import Base.Messages (internalError) -import Base.NestEnv ( NestEnv, emptyEnv, bindNestEnv, lookupNestEnv - , nestEnv, unnestEnv ) -import Base.TypeExpansion -import Base.Types - -import CompilerEnv -import Env.OpPrec (mkPrec) -import Env.TypeConstructor (TCEnv) -import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue) - -import qualified IL -import Transformations (transType) - --- transforms intermediate language code (IL) to typed FlatCurry code -genTypedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module - -> TProg -genTypedFlatCurry env mdl il = patchPrelude $ run env mdl (trModule il) - --- ----------------------------------------------------------------------------- --- Addition of primitive types for lists and tuples to the Prelude --- ----------------------------------------------------------------------------- - -patchPrelude :: TProg -> TProg -patchPrelude p@(TProg n _ ts fs os) - | n == prelude = TProg n [] ts' fs os - | otherwise = p - where ts' = sortBy (compare `on` typeName) pts - pts = primTypes ++ ts - -primTypes :: [TypeDecl] -primTypes = - [ Type arrow Public [0, 1] [] - , Type unit Public [] [(Cons unit 0 Public [])] - , Type nil Public [0] [ Cons nil 0 Public [] - , Cons cons 2 Public [TVar 0, TCons nil [TVar 0]] - ] - ] ++ map mkTupleType [2 .. maxTupleArity] - where arrow = mkPreludeQName "(->)" - unit = mkPreludeQName "()" - nil = mkPreludeQName "[]" - cons = mkPreludeQName ":" - -mkTupleType :: Int -> TypeDecl -mkTupleType arity = Type tuple Public [0 .. arity - 1] - [Cons tuple arity Public (map TVar [0 .. arity - 1])] - where tuple = mkPreludeQName $ '(' : replicate (arity - 1) ',' ++ ")" - -mkPreludeQName :: String -> QName -mkPreludeQName n = (prelude, n) - -prelude :: String -prelude = "Prelude" - --- |Maximal arity of tuples -maxTupleArity :: Int -maxTupleArity = 15 - --- ----------------------------------------------------------------------------- - --- The environment 'FlatEnv' is embedded in the monadic representation --- 'FlatState' which allows the usage of 'do' expressions. -type FlatState a = S.State FlatEnv a - --- Data type for representing an environment which contains information needed --- for generating FlatCurry code. -data FlatEnv = FlatEnv - { modIdent :: ModuleIdent -- current module - -- for visibility calculation - , tyExports :: Set.Set Ident -- exported types - , valExports :: Set.Set Ident -- exported values (functions + constructors) - , tcEnv :: TCEnv -- type constructor environment - , tyEnv :: ValueEnv -- type environment - , fixities :: [CS.IDecl] -- fixity declarations - , typeSynonyms :: [CS.Decl Type] -- type synonyms - , imports :: [ModuleIdent] -- module imports - -- state for mapping identifiers to indexes - , nextVar :: Int -- fresh variable index counter - , varMap :: NestEnv VarIndex -- map of identifier to variable index - } - --- Runs a 'FlatState' action and returns the result -run :: CompilerEnv -> CS.Module Type -> FlatState a -> a -run env (CS.Module _ _ mid es is ds) act = S.evalState act env0 - where - es' = case es of Just (CS.Exporting _ e) -> e - _ -> [] - env0 = FlatEnv - { modIdent = mid - -- for visibility calculation - , tyExports = foldr (buildTypeExports mid) Set.empty es' - , valExports = foldr (buildValueExports mid) Set.empty es' - -- This includes *all* imports, even unused ones - , imports = nub [ m | CS.ImportDecl _ m _ _ _ <- is ] - -- Environment to retrieve the type of identifiers - , tyEnv = valueEnv env - , tcEnv = tyConsEnv env - -- Fixity declarations - , fixities = [ CS.IInfixDecl (spanInfo2Pos p) fix (mkPrec mPrec) (qualifyWith mid o) - | CS.InfixDecl p fix mPrec os <- ds, o <- os - ] - -- Type synonyms in the module - , typeSynonyms = [ d | d@CS.TypeDecl{} <- ds ] - , nextVar = 0 - , varMap = emptyEnv - } - --- Builds a table containing all exported identifiers from a module. -buildTypeExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident -buildTypeExports mid (CS.ExportTypeWith _ tc _) - | isLocalIdent mid tc = Set.insert (unqualify tc) -buildTypeExports _ _ = id - --- Builds a table containing all exported identifiers from a module. -buildValueExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident -buildValueExports mid (CS.Export _ q) - | isLocalIdent mid q = Set.insert (unqualify q) -buildValueExports mid (CS.ExportTypeWith _ tc cs) - | isLocalIdent mid tc = flip (foldr Set.insert) cs -buildValueExports _ _ = id - -getModuleIdent :: FlatState ModuleIdent -getModuleIdent = S.gets modIdent - -getArity :: QualIdent -> FlatState Int -getArity qid = S.gets tyEnv >>= \ env -> return $ case qualLookupValue qid env of - [DataConstructor _ a _ _] -> a - [NewtypeConstructor _ _ _] -> 1 - [Value _ _ a _] -> a - [Label _ _ _] -> 1 - _ -> internalError - ("GenTypedFlatCurry.getArity: " ++ qualName qid) - -getFixities :: FlatState [CS.IDecl] -getFixities = S.gets fixities - --- The function 'typeSynonyms' returns the list of type synonyms. -getTypeSynonyms :: FlatState [CS.Decl Type] -getTypeSynonyms = S.gets typeSynonyms - --- Retrieve imports -getImports :: [ModuleIdent] -> FlatState [String] -getImports imps = (nub . map moduleName . (imps ++)) <$> S.gets imports - --- ----------------------------------------------------------------------------- --- Stateful part, used for translation of rules and expressions --- ----------------------------------------------------------------------------- - --- resets var index and environment -withFreshEnv :: FlatState a -> FlatState a -withFreshEnv act = S.modify (\ s -> s { nextVar = 0, varMap = emptyEnv }) >> act - --- Execute an action in a nested variable mapping -inNestedEnv :: FlatState a -> FlatState a -inNestedEnv act = do - S.modify $ \ s -> s { varMap = nestEnv $ varMap s } - res <- act - S.modify $ \ s -> s { varMap = unnestEnv $ varMap s } - return res - --- Generates a new variable index for an identifier -newVar :: IL.Type -> Ident -> FlatState (VarIndex, TypeExpr) -newVar ty i = do - idx <- (+1) <$> S.gets nextVar - S.modify $ \ s -> s { nextVar = idx, varMap = bindNestEnv i idx (varMap s) } - ty' <- trType ty - return (idx, ty') - --- Retrieve the variable index assigned to an identifier -getVarIndex :: Ident -> FlatState VarIndex -getVarIndex i = S.gets varMap >>= \ varEnv -> case lookupNestEnv i varEnv of - [v] -> return v - _ -> internalError $ "GenFlatCurry.getVarIndex: " ++ escName i - --- ----------------------------------------------------------------------------- --- Translation of an interface --- ----------------------------------------------------------------------------- - --- Translate an operator declaration -trIOpDecl :: CS.IDecl -> FlatState [OpDecl] -trIOpDecl (CS.IInfixDecl _ fix prec op) - = (\op' -> [Op op' (cvFixity fix) prec]) <$> trQualIdent op -trIOpDecl _ = return [] - --- ----------------------------------------------------------------------------- --- Translation of a module --- ----------------------------------------------------------------------------- - -trModule :: IL.Module -> FlatState TProg -trModule (IL.Module mid is ds) = do - is' <- getImports is - sns <- getTypeSynonyms >>= concatMapM trTypeSynonym - tds <- concatMapM trTypeDecl ds - fds <- concatMapM (return . map runNormalization <=< trTFuncDecl) ds - ops <- getFixities >>= concatMapM trIOpDecl - return $ TProg (moduleName mid) is' (sns ++ tds) fds ops - --- Translate a type synonym -trTypeSynonym :: CS.Decl a -> FlatState [TypeDecl] -trTypeSynonym (CS.TypeDecl _ t tvs ty) = do - m <- getModuleIdent - qid <- flip qualifyWith t <$> getModuleIdent - t' <- trQualIdent qid - vis <- getTypeVisibility qid - tEnv <- S.gets tcEnv - ty' <- trType (transType $ expandType m tEnv $ toType tvs ty) - return [TypeSyn t' vis [0 .. length tvs - 1] ty'] -trTypeSynonym _ = return [] - --- Translate a data declaration --- For empty data declarations, an additional constructor is generated. This --- is due to the fact that external data declarations are translated into data --- declarations with zero constructors and without the additional constructor --- empty data declarations could not be distinguished from external ones. -trTypeDecl :: IL.Decl -> FlatState [TypeDecl] -trTypeDecl (IL.DataDecl qid a []) = do - q' <- trQualIdent qid - vis <- getTypeVisibility qid - c <- trQualIdent $ qualify (mkIdent $ "_Constr#" ++ idName (unqualify qid)) - let tvs = [0 .. a - 1] - return [Type q' vis tvs [Cons c 1 Private [TCons q' $ map TVar tvs]]] -trTypeDecl (IL.DataDecl qid a cs) = do - q' <- trQualIdent qid - vis <- getTypeVisibility qid - cs' <- mapM trConstrDecl cs - return [Type q' vis [0 .. a - 1] cs'] -trTypeDecl (IL.ExternalDataDecl qid a) = do - q' <- trQualIdent qid - vis <- getTypeVisibility qid - return [Type q' vis [0 .. a - 1] []] -trTypeDecl _ = return [] - --- Translate a constructor declaration -trConstrDecl :: IL.ConstrDecl -> FlatState ConsDecl -trConstrDecl (IL.ConstrDecl qid tys) = flip Cons (length tys) - <$> trQualIdent qid - <*> getVisibility qid - <*> mapM trType tys - --- Translate a type expression -trType :: IL.Type -> FlatState TypeExpr -trType (IL.TypeConstructor t tys) = TCons <$> trQualIdent t <*> mapM trType tys -trType (IL.TypeVariable idx) = return $ TVar $ abs idx -trType (IL.TypeArrow ty1 ty2) = FuncType <$> trType ty1 <*> trType ty2 -trType (IL.TypeForall idxs ty) = ForallType (map abs idxs) <$> trType ty - --- Convert a fixity -cvFixity :: CS.Infix -> Fixity -cvFixity CS.InfixL = InfixlOp -cvFixity CS.InfixR = InfixrOp -cvFixity CS.Infix = InfixOp - --- ----------------------------------------------------------------------------- --- Function declarations --- ----------------------------------------------------------------------------- - --- Translate a function declaration -trTFuncDecl :: IL.Decl -> FlatState [TFuncDecl] -trTFuncDecl (IL.FunctionDecl f vs _ e) = do - f' <- trQualIdent f - a <- getArity f - vis <- getVisibility f - ty' <- trType ty - r' <- trTRule vs e - return [TFunc f' a vis ty' r'] - where ty = foldr IL.TypeArrow (IL.typeOf e) $ map fst vs -trTFuncDecl (IL.ExternalDecl f ty) = do - f' <- trQualIdent f - a <- getArity f - vis <- getVisibility f - ty' <- trType ty - r' <- trTExternal ty f - return [TFunc f' a vis ty' r'] -trTFuncDecl _ = return [] - --- Translate a function rule. --- Resets variable index so that for every rule variables start with index 1 -trTRule :: [(IL.Type, Ident)] -> IL.Expression - -> FlatState TRule -trTRule vs e = withFreshEnv $ TRule <$> mapM (uncurry newVar) vs - <*> trTExpr e - -trTExternal :: IL.Type -> QualIdent -> FlatState TRule -trTExternal ty f = flip TExternal (qualName f) <$> trType ty - --- Translate an expression -trTExpr :: IL.Expression -> FlatState TExpr -trTExpr (IL.Literal ty l) = TLit <$> trType ty <*> trLiteral l -trTExpr (IL.Variable ty v) = TVarE <$> trType ty <*> getVarIndex v -trTExpr (IL.Function ty f _) = genCall Fun ty f [] -trTExpr (IL.Constructor ty c _) = genCall Con ty c [] -trTExpr (IL.Apply e1 e2) = trApply e1 e2 -trTExpr (IL.Case t e bs) = TCase (cvEval t) <$> trTExpr e - <*> mapM (inNestedEnv . trAlt) bs -trTExpr (IL.Or e1 e2) = TOr <$> trTExpr e1 <*> trTExpr e2 -trTExpr (IL.Exist v ty e) = inNestedEnv $ do - v' <- newVar ty v - e' <- trTExpr e - return $ case e' of TFree vs e'' -> TFree (v' : vs) e'' - _ -> TFree (v' : []) e' -trTExpr (IL.Let (IL.Binding v b) e) = inNestedEnv $ do - v' <- newVar (IL.typeOf b) v - b' <- trTExpr b - e' <- trTExpr e - return $ case e' of TLet bs e'' -> TLet ((v', b'):bs) e'' - _ -> TLet ((v', b'):[]) e' -trTExpr (IL.Letrec bs e) = inNestedEnv $ do - let (vs, es) = unzip [ ((IL.typeOf b, v), b) | IL.Binding v b <- bs] - TLet <$> (zip <$> mapM (uncurry newVar) vs <*> mapM trTExpr es) - <*> trTExpr e -trTExpr (IL.Typed e _) = TTyped <$> trTExpr e <*> ty' - where ty' = trType $ IL.typeOf e - --- Translate a literal -trLiteral :: IL.Literal -> FlatState Literal -trLiteral (IL.Char c) = return $ Charc c -trLiteral (IL.Int i) = return $ Intc i -trLiteral (IL.Float f) = return $ Floatc f - --- Translate a higher-order application -trApply :: IL.Expression -> IL.Expression -> FlatState TExpr -trApply e1 e2 = genFlatApplic e1 [e2] - where - genFlatApplic e es = case e of - IL.Apply ea eb -> genFlatApplic ea (eb:es) - IL.Function ty f _ -> genCall Fun ty f es - IL.Constructor ty c _ -> genCall Con ty c es - _ -> do - expr <- trTExpr e - genApply expr es - --- Translate an alternative -trAlt :: IL.Alt -> FlatState TBranchExpr -trAlt (IL.Alt p e) = TBranch <$> trPat p <*> trTExpr e - --- Translate a pattern -trPat :: IL.ConstrTerm -> FlatState TPattern -trPat (IL.LiteralPattern ty l) = TLPattern <$> trType ty <*> trLiteral l -trPat (IL.ConstructorPattern ty c vs) = - TPattern <$> trType ty <*> trQualIdent c <*> mapM (uncurry newVar) vs -trPat (IL.VariablePattern _ _) = internalError "GenTypedFlatCurry.trPat" - --- Convert a case type -cvEval :: IL.Eval -> CaseType -cvEval IL.Rigid = Rigid -cvEval IL.Flex = Flex - -data Call = Fun | Con - --- Generate a function or constructor call -genCall :: Call -> IL.Type -> QualIdent -> [IL.Expression] - -> FlatState TExpr -genCall call ty f es = do - f' <- trQualIdent f - arity <- getArity f - case compare supplied arity of - LT -> genTComb ty f' es (part call (arity - supplied)) - EQ -> genTComb ty f' es (full call) - GT -> do - let (es1, es2) = splitAt arity es - funccall <- genTComb ty f' es1 (full call) - genApply funccall es2 - where - supplied = length es - full Fun = FuncCall - full Con = ConsCall - part Fun = FuncPartCall - part Con = ConsPartCall - -genTComb :: IL.Type -> QName -> [IL.Expression] -> CombType -> FlatState TExpr -genTComb ty qid es ct = do - ty' <- trType ty - let ty'' = defunc ty' (length es) - TComb ty'' ct qid <$> mapM trTExpr es - where - defunc t 0 = t - defunc (FuncType _ t2) n = defunc t2 (n - 1) - defunc _ _ = internalError "GenTypedFlatCurry.genTComb.defunc" - -genApply :: TExpr -> [IL.Expression] -> FlatState TExpr -genApply e es = do - ap <- trQualIdent qApplyId - es' <- mapM trTExpr es - return $ foldl (\e1 e2 -> let FuncType _ ty2 = typeOf e1 - in TComb ty2 FuncCall ap [e1, e2]) - e es' - --- ----------------------------------------------------------------------------- --- Normalization --- ----------------------------------------------------------------------------- - -runNormalization :: Normalize a => a -> a -runNormalization x = S.evalState (normalize x) (0, Map.empty) - -type NormState a = S.State (Int, Map.Map Int Int) a - -class Normalize a where - normalize :: a -> NormState a - -instance Normalize Int where - normalize i = do - (n, m) <- S.get - case Map.lookup i m of - Nothing -> do - S.put (n + 1, Map.insert i n m) - return n - Just n' -> return n' - -instance Normalize TypeExpr where - normalize (TVar i) = TVar <$> normalize i - normalize (TCons q tys) = TCons q <$> mapM normalize tys - normalize (FuncType ty1 ty2) = FuncType <$> normalize ty1 <*> normalize ty2 - normalize (ForallType is ty) = - ForallType <$> mapM normalize is <*> normalize ty - -instance Normalize b => Normalize (a, b) where - normalize (x, y) = (,) x <$> normalize y - -instance Normalize TFuncDecl where - normalize (TFunc f a v ty r) = TFunc f a v <$> normalize ty <*> normalize r - -instance Normalize TRule where - normalize (TRule vs e) = TRule <$> mapM normalize vs - <*> normalize e - normalize (TExternal ty s) = flip TExternal s <$> normalize ty - -instance Normalize TExpr where - normalize (TVarE ty v) = flip TVarE v <$> normalize ty - normalize (TLit ty l) = flip TLit l <$> normalize ty - normalize (TComb ty ct f es) = flip TComb ct <$> normalize ty - <*> pure f - <*> mapM normalize es - normalize (TLet ds e) = TLet <$> mapM normalizeBinding ds - <*> normalize e - where normalizeBinding (v, b) = (,) <$> normalize v <*> normalize b - normalize (TOr a b) = TOr <$> normalize a - <*> normalize b - normalize (TCase ct e bs) = TCase ct <$> normalize e - <*> mapM normalize bs - normalize (TFree vs e) = TFree <$> mapM normalize vs - <*> normalize e - normalize (TTyped e ty') = TTyped <$> normalize e - <*> normalize ty' +import Curry.FlatCurry.Annotated.Type +import Curry.FlatCurry.Annotated.Goodies +import Curry.FlatCurry.Typed.Type -instance Normalize TBranchExpr where - normalize (TBranch p e) = TBranch <$> normalize p <*> normalize e +-- transforms annotated FlatCurry code to typed FlatCurry code +genTypedFlatCurry :: AProg TypeExpr -> TProg +genTypedFlatCurry = trAProg + (\name imps types funcs ops -> + TProg name imps types (map genTypedFuncDecl funcs) ops) -instance Normalize TPattern where - normalize (TPattern ty c vs) = TPattern <$> normalize ty - <*> pure c - <*> mapM normalize vs - normalize (TLPattern ty l) = flip TLPattern l <$> normalize ty +genTypedFuncDecl :: AFuncDecl TypeExpr -> TFuncDecl +genTypedFuncDecl = trAFunc + (\name arity vis ty rule -> TFunc name arity vis ty $ genTypedRule rule) --- ----------------------------------------------------------------------------- --- Helper functions --- ----------------------------------------------------------------------------- +genTypedRule :: ARule TypeExpr -> TRule +genTypedRule = trARule + (\_ args e -> TRule args $ genTypedExpr e) + TExternal -trQualIdent :: QualIdent -> FlatState QName -trQualIdent qid = do - mid <- getModuleIdent - return $ (moduleName $ fromMaybe mid mid', idName i) - where - mid' | i `elem` [listId, consId, nilId, unitId] || isTupleId i - = Just preludeMIdent - | otherwise - = qidModule qid - i = qidIdent qid +genTypedExpr :: AExpr TypeExpr -> TExpr +genTypedExpr = trAExpr + TVarE + TLit + (\ty ct (name, _) args -> TComb ty ct name args) + (const TLet) + (const TFree) + (const TOr) + (const TCase) + (TBranch . genTypedPattern) + (const TTyped) -getTypeVisibility :: QualIdent -> FlatState Visibility -getTypeVisibility i = S.gets $ \s -> - if Set.member (unqualify i) (tyExports s) then Public else Private +genTypedPattern :: APattern TypeExpr -> TPattern +genTypedPattern = trAPattern + (\ty (name, _) args -> TPattern ty name args) + TLPattern -getVisibility :: QualIdent -> FlatState Visibility -getVisibility i = S.gets $ \s -> - if Set.member (unqualify i) (valExports s) then Public else Private diff --git a/src/Html/CurryHtml.hs b/src/Html/CurryHtml.hs --- a/src/Html/CurryHtml.hs +++ b/src/Html/CurryHtml.hs @@ -70,10 +70,10 @@ [ "" , "" , "" - , "" - , "" + , "" + , "" , "" ++ titleHtml ++ "" - , "" + , "" , "" , "" , "" diff --git a/src/Html/SyntaxColoring.hs b/src/Html/SyntaxColoring.hs --- a/src/Html/SyntaxColoring.hs +++ b/src/Html/SyntaxColoring.hs @@ -257,7 +257,7 @@ -- ----------------------------------------------------------------------------- idsModule :: Module a -> [Code] -idsModule (Module _ _ mid es is ds) = +idsModule (Module _ _ _ mid es is ds) = let hdrCodes = ModuleName mid : idsExportSpec es impCodes = concatMap idsImportDecl (sortBy cmpImportDecl is) dclCodes = concatMap idsDecl (sortBy cmpDecl ds) @@ -299,35 +299,35 @@ -- Declarations idsDecl :: Decl a -> [Code] -idsDecl (InfixDecl _ _ _ ops) = +idsDecl (InfixDecl _ _ _ ops) = map (Function FuncInfix False . qualify) ops -idsDecl (DataDecl _ d vs cds clss) = +idsDecl (DataDecl _ d vs cds clss) = TypeCons TypeDeclare False (qualify d) : map (Identifier IdDeclare False . qualify) vs ++ concatMap idsConstrDecl cds ++ map (TypeCons TypeRefer False) clss -idsDecl (ExternalDataDecl _ d vs) = +idsDecl (ExternalDataDecl _ d vs) = TypeCons TypeDeclare False (qualify d) : map (Identifier IdDeclare False . qualify) vs -idsDecl (NewtypeDecl _ t vs nc clss) = +idsDecl (NewtypeDecl _ t vs nc clss) = TypeCons TypeDeclare False (qualify t) : map (Identifier IdDeclare False . qualify) vs ++ idsNewConstrDecl nc ++ map (TypeCons TypeRefer False) clss -idsDecl (TypeDecl _ t vs ty) = +idsDecl (TypeDecl _ t vs ty) = TypeCons TypeDeclare False (qualify t) : map (Identifier IdDeclare False . qualify) vs ++ idsTypeExpr ty -idsDecl (TypeSig _ fs qty) = +idsDecl (TypeSig _ fs qty) = map (Function FuncTypeSig False . qualify) fs ++ idsQualTypeExpr qty -idsDecl (FunctionDecl _ _ _ eqs) = concatMap idsEquation eqs -idsDecl (ExternalDecl _ fs) = +idsDecl (FunctionDecl _ _ _ eqs) = concatMap idsEquation eqs +idsDecl (ExternalDecl _ fs) = map (Function FuncDeclare False . qualify . varIdent) fs -idsDecl (PatternDecl _ p rhs) = idsPat p ++ idsRhs rhs -idsDecl (FreeDecl _ vs) = +idsDecl (PatternDecl _ p rhs) = idsPat p ++ idsRhs rhs +idsDecl (FreeDecl _ vs) = map (Identifier IdDeclare False . qualify . varIdent) vs -idsDecl (DefaultDecl _ tys) = concatMap idsTypeExpr tys -idsDecl (ClassDecl _ cx c v ds) = +idsDecl (DefaultDecl _ tys) = concatMap idsTypeExpr tys +idsDecl (ClassDecl _ _ cx c v ds) = idsContext cx ++ TypeCons TypeDeclare False (qualify c) : Identifier IdDeclare False (qualify v) : concatMap idsClassDecl ds -idsDecl (InstanceDecl _ cx c ty ds) = idsContext cx ++ +idsDecl (InstanceDecl _ _ cx c ty ds) = idsContext cx ++ TypeCons TypeRefer False c : idsTypeExpr ty ++ concatMap idsInstanceDecl ds idsConstrDecl :: ConstrDecl -> [Code] @@ -376,7 +376,7 @@ idsTypeExpr (ArrowType _ ty1 ty2) = concatMap idsTypeExpr [ty1, ty2] idsTypeExpr (ParenType _ ty) = idsTypeExpr ty idsTypeExpr (ForallType _ vs ty) = - map (Identifier IdDeclare False . qualify) vs ++ idsTypeExpr ty + map (Identifier IdDeclare False . qualify) vs ++ Symbol "." : idsTypeExpr ty idsFieldDecl :: FieldDecl -> [Code] idsFieldDecl (FieldDecl _ ls ty) = @@ -393,8 +393,8 @@ idsLhs (ApLhs _ lhs ps) = idsLhs lhs ++ concatMap idsPat ps idsRhs :: Rhs a -> [Code] -idsRhs (SimpleRhs _ e ds) = idsExpr e ++ concatMap idsDecl ds -idsRhs (GuardedRhs _ ce ds) = concatMap idsCondExpr ce ++ concatMap idsDecl ds +idsRhs (SimpleRhs _ _ e ds) = idsExpr e ++ concatMap idsDecl ds +idsRhs (GuardedRhs _ _ ce ds) = concatMap idsCondExpr ce ++ concatMap idsDecl ds idsCondExpr :: CondExpr a -> [Code] idsCondExpr (CondExpr _ e1 e2) = idsExpr e1 ++ idsExpr e2 @@ -446,10 +446,10 @@ idsExpr (LeftSection _ e op) = idsExpr e ++ idsInfix op idsExpr (RightSection _ op e) = idsInfix op ++ idsExpr e idsExpr (Lambda _ ps e) = concatMap idsPat ps ++ idsExpr e -idsExpr (Let _ ds e) = concatMap idsDecl ds ++ idsExpr e -idsExpr (Do _ stmts e) = concatMap idsStmt stmts ++ idsExpr e +idsExpr (Let _ _ ds e) = concatMap idsDecl ds ++ idsExpr e +idsExpr (Do _ _ stmts e) = concatMap idsStmt stmts ++ idsExpr e idsExpr (IfThenElse _ e1 e2 e3) = concatMap idsExpr [e1, e2, e3] -idsExpr (Case _ _ e alts) = idsExpr e ++ concatMap idsAlt alts +idsExpr (Case _ _ _ e alts) = idsExpr e ++ concatMap idsAlt alts idsField :: (a -> [Code]) -> Field a -> [Code] idsField f (Field _ l x) = Function FuncCall False l : f x @@ -459,9 +459,9 @@ idsInfix (InfixConstr _ qid) = [DataCons ConsInfix False qid] idsStmt :: Statement a -> [Code] -idsStmt (StmtExpr _ e) = idsExpr e -idsStmt (StmtDecl _ ds) = concatMap idsDecl ds -idsStmt (StmtBind _ p e) = idsPat p ++ idsExpr e +idsStmt (StmtExpr _ e) = idsExpr e +idsStmt (StmtDecl _ _ ds) = concatMap idsDecl ds +idsStmt (StmtBind _ p e) = idsPat p ++ idsExpr e idsAlt :: Alt a -> [Code] idsAlt (Alt _ p rhs) = idsPat p ++ idsRhs rhs diff --git a/src/IL/Pretty.hs b/src/IL/Pretty.hs --- a/src/IL/Pretty.hs +++ b/src/IL/Pretty.hs @@ -56,16 +56,19 @@ ppImport m = text "import" <+> text (moduleName m) ppDecl :: Decl -> Doc -ppDecl (DataDecl tc n cs) = sep $ - text "data" <+> ppTypeLhs tc n : +ppDecl (DataDecl tc ks cs) = sep $ + text "data" <+> ppTypeLhs tc (length ks) : map (nest dataIndent) (zipWith (<+>) (equals : repeat (char '|')) (map ppConstr cs)) -ppDecl (ExternalDataDecl tc n) = - text "external data" <+> ppTypeLhs tc n +ppDecl (NewtypeDecl tc ks nc) = sep $ + text "newtype" <+> ppTypeLhs tc (length ks) : + [nest dataIndent (equals <+> ppNewConstr nc)] +ppDecl (ExternalDataDecl tc ks) = + text "external data" <+> ppTypeLhs tc (length ks) ppDecl (FunctionDecl f vs ty e) = ppTypeSig f ty $$ sep [ ppQIdent f <+> hsep (map (ppIdent . snd) vs) <+> equals , nest bodyIndent (ppExpr 0 e)] -ppDecl (ExternalDecl f ty) = text "external" <+> ppTypeSig f ty +ppDecl (ExternalDecl f _ ty) = text "external" <+> ppTypeSig f ty ppTypeLhs :: QualIdent -> Int -> Doc ppTypeLhs tc n = ppQIdent tc <+> hsep (map text (take n typeVars)) @@ -73,6 +76,9 @@ ppConstr :: ConstrDecl -> Doc ppConstr (ConstrDecl c tys) = ppQIdent c <+> fsep (map (ppType 2) tys) +ppNewConstr :: NewConstrDecl -> Doc +ppNewConstr (NewConstrDecl c ty) = ppQIdent c <+> fsep [ppType 2 ty] + ppTypeSig :: QualIdent -> Type -> Doc ppTypeSig f ty = ppQIdent f <+> text "::" <+> ppType 0 ty @@ -83,9 +89,9 @@ | tc == qListId && length tys == 1 = brackets (ppType 0 (head tys)) | otherwise = parenIf (p > 1 && not (null tys)) (ppQIdent tc <+> fsep (map (ppType 2) tys)) -ppType _ (TypeVariable n) = ppTypeVar n -ppType p (TypeArrow ty1 ty2) = parenIf (p > 0) - (fsep (ppArrow (TypeArrow ty1 ty2))) +ppType _ (TypeVariable n) = ppTypeVar n +ppType p (TypeArrow ty1 ty2) = parenIf (p > 0) + (fsep (ppArrow (TypeArrow ty1 ty2))) where ppArrow (TypeArrow ty1' ty2') = ppType 1 ty1' <+> text "->" : ppArrow ty2' ppArrow ty = [ppType 0 ty] @@ -98,10 +104,10 @@ | n >= 0 = text (typeVars !! n) | otherwise = text ('_':show (-n)) -ppQuantifiedTypeVars :: [Int] -> Doc +ppQuantifiedTypeVars :: [(Int, Kind)] -> Doc ppQuantifiedTypeVars ns | null ns = empty - | otherwise = text "forall" <+> hsep (map ppTypeVar ns) <+> char '.' + | otherwise = text "forall" <+> hsep (map (ppTypeVar . fst) ns) <> char '.' ppBinding :: Binding -> Doc ppBinding (Binding v expr) = sep diff --git a/src/IL/ShowModule.hs b/src/IL/ShowModule.hs --- a/src/IL/ShowModule.hs +++ b/src/IL/ShowModule.hs @@ -39,6 +39,12 @@ . shows arity . space . showsList showsConstrDecl constrdecls . showsString ")" +showsDecl (NewtypeDecl qident arity newconstrdecl) + = showsString "(NewtypeDecl " + . showsQualIdent qident . space + . shows arity . space + . showsNewConstrDecl newconstrdecl + . showsString ")" showsDecl (ExternalDataDecl qident arity) = showsString "(ExternalDataDecl " . showsQualIdent qident . space @@ -51,9 +57,10 @@ . showsType typ . space . showsExpression expr . showsString ")" -showsDecl (ExternalDecl qident typ) +showsDecl (ExternalDecl qident arity typ) = showsString "(ExternalDecl " . showsQualIdent qident . space + . shows arity . showsType typ . showsString ")" @@ -62,6 +69,13 @@ = showsString "(ConstrDecl " . showsQualIdent qident . space . showsList showsType tys + . showsString ")" + +showsNewConstrDecl :: NewConstrDecl -> ShowS +showsNewConstrDecl (NewConstrDecl qident ty) + = showsString "(NewConstrDecl " + . showsQualIdent qident . space + . showsType ty . showsString ")" showsType :: Type -> ShowS diff --git a/src/IL/Type.hs b/src/IL/Type.hs --- a/src/IL/Type.hs +++ b/src/IL/Type.hs @@ -42,9 +42,12 @@ -} module IL.Type - ( -- * Data types - Module (..), Decl (..), ConstrDecl (..), Type (..), Literal (..) - , ConstrTerm (..), Expression (..), Eval (..), Alt (..), Binding (..) + ( -- * Representation of (type) variables + TypeVariableWithKind + -- * Data types + , Module (..), Decl (..), ConstrDecl (..), NewConstrDecl (..), Type (..) + , Kind (..), Literal (..), ConstrTerm (..), Expression (..), Eval (..) + , Alt (..), Binding (..) ) where import Curry.Base.Ident @@ -55,21 +58,33 @@ deriving (Eq, Show) data Decl - = DataDecl QualIdent Int [ConstrDecl] - | ExternalDataDecl QualIdent Int + = DataDecl QualIdent [Kind] [ConstrDecl] + | NewtypeDecl QualIdent [Kind] NewConstrDecl + | ExternalDataDecl QualIdent [Kind] | FunctionDecl QualIdent [(Type, Ident)] Type Expression - | ExternalDecl QualIdent Type + | ExternalDecl QualIdent Int Type deriving (Eq, Show) +data NewConstrDecl = NewConstrDecl QualIdent Type + deriving (Eq, Show) + data ConstrDecl = ConstrDecl QualIdent [Type] deriving (Eq, Show) +type TypeVariableWithKind = (Int, Kind) + data Type = TypeConstructor QualIdent [Type] | TypeVariable Int | TypeArrow Type Type - | TypeForall [Int] Type + | TypeForall [TypeVariableWithKind] Type deriving (Eq, Show) + +data Kind + = KindStar + | KindVariable Int + | KindArrow Kind Kind + deriving (Eq, Ord, Show) data Literal = Char Char diff --git a/src/Imports.hs b/src/Imports.hs --- a/src/Imports.hs +++ b/src/Imports.hs @@ -17,7 +17,7 @@ -} module Imports (importInterfaces, importModules, qualifyEnv) where -import Data.List (nubBy) +import Data.List (nubBy, find) import qualified Data.Map as Map import Data.Maybe (catMaybes, fromMaybe, isJust) import qualified Data.Set as Set @@ -49,7 +49,7 @@ importModules :: Monad m => Module a -> InterfaceEnv -> [ImportDecl] -> CYT m CompilerEnv -importModules mdl@(Module _ _ mid _ _ _) iEnv expImps +importModules mdl@(Module _ _ _ mid _ _ _) iEnv expImps = ok $ foldl importModule initEnv expImps where initEnv = (initCompilerEnv mid) @@ -265,11 +265,17 @@ where tc' = qualQualify m tc ty' = constrType tc' tvs values m (IFunctionDecl _ f Nothing a qty) = - [Value (qualQualify m f) False a (typeScheme (toQualPredType m [] qty))] + [Value (qualQualify m f) Nothing a (typeScheme (toQualPredType m [] qty))] values m (IFunctionDecl _ f (Just tv) _ qty) = - [Value (qualQualify m f) True 0 (typeScheme (toQualPredType m [tv] qty))] + let mcls = case qty of + QualTypeExpr _ ctx _ -> fmap (\(Constraint _ qcls _) -> qcls) $ + find (\(Constraint _ _ ty) -> isVar ty) ctx + in [Value (qualQualify m f) mcls 0 (typeScheme (toQualPredType m [tv] qty))] + where + isVar (VariableType _ i) = i == tv + isVar _ = False values m (IClassDecl _ _ qcls _ tv ds hs) = - map (classMethod m qcls' tv) (filter ((`notElem` hs) . imethod) ds) + map (classMethod m qcls' tv hs) ds where qcls' = qualQualify m qcls values _ _ = [] @@ -315,10 +321,13 @@ -- We always enter class methods with an arity of 0 into the value environment -- because there may be different implementations with different arities. -classMethod :: ModuleIdent -> QualIdent -> Ident -> IMethodDecl -> ValueInfo -classMethod m qcls tv (IMethodDecl _ f _ qty) = - Value (qualifyLike qcls f) True 0 $ +classMethod :: ModuleIdent -> QualIdent -> Ident -> [Ident] -> IMethodDecl + -> ValueInfo +classMethod m qcls tv hs (IMethodDecl _ f _ qty) = + Value (qualifyLike qcls f) mcls 0 $ typeScheme $ qualifyPredType m $ toMethodType qcls tv qty + where + mcls = if f `elem` hs then Nothing else Just qcls -- --------------------------------------------------------------------------- diff --git a/src/Interfaces.hs b/src/Interfaces.hs --- a/src/Interfaces.hs +++ b/src/Interfaces.hs @@ -77,7 +77,7 @@ loadInterfaces :: [FilePath] -- ^ 'FilePath's to search in for interfaces -> Module a -- ^ 'Module' header with import declarations -> CYIO InterfaceEnv -loadInterfaces paths (Module _ _ m _ is _) = do +loadInterfaces paths (Module _ _ _ m _ is _) = do res <- liftIO $ S.execStateT load (LoaderState initInterfaceEnv paths []) if null (errs res) then ok (iEnv res) else failMessages (reverse $ errs res) where load = mapM_ (loadInterface [m]) [(p, m') | ImportDecl p m' _ _ _ <- is] @@ -93,33 +93,32 @@ -- for in the import paths and compiled. loadInterface :: HasPosition a => [ModuleIdent] -> (a, ModuleIdent) -> IntfLoader () -loadInterface ctxt imp@(pp, m) - | m `elem` ctxt = report [errCyclicImport p (m : takeWhile (/= m) ctxt)] +loadInterface ctxt (_, m) + | m `elem` ctxt = report [errCyclicImport $ m : takeWhile (/= m) ctxt] | otherwise = do isLoaded <- loaded m unless isLoaded $ do paths <- searchPaths mbIntf <- liftIO $ lookupCurryInterface paths m case mbIntf of - Nothing -> report [errInterfaceNotFound p m] - Just fn -> compileInterface ctxt imp fn - where p = getPosition pp + Nothing -> report [errInterfaceNotFound m] + Just fn -> compileInterface ctxt m fn -- |Compile an interface by recursively loading its dependencies. -- -- After reading an interface, all imported interfaces are recursively -- loaded and inserted into the interface's environment. -compileInterface :: HasPosition p => [ModuleIdent] -> (p, ModuleIdent) -> FilePath +compileInterface :: [ModuleIdent] -> ModuleIdent -> FilePath -> IntfLoader () -compileInterface ctxt (p, m) fn = do +compileInterface ctxt m fn = do mbSrc <- liftIO $ readModule fn case mbSrc of - Nothing -> report [errInterfaceNotFound p m] + Nothing -> report [errInterfaceNotFound m] Just src -> case runCYMIgnWarn (parseInterface fn src) of Left err -> report err Right intf@(Interface n is _) -> if m /= n - then report [errWrongInterface (first fn) m n] + then report [errWrongInterface m n] else do let (intf', intfErrs) = intfSyntaxCheck intf mapM_ report [intfErrs] @@ -127,22 +126,22 @@ addInterface m intf' -- Error message for required interface that could not be found. -errInterfaceNotFound :: HasPosition p => p -> ModuleIdent -> Message -errInterfaceNotFound p m = posMessage p $ +errInterfaceNotFound :: ModuleIdent -> Message +errInterfaceNotFound m = spanInfoMessage m $ text "Interface for module" <+> text (moduleName m) <+> text "not found" -- Error message for an unexpected interface. -errWrongInterface :: HasPosition p => p -> ModuleIdent -> ModuleIdent -> Message -errWrongInterface p m n = posMessage p $ +errWrongInterface :: ModuleIdent -> ModuleIdent -> Message +errWrongInterface m n = spanInfoMessage m $ text "Expected interface for" <+> text (moduleName m) <> comma <+> text "but found" <+> text (moduleName n) -- Error message for a cyclic import. -errCyclicImport :: HasPosition p => p -> [ModuleIdent] -> Message -errCyclicImport _ [] = internalError "Interfaces.errCyclicImport: empty list" -errCyclicImport p [m] = posMessage p $ +errCyclicImport :: [ModuleIdent] -> Message +errCyclicImport [] = internalError "Interfaces.errCyclicImport: empty list" +errCyclicImport [m] = spanInfoMessage m $ text "Recursive import for module" <+> text (moduleName m) -errCyclicImport p ms = posMessage p $ +errCyclicImport ms = spanInfoMessage (head ms) $ text "Cyclic import dependency between modules" <+> hsep (punctuate comma (map text inits)) <+> text "and" <+> text lastm where diff --git a/src/Modules.hs b/src/Modules.hs --- a/src/Modules.hs +++ b/src/Modules.hs @@ -55,7 +55,7 @@ import qualified Curry.AbstractCurry as AC import qualified Curry.FlatCurry as FC import qualified Curry.Syntax as CS -import qualified IL as IL +import qualified IL import Checks import CompilerEnv @@ -93,11 +93,10 @@ writeParsed opts mdl let qmdl = qual mdl writeHtml opts qmdl - let umdl = (fst qmdl, fmap (const ()) (snd qmdl)) - writeAST opts umdl - writeShortAST opts umdl + writeAST opts (fst mdl, fmap (const ()) (snd mdl)) + writeShortAST opts (fst qmdl, fmap (const ()) (snd qmdl)) mdl' <- expandExports opts mdl - qmdl' <- dumpWith opts CS.showModule CS.ppModule DumpQualified $ qual mdl' + qmdl' <- dumpWith opts CS.showModule pPrint DumpQualified $ qual mdl' writeAbstractCurry opts qmdl' -- generate interface file let intf = uncurry exportInterface qmdl' @@ -106,7 +105,10 @@ ((env, il), mdl'') <- transModule opts qmdl' writeFlat opts env (snd mdl'') il where - withFlat = any (`elem` optTargetTypes opts) [TypedFlatCurry, FlatCurry] + withFlat = any (`elem` optTargetTypes opts) [ AnnotatedFlatCurry + , TypedFlatCurry + , FlatCurry + ] loadAndCheckModule :: Options -> ModuleIdent -> FilePath -> CYIO (CompEnv (CS.Module PredType)) @@ -125,13 +127,14 @@ -- parse and check module header (toks, mdl) <- parseModule opts m fn -- load the imported interfaces into an InterfaceEnv - let paths = map (addCurrySubdir (optUseSubdir opts)) + let paths = map (addOutDir (optUseOutDir opts) (optOutDir opts)) ("." : optImportPaths opts) - iEnv <- loadInterfaces paths mdl + let withPrel = importPrelude opts mdl + iEnv <- loadInterfaces paths withPrel checkInterfaces opts iEnv - is <- importSyntaxCheck iEnv mdl + is <- importSyntaxCheck iEnv withPrel -- add information of imported modules - cEnv <- importModules mdl iEnv is + cEnv <- importModules withPrel iEnv is return (cEnv { filePath = fn, tokens = toks }, mdl) parseModule :: Options -> ModuleIdent -> FilePath @@ -150,7 +153,7 @@ -- they will be issued a second time during parsing. spanToks <- liftCYM $ silent $ CS.lexSource fn condC ast <- liftCYM $ CS.parseModule fn condC - checked <- checkModuleHeader opts m fn ast + checked <- checkModuleHeader m fn ast return (spanToks, checked) preprocess :: PrepOpts -> FilePath -> String -> CYIO String @@ -179,33 +182,33 @@ removeFile fn return res -checkModuleHeader :: Monad m => Options -> ModuleIdent -> FilePath +checkModuleHeader :: Monad m => ModuleIdent -> FilePath -> CS.Module () -> CYT m (CS.Module ()) -checkModuleHeader opts m fn = checkModuleId m - . importPrelude opts - . CS.patchModuleId fn +checkModuleHeader m fn = checkModuleId m + . CS.patchModuleId fn -- |Check whether the 'ModuleIdent' and the 'FilePath' fit together checkModuleId :: Monad m => ModuleIdent -> CS.Module () -> CYT m (CS.Module ()) -checkModuleId mid m@(CS.Module _ _ mid' _ _ _) +checkModuleId mid m@(CS.Module _ _ _ mid' _ _ _) | mid == mid' = ok m | otherwise = failMessages [errModuleFileMismatch mid'] --- An implicit import of the prelude is added to the declarations of --- every module, except for the prelude itself, or when the import is disabled --- by a compiler option. If no explicit import for the prelude is present, --- the prelude is imported unqualified, otherwise a qualified import is added. +-- An implicit import of the prelude is temporariliy added to the declarations +-- of every module, except for the prelude itself, or when the import is +-- disabled by a compiler option. If no explicit import for the prelude is +-- present, the prelude is imported unqualified, +-- otherwise a qualified import is added. importPrelude :: Options -> CS.Module () -> CS.Module () -importPrelude opts m@(CS.Module spi ps mid es is ds) +importPrelude opts m@(CS.Module spi li ps mid es is ds) -- the Prelude itself - | mid == preludeMIdent = m + | mid == preludeMIdent = m -- disabled by compiler option - | noImpPrelude = m + | noImpPrelude = m -- already imported - | preludeMIdent `elem` imported = m + | preludeMIdent `elem` imports = m -- let's add it! - | otherwise = CS.Module spi ps mid es (preludeImp : is) ds + | otherwise = CS.Module spi li ps mid es (preludeImp:is) ds where noImpPrelude = NoImplicitPrelude `elem` optExtensions opts || m `CS.hasLanguageExtension` NoImplicitPrelude @@ -213,7 +216,7 @@ False -- qualified? Nothing -- no alias Nothing -- no selection of types, functions, etc. - imported = [imp | (CS.ImportDecl _ imp _ _ _) <- is] + imports = [imp | (CS.ImportDecl _ imp _ _ _) <- is] checkInterfaces :: Monad m => Options -> InterfaceEnv -> CYT m () checkInterfaces opts iEnv = mapM_ checkInterface (Map.elems iEnv) @@ -223,7 +226,7 @@ interfaceCheck opts (env, intf) importSyntaxCheck :: Monad m => InterfaceEnv -> CS.Module a -> CYT m [CS.ImportDecl] -importSyntaxCheck iEnv (CS.Module _ _ _ _ imps _) = mapM checkImportDecl imps +importSyntaxCheck iEnv (CS.Module _ _ _ _ _ imps _) = mapM checkImportDecl imps where checkImportDecl (CS.ImportDecl p m q asM is) = case Map.lookup m iEnv of Just intf -> CS.ImportDecl p m q asM `liftM` importCheck intf is @@ -252,7 +255,7 @@ where dumpCS :: (MonadIO m, Show a) => DumpLevel -> CompEnv (CS.Module a) -> m (CompEnv (CS.Module a)) - dumpCS = dumpWith opts CS.showModule CS.ppModule + dumpCS = dumpWith opts CS.showModule pPrint -- --------------------------------------------------------------------------- -- Translating a module @@ -261,19 +264,23 @@ transModule :: Options -> CompEnv (CS.Module PredType) -> CYIO (CompEnv IL.Module, CompEnv (CS.Module Type)) transModule opts mdl = do - derived <- dumpCS DumpDerived $ derive mdl - desugared <- dumpCS DumpDesugared $ desugar derived - dicts <- dumpCS DumpDictionaries $ insertDicts desugared - newtypes <- dumpCS DumpNewtypes $ removeNewtypes dicts - simplified <- dumpCS DumpSimplified $ simplify newtypes - lifted <- dumpCS DumpLifted $ lift simplified - il <- dumpIL DumpTranslated $ ilTrans lifted - ilCaseComp <- dumpIL DumpCaseCompleted $ completeCase il + derived <- dumpCS DumpDerived $ derive mdl + desugared <- dumpCS DumpDesugared $ desugar derived + dicts <- dumpCS DumpDictionaries $ insertDicts inlDi desugared + newtypes <- dumpCS DumpNewtypes $ removeNewtypes remNT dicts + simplified <- dumpCS DumpSimplified $ simplify newtypes + lifted <- dumpCS DumpLifted $ lift simplified + il <- dumpIL DumpTranslated $ ilTrans remIm lifted + ilCaseComp <- dumpIL DumpCaseCompleted $ completeCase il return (ilCaseComp, newtypes) where + optOpts = optOptimizations opts + inlDi = optInlineDictionaries optOpts + remIm = optRemoveUnusedImports optOpts + remNT = optDesugarNewtypes optOpts dumpCS :: Show a => DumpLevel -> CompEnv (CS.Module a) -> CYIO (CompEnv (CS.Module a)) - dumpCS = dumpWith opts CS.showModule CS.ppModule + dumpCS = dumpWith opts CS.showModule pPrint dumpIL = dumpWith opts IL.showModule IL.ppModule -- --------------------------------------------------------------------------- @@ -293,7 +300,7 @@ (showTokenStream (tokens env)) where tokTarget = Tokens `elem` optTargetTypes opts - useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env) + useSubDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env) writeComments :: Options -> CompilerEnv -> CYIO () writeComments opts env = when tokTarget $ liftIO $ @@ -301,7 +308,7 @@ (showCommentTokenStream $ tokens env) where tokTarget = Comments `elem` optTargetTypes opts - useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env) + useSubDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env) -- |Output the parsed 'Module' on request writeParsed :: Show a => Options -> CompEnv (CS.Module a) -> CYIO () @@ -309,7 +316,7 @@ writeModule (useSubDir $ sourceRepName (filePath env)) (CS.showModule mdl) where srcTarget = Parsed `elem` optTargetTypes opts - useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env) + useSubDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env) writeHtml :: Options -> CompEnv (CS.Module a) -> CYIO () writeHtml opts (env, mdl) = when htmlTarget $ @@ -329,8 +336,8 @@ interfaceFile = interfName (filePath env) outputInterface = liftIO $ writeModule - (addCurrySubdirModule (optUseSubdir opts) m interfaceFile) - (show $ CS.ppInterface intf) + (addOutDirModule (optUseOutDir opts) (optOutDir opts) m interfaceFile) + (show $ pPrint intf) matchInterface :: FilePath -> CS.Interface -> IO Bool matchInterface ifn i = do @@ -342,24 +349,24 @@ writeFlat :: Options -> CompilerEnv -> CS.Module Type -> IL.Module -> CYIO () writeFlat opts env mdl il = do - (_, tfc) <- dumpWith opts show (FC.ppProg . genFlatCurry) DumpTypedFlatCurry (env, tfcyProg) - when tfcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir tfcyName) tafcyProg - when tafcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir tafcyName) tfc + _ <- dumpWith opts show (pPrint . genFlatCurry) DumpTypedFlatCurry (env, afcy) + when afcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir afcyName) afcy + when tfcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir tfcyName) tfcy when fcyTarget $ do - (_, fc) <- dumpWith opts show FC.ppProg DumpFlatCurry (env, fcyProg) - liftIO $ FC.writeFlatCurry (useSubDir fcyName) fc - writeFlatIntf opts env fcyProg + _ <- dumpWith opts show pPrint DumpFlatCurry (env, fcy) + liftIO $ FC.writeFlatCurry (useSubDir fcyName) fcy + writeFlatIntf opts env fcy where - tfcyName = typedFlatName (filePath env) - tfcyProg = genTypedFlatCurry env mdl il - tfcyTarget = TypedFlatCurry `elem` optTargetTypes opts - tafcyName = typeAnnFlatName (filePath env) - tafcyProg = genTypeAnnotatedFlatCurry env mdl il - tafcyTarget = TypeAnnotatedFlatCurry `elem` optTargetTypes opts - fcyName = flatName (filePath env) - fcyProg = genFlatCurry tfcyProg - fcyTarget = FlatCurry `elem` optTargetTypes opts - useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env) + afcy = genAnnotatedFlatCurry env mdl il + afcyName = annotatedFlatName (filePath env) + afcyTarget = AnnotatedFlatCurry `elem` optTargetTypes opts + tfcy = genTypedFlatCurry afcy + tfcyName = typedFlatName (filePath env) + tfcyTarget = TypedFlatCurry `elem` optTargetTypes opts + fcy = genFlatCurry afcy + fcyName = flatName (filePath env) + fcyTarget = FlatCurry `elem` optTargetTypes opts + useSubDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env) writeFlatIntf :: Options -> CompilerEnv -> FC.Prog -> CYIO () writeFlatIntf opts env prog @@ -369,12 +376,12 @@ mfint <- liftIO $ FC.readFlatInterface targetFile let oldInterface = fromMaybe emptyIntf mfint when (mfint == mfint) $ return () -- necessary to close file -- TODO - unless (oldInterface `eqInterface` fint) $ outputInterface + unless (oldInterface `eqInterface` fint) outputInterface where targetFile = flatIntName (filePath env) emptyIntf = FC.Prog "" [] [] [] [] fint = genFlatInterface prog - useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env) + useSubDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env) outputInterface = liftIO $ FC.writeFlatCurry (useSubDir targetFile) fint writeAbstractCurry :: Options -> CompEnv (CS.Module PredType) -> CYIO () @@ -388,7 +395,7 @@ where acyTarget = AbstractCurry `elem` optTargetTypes opts uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts - useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env) + useSubDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env) writeAST :: Options -> CompEnv (CS.Module ()) -> CYIO () @@ -396,7 +403,7 @@ writeModule (useSubDir $ astName (filePath env)) (CS.showModule mdl) where astTarget = AST `elem` optTargetTypes opts - useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env) + useSubDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env) writeShortAST :: Options -> CompEnv (CS.Module ()) -> CYIO () @@ -405,7 +412,7 @@ (CS.showModule $ shortenModuleAST mdl) where astTarget = ShortAST `elem` optTargetTypes opts - useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env) + useSubDir = addOutDirModule (optUseOutDir opts) (optOutDir opts) (moduleIdent env) type Dump = (DumpLevel, CompilerEnv, String) diff --git a/src/Transformations.hs b/src/Transformations.hs --- a/src/Transformations.hs +++ b/src/Transformations.hs @@ -26,6 +26,8 @@ import Transformations.Qual as Q (qual) import Transformations.Simplify as S (simplify) +import Env.TypeConstructor + import CompilerEnv import Imports (qualifyEnv) import qualified IL @@ -48,19 +50,20 @@ (tyConsEnv env) mdl -- |Insert dictionaries, changes the type constructor and value environments. -insertDicts :: CompEnv (Module PredType) -> CompEnv (Module Type) -insertDicts (env, mdl) = (env { interfaceEnv = intfEnv' - , tyConsEnv = tcEnv' - , valueEnv = vEnv' - , opPrecEnv = pEnv' }, mdl') +insertDicts :: Bool -> CompEnv (Module PredType) -> CompEnv (Module Type) +insertDicts inlDi (env, mdl) = (env { interfaceEnv = intfEnv' + , tyConsEnv = tcEnv' + , valueEnv = vEnv' + , opPrecEnv = pEnv' }, mdl') where (mdl', intfEnv', tcEnv', vEnv', pEnv') = - DI.insertDicts (interfaceEnv env) (tyConsEnv env) (valueEnv env) - (classEnv env) (instEnv env) (opPrecEnv env) mdl + DI.insertDicts inlDi (interfaceEnv env) (tyConsEnv env) + (valueEnv env) (classEnv env) (instEnv env) + (opPrecEnv env) mdl -- |Remove newtype constructors. -removeNewtypes :: CompEnv (Module Type) -> CompEnv (Module Type) -removeNewtypes (env, mdl) = (env, mdl') - where mdl' = NT.removeNewtypes (valueEnv env) mdl +removeNewtypes :: Bool -> CompEnv (Module Type) -> CompEnv (Module Type) +removeNewtypes remNT (env, mdl) = (env, mdl') + where mdl' = NT.removeNewtypes remNT (valueEnv env) mdl -- |Simplify the source code, changes the value environment. simplify :: CompEnv (Module Type) -> CompEnv (Module Type) @@ -73,14 +76,14 @@ where (mdl', tyEnv') = L.lift (valueEnv env) mdl -- |Translate into the intermediate language -ilTrans :: CompEnv (Module Type) -> CompEnv IL.Module -ilTrans (env, mdl) = (env, il) - where il = IL.ilTrans (valueEnv env) mdl +ilTrans :: Bool -> CompEnv (Module Type) -> CompEnv IL.Module +ilTrans remIm (env, mdl) = (env, il) + where il = IL.ilTrans remIm (valueEnv env) (tyConsEnv env) mdl --- |Translate a type into its representation in the intermediate language -transType :: Type -> IL.Type +transType :: TCEnv -> Type -> IL.Type transType = IL.transType -- |Add missing case branches completeCase :: CompEnv IL.Module -> CompEnv IL.Module -completeCase (env, mdl) = (env, CC.completeCase (interfaceEnv env) mdl) +completeCase (env, mdl) = + (env, CC.completeCase (interfaceEnv env) (tyConsEnv env) mdl) diff --git a/src/Transformations/CaseCompletion.hs b/src/Transformations/CaseCompletion.hs --- a/src/Transformations/CaseCompletion.hs +++ b/src/Transformations/CaseCompletion.hs @@ -50,6 +50,7 @@ ) import Base.Subst +import Env.TypeConstructor import Env.Interface (InterfaceEnv, lookupInterface) import Transformations.CurryToIL (transType) @@ -59,9 +60,9 @@ -- Completes case expressions by adding branches for missing constructors. -- The interface environment 'iEnv' is needed to compute these constructors. -completeCase :: InterfaceEnv -> Module -> Module -completeCase iEnv mdl@(Module mid is ds) = Module mid is ds' - where ds'= S.evalState (mapM ccDecl ds) (CCState mdl iEnv 0) +completeCase :: InterfaceEnv -> TCEnv -> Module -> Module +completeCase iEnv tcEnv mdl@(Module mid is ds) = Module mid is ds' + where ds'= S.evalState (mapM ccDecl ds) (CCState mdl iEnv 0 tcEnv ) -- ----------------------------------------------------------------------------- -- Internally used state monad @@ -71,6 +72,7 @@ { modul :: Module , interfaceEnv :: InterfaceEnv , nextId :: Int + , tyconEnv :: TCEnv } type CCM a = S.State CCState a @@ -78,6 +80,9 @@ getModule :: CCM Module getModule = S.gets modul +getTCEnv :: CCM TCEnv +getTCEnv = S.gets tyconEnv + getInterfaceEnv :: CCM InterfaceEnv getInterfaceEnv = S.gets interfaceEnv @@ -96,7 +101,8 @@ ccDecl dd@(DataDecl _ _ _) = return dd ccDecl edd@(ExternalDataDecl _ _) = return edd ccDecl (FunctionDecl qid vs ty e) = FunctionDecl qid vs ty <$> ccExpr e -ccDecl ed@(ExternalDecl _ _) = return ed +ccDecl ed@(ExternalDecl _ _ _) = return ed +ccDecl nd@(NewtypeDecl _ _ _) = return nd ccExpr :: Expression -> CCM Expression ccExpr l@(Literal _ _) = return l @@ -165,8 +171,9 @@ completeConsAlts ea ce alts = do mdl <- getModule menv <- getInterfaceEnv + tcEnv <- getTCEnv -- complementary constructor patterns - complPats <- mapM genPat $ getComplConstrs mdl menv + complPats <- mapM genPat $ getComplConstrs mdl menv tcEnv [ c | (Alt (ConstructorPattern _ c _) _) <- consAlts ] v <- freshIdent w <- freshIdent @@ -315,16 +322,22 @@ failedExpr :: Type -> Expression failedExpr ty = Function ty (qualifyWith preludeMIdent (mkIdent "failed")) 0 +--TODO: Add note about arity of 0 because of the predefined functions in the Prelude eqExpr :: Expression -> Expression -> Expression -eqExpr e1 e2 = Apply (Apply (Function eqTy eq 2) e1) e2 - where eq = qImplMethodId preludeMIdent qEqId ty $ mkIdent "==" +eqExpr e1 e2 = Apply (Apply (Function eqTy eq 0) e1) e2 + where eq = qImplMethodId preludeMIdent qDataId ty $ mkIdent "===" ty = case e2 of Literal _ l -> case l of Char _ -> charType Int _ -> intType Float _ -> floatType _ -> internalError "CaseCompletion.eqExpr: no literal" - ty' = transType ty + ty' = case e2 of + Literal _ l -> case l of + Char _ -> charType' + Int _ -> intType' + Float _ -> floatType' + _ -> internalError "CaseCompletion.eqExpr: no literal" eqTy = TypeArrow ty' (TypeArrow ty' boolType') truePatt :: ConstrTerm @@ -334,8 +347,17 @@ falsePatt = ConstructorPattern boolType' qFalseId [] boolType' :: Type -boolType' = transType boolType +boolType' = IL.TypeConstructor qBoolId [] +charType' :: Type +charType' = IL.TypeConstructor qCharId [] + +intType' :: Type +intType' = IL.TypeConstructor qIntId [] + +floatType' :: Type +floatType' = IL.TypeConstructor qFloatId [] + -- --------------------------------------------------------------------------- -- The following functions compute the missing constructors for generating -- missing case alternatives @@ -345,17 +367,20 @@ -- This functions uses the module environment 'menv', which contains all -- imported constructors, except for the built-in list constructors. -- TODO: Check if the list constructors are in the menv. -getComplConstrs :: Module -> InterfaceEnv -> [QualIdent] -> [(QualIdent, [Type])] -getComplConstrs _ _ [] +getComplConstrs :: Module -> InterfaceEnv -> TCEnv + -> [QualIdent] -> [(QualIdent, [Type])] +getComplConstrs _ _ _ [] = internalError "CaseCompletion.getComplConstrs: empty constructor list" -getComplConstrs (Module mid _ ds) menv cs@(c:_) +getComplConstrs (Module mid _ ds) menv tcEnv cs@(c:_) -- built-in lists | c `elem` [qNilId, qConsId] = complementary cs - [(qNilId, []), (qConsId, [TypeVariable 0, transType (listType boolType)])] + [ (qNilId, []) + , (qConsId, [TypeVariable 0, transType tcEnv (listType boolType)]) + ] -- current module | mid' == mid = getCCFromDecls cs ds -- imported module - | otherwise = maybe [] (getCCFromIDecls mid' cs) + | otherwise = maybe [] (getCCFromIDecls mid' cs tcEnv) (lookupInterface mid' menv) where mid' = fromMaybe mid (qidModule c) @@ -379,9 +404,9 @@ constrInfo (ConstrDecl cid tys) = (cid, tys) -- Find complementary constructors within the module environment -getCCFromIDecls :: ModuleIdent -> [QualIdent] -> CS.Interface +getCCFromIDecls :: ModuleIdent -> [QualIdent] -> TCEnv-> CS.Interface -> [(QualIdent, [Type])] -getCCFromIDecls mid cs (CS.Interface _ _ ds) = complementary cs cinfos +getCCFromIDecls mid cs tcEnv (CS.Interface _ _ ds) = complementary cs cinfos where cinfos = map (uncurry constrInfo) $ maybe [] extractConstrDecls (find (`declares` head cs) ds) @@ -410,7 +435,7 @@ , [transType' vs ty | CS.FieldDecl _ ls ty <- fs, _ <- ls] ) - transType' vs = transType . toType vs + transType' vs = transType tcEnv . toType vs -- Compute complementary constructors complementary :: [QualIdent] -> [(QualIdent, [Type])] -> [(QualIdent, [Type])] @@ -430,10 +455,11 @@ instance SubstType Type where subst sigma (TypeConstructor q tys) = TypeConstructor q $ subst sigma tys - subst sigma (TypeVariable tv) = substVar' TypeVariable subst sigma tv - subst sigma (TypeArrow ty1 ty2) = TypeArrow (subst sigma ty1) (subst sigma ty2) - subst _ (TypeForall _ _) = - internalError "Transformations.CaseCompletion.SubstType.Type.subst" + subst sigma (TypeVariable tv) = substVar' TypeVariable subst sigma tv + subst sigma (TypeArrow ty1 ty2) + = TypeArrow (subst sigma ty1) (subst sigma ty2) + subst sigma (TypeForall tvs ty) + = TypeForall tvs (subst (foldr (unbindSubst . fst) sigma tvs) ty) matchType :: Type -> Type -> TypeSubst -> TypeSubst matchType ty1 ty2 = fromMaybe noMatch (matchType' ty1 ty2) diff --git a/src/Transformations/CurryToIL.hs b/src/Transformations/CurryToIL.hs --- a/src/Transformations/CurryToIL.hs +++ b/src/Transformations/CurryToIL.hs @@ -30,28 +30,34 @@ import Control.Monad.Extra (concatMapM) import qualified Control.Monad.Reader as R +import qualified Control.Monad.State as S import Data.List (nub, partition) -import qualified Data.Map as Map (Map, empty, insert, lookup) +import Data.Maybe (fromJust) +import qualified Data.Map as Map import qualified Data.Set as Set (Set, empty, insert, delete, toList) import Curry.Base.Ident import Curry.Syntax hiding (caseAlt) -import Base.CurryTypes (toType) import Base.Expr import Base.Messages (internalError) -import Base.Types +import Base.Types hiding (polyType) +import Base.Kinds import Base.Typing import Base.Utils (foldr2) +import Env.TypeConstructor import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue) import qualified IL as IL -ilTrans :: ValueEnv -> Module Type -> IL.Module -ilTrans vEnv (Module _ _ m _ _ ds) = IL.Module m (imports m ds') ds' - where ds' = R.runReader (concatMapM trDecl ds) (TransEnv m vEnv) +ilTrans :: Bool -> ValueEnv -> TCEnv -> Module Type -> IL.Module +ilTrans remIm vEnv tcEnv (Module _ _ _ m _ im ds) = IL.Module m im' ds' + where ds' = R.runReader (concatMapM trDecl ds) (TransEnv m vEnv tcEnv) + im' = preludeMIdent : if remIm then imports m ds' else map moduleImport im + moduleImport (ImportDecl _ mdl _ _ _) = mdl + -- ----------------------------------------------------------------------------- -- Computation of necessary imports -- ----------------------------------------------------------------------------- @@ -65,9 +71,11 @@ mdlsDecl :: IL.Decl -> Set.Set ModuleIdent -> Set.Set ModuleIdent mdlsDecl (IL.DataDecl _ _ cs) ms = foldr mdlsConstrsDecl ms cs where mdlsConstrsDecl (IL.ConstrDecl _ tys) ms' = foldr mdlsType ms' tys +mdlsDecl (IL.NewtypeDecl _ _ nc) ms = mdlsNewConstrDecl nc + where mdlsNewConstrDecl (IL.NewConstrDecl _ ty) = mdlsType ty ms mdlsDecl (IL.ExternalDataDecl _ _) ms = ms mdlsDecl (IL.FunctionDecl _ _ ty e) ms = mdlsType ty (mdlsExpr e ms) -mdlsDecl (IL.ExternalDecl _ ty) ms = mdlsType ty ms +mdlsDecl (IL.ExternalDecl _ _ ty) ms = mdlsType ty ms mdlsType :: IL.Type -> Set.Set ModuleIdent -> Set.Set ModuleIdent mdlsType (IL.TypeConstructor tc tys) ms = modules tc (foldr mdlsType ms tys) @@ -103,6 +111,7 @@ data TransEnv = TransEnv { moduleIdent :: ModuleIdent , valueEnv :: ValueEnv + , tyconEnv :: TCEnv } type TransM a = R.Reader TransEnv a @@ -110,17 +119,22 @@ getValueEnv :: TransM ValueEnv getValueEnv = R.asks valueEnv +getTCEnv :: TransM TCEnv +getTCEnv = R.asks tyconEnv + trQualify :: Ident -> TransM QualIdent trQualify i = flip qualifyWith i <$> R.asks moduleIdent --- Return the type of a variable -varType :: QualIdent -> TransM Type -varType f = do - tyEnv <- getValueEnv - case qualLookupValue f tyEnv of - [Value _ _ _ (ForAll _ (PredType _ ty))] -> return ty - [Label _ _ (ForAll _ (PredType _ ty))] -> return ty - _ -> internalError $ "CurryToIL.varType: " ++ show f +getArity :: QualIdent -> TransM Int +getArity qid = do + vEnv <- getValueEnv + return $ case qualLookupValue qid vEnv of + [DataConstructor _ a _ _] -> a + [NewtypeConstructor _ _ _] -> 1 + [Value _ _ a _] -> a + [Label _ _ _] -> 1 + _ -> + internalError $ "CurryToIL.getArity: " ++ show qid -- Return the type of a constructor constrType :: QualIdent -> TransM Type @@ -131,6 +145,14 @@ [NewtypeConstructor _ _ (ForAll _ (PredType _ ty))] -> return ty _ -> internalError $ "CurryToIL.constrType: " ++ show c +-- Return the kinds of a type constructor's type variables +tcTVarKinds :: QualIdent -> TransM [Kind] +tcTVarKinds qid = do + tcEnv <- getTCEnv + let mid = fromJust $ qidModule qid + kind = tcKind mid qid tcEnv + return $ kindArgs kind + -- ----------------------------------------------------------------------------- -- Translation -- ----------------------------------------------------------------------------- @@ -144,57 +166,177 @@ trDecl :: Decl Type -> TransM [IL.Decl] trDecl (DataDecl _ tc tvs cs _) = (:[]) <$> trData tc tvs cs +trDecl (NewtypeDecl _ tc tvs nc _) = (:[]) <$> trNewtype tc tvs nc trDecl (ExternalDataDecl _ tc tvs) = (:[]) <$> trExternalData tc tvs -trDecl (FunctionDecl _ ty f eqs) = (:[]) <$> trFunction f ty eqs +trDecl (FunctionDecl _ _ f eqs) = (:[]) <$> trFunction f eqs trDecl (ExternalDecl _ vs) = mapM trExternal vs trDecl _ = return [] trData :: Ident -> [Ident] -> [ConstrDecl] -> TransM IL.Decl trData tc tvs cs = do tc' <- trQualify tc - IL.DataDecl tc' (length tvs) <$> mapM trConstrDecl cs + ks <- tcTVarKinds tc' + IL.DataDecl tc' (transKind <$> ks) <$> mapM trConstrDecl cs +trNewtype :: Ident -> [Ident] -> NewConstrDecl -> TransM IL.Decl +trNewtype tc tvs nc = do + tc' <- trQualify tc + ks <- tcTVarKinds tc' + IL.NewtypeDecl tc' (transKind <$> ks) <$> trNewConstrDecl nc + trConstrDecl :: ConstrDecl -> TransM IL.ConstrDecl trConstrDecl d = do c' <- trQualify (constr d) ty' <- arrowArgs <$> constrType c' - return $ IL.ConstrDecl c' (map transType ty') + tcEnv <- getTCEnv + return $ IL.ConstrDecl c' (map (transType tcEnv) ty') where constr (ConstrDecl _ c _) = c constr (ConOpDecl _ _ op _) = op constr (RecordDecl _ c _) = c +trNewConstrDecl :: NewConstrDecl -> TransM IL.NewConstrDecl +trNewConstrDecl d = do + c' <- trQualify (constr d) + ty' <- arrowArgs <$> constrType c' + tcEnv <- getTCEnv + case ty' of + [ty] -> return $ IL.NewConstrDecl c' (transType tcEnv ty) + _ -> internalError "CurryToIL.trNewConstrDecl: invalid constructor type" + where + constr (NewConstrDecl _ c _) = c + constr (NewRecordDecl _ c _) = c + trExternalData :: Ident -> [Ident] -> TransM IL.Decl -trExternalData tc tvs = flip IL.ExternalDataDecl (length tvs) <$> trQualify tc +trExternalData tc tvs = do + tc' <- trQualify tc + ks <- tcTVarKinds tc' + return $ IL.ExternalDataDecl tc' (transKind <$> ks) trExternal :: Var Type -> TransM IL.Decl -trExternal (Var ty f) = flip IL.ExternalDecl (transType ty) <$> trQualify f +trExternal (Var ty f) = do + tcEnv <- getTCEnv + f' <- trQualify f + a <- getArity f' + return $ IL.ExternalDecl f' a (transType tcEnv $ polyType ty) -- The type representation in the intermediate language does not support -- types with higher order kinds. Therefore, the type transformations has -- to transform all types to first order terms. To that end, we assume the --- existence of a type synonym 'type @ f a = f a'. In addition, the type +-- existence of a type synonym 'type Apply f a = f a'. In addition, the type -- representation of the intermediate language does not support constrained -- type variables and skolem types. The former are fixed and the later are -- replaced by fresh type constructors. -transType :: Type -> IL.Type -transType ty = transType' ty [] - -transType' :: Type -> [IL.Type] -> IL.Type -transType' (TypeConstructor tc) = IL.TypeConstructor tc -transType' (TypeApply ty1 ty2) = transType' ty1 . (transType ty2 :) -transType' (TypeVariable tv) = foldl applyType' (IL.TypeVariable tv) -transType' (TypeConstrained tys _) = transType' (head tys) -transType' (TypeArrow ty1 ty2) = - foldl applyType' (IL.TypeArrow (transType ty1) (transType ty2)) -transType' (TypeForall tvs ty) = - foldl applyType' (IL.TypeForall tvs (transType ty)) +transType :: TCEnv -> Type -> IL.Type +transType tcEnv ty' = transType' ty' [] + where + ks = transTVars tcEnv ty' + transType' (TypeConstructor tc) = IL.TypeConstructor tc + transType' (TypeApply ty1 ty2) = transType' ty1 . (transType' ty2 [] :) + transType' (TypeVariable tv) = foldl applyType' (IL.TypeVariable tv) + transType' (TypeConstrained tys _) = transType' (head tys) + transType' (TypeArrow ty1 ty2) = + foldl applyType' (IL.TypeArrow (transType' ty1 []) (transType' ty2 [])) + transType' (TypeForall tvs ty) = + foldl applyType' (IL.TypeForall tvs' (transType' ty [])) + where tvs' = filter ((`elem` tvs) . fst) ks applyType' :: IL.Type -> IL.Type -> IL.Type applyType' ty1 ty2 = IL.TypeConstructor (qualifyWith preludeMIdent (mkIdent "Apply")) [ty1, ty2] +-- We need to existentially quantify all variables in some types +polyType :: Type -> Type +polyType (TypeForall _ ty) = polyType ty +polyType ty = + let vs = nub $ typeVars ty + in if null vs then ty else TypeForall vs ty + +-- We need to infer kinds for the quantified variables. +-- We already checked the correctness of all Kinds earlier, +-- thus we know that we will be able to unify all the inferred equations. +-- We can also keep a flat environment, +-- as all variables have already been renamed. + +data KIS = KIS + { _nextId :: Int + , kinds :: Map.Map Int IL.Kind + } + +freshId :: S.State KIS Int +freshId = do + KIS i ks <- S.get + S.put (KIS (i+1) ks) + return i + +transTVars :: TCEnv -> Type -> [(Int, IL.Kind)] +transTVars tcEnv ty' = + Map.toList $ kinds $ S.execState (build ty' IL.KindStar) (KIS 0 Map.empty) + where + build :: Type -> IL.Kind -> S.State KIS () + build (TypeArrow ty1 ty2) _ = + build ty1 IL.KindStar >> build ty2 IL.KindStar + build (TypeConstrained tys _) k = + build (head tys) k + build (TypeForall _ ty) k = + build ty k + build (TypeVariable tv) k = do + KIS i ks <- S.get + -- get current kind + let k' = Map.findWithDefault k tv ks + -- unify it + let s = unifyKind k k' + -- apply substitution + let ks' = fmap (applyKindSubst s) $ Map.insert tv k' ks + S.put (KIS i ks') + build (TypeConstructor _) _ = return () + build ta@(TypeApply _ _) k = + let (ty, tys) = unapplyType True ta + in case ty of + TypeConstructor tc -> do + let k' = tcKind (fromJust $ qidModule tc) tc tcEnv + mapM_ (uncurry build) (zip tys $ unarrowKind $ transKind k') + _ -> do -- var of forall + -- construct new kind vars + ks <- mapM (const (freshId >>= return . IL.KindVariable)) tys + -- infer kind for v + build ty (foldr IL.KindArrow k ks) + -- infer kinds for args + mapM_ (uncurry build) (zip tys ks) + +type KindSubst = Map.Map Int IL.Kind + +transKind :: Kind -> IL.Kind +transKind KindStar = IL.KindStar +transKind (KindVariable _) = IL.KindStar +transKind (KindArrow k1 k2) = IL.KindArrow (transKind k1) (transKind k2) + +unarrowKind :: IL.Kind -> [IL.Kind] +unarrowKind (IL.KindArrow k1 k2) = k1 : unarrowKind k2 +unarrowKind k = [k] + +applyKindSubst :: KindSubst -> IL.Kind -> IL.Kind +applyKindSubst _ IL.KindStar = + IL.KindStar +applyKindSubst s (IL.KindArrow k1 k2) = + IL.KindArrow (applyKindSubst s k1) (applyKindSubst s k2) +applyKindSubst s v@(IL.KindVariable i) = + Map.findWithDefault v i s + +composeKindSubst :: KindSubst -> KindSubst -> KindSubst +composeKindSubst s1 s2 = Map.map (applyKindSubst s1) s2 `Map.union` s1 + +unifyKind :: IL.Kind -> IL.Kind -> KindSubst +unifyKind IL.KindStar IL.KindStar = Map.empty +unifyKind (IL.KindVariable i) k = Map.singleton i k +unifyKind k (IL.KindVariable i) = Map.singleton i k +unifyKind (IL.KindArrow k1 k2) (IL.KindArrow k1' k2') = + let s1 = unifyKind k1 k1' + s2 = unifyKind (applyKindSubst s1 k2) (applyKindSubst s1 k2') + in s1 `composeKindSubst` s2 +unifyKind k1 k2 = error $ "Transformation.CurryToIL.unifyKind: " ++ show k1 ++ ", " ++ show k2 + -- Each function in the program is translated into a function of the -- intermediate language. The arguments of the function are renamed such -- that all variables occurring in the same position (in different @@ -215,17 +357,19 @@ -- selector function have to be renamed according to the name mapping -- computed for its first argument. -trFunction :: Ident -> Type -> [Equation Type] -> TransM IL.Decl -trFunction f ty eqs = do +trFunction :: Ident -> [Equation Type] -> TransM IL.Decl +trFunction f eqs = do f' <- trQualify f - let ty' = transType ty - vs' = zip (map (transType . typeOf) ts) vs + tcEnv <- getTCEnv + let tys = map typeOf ts + ty' = transType tcEnv $ polyType $ foldr TypeArrow (typeOf rhs) tys + vs' = zip (map (transType tcEnv) tys) vs alts <- mapM (trEquation vs ws) eqs return $ IL.FunctionDecl f' vs' ty' (flexMatch vs' alts) where -- vs are the variables needed for the function: _1, _2, etc. -- ws is an infinite list for introducing additional variables later - Equation _ lhs _ = head eqs + Equation _ lhs rhs = head eqs (_, ts) = flatLhs lhs (vs, ws) = splitAt (length ts) (argNames (mkIdent "")) @@ -239,7 +383,8 @@ -- translate right-hand-side rhs' <- trRhs vs' patternRenaming rhs -- convert patterns - return (zipWith trPattern vs ts, rhs') + tcEnv <- getTCEnv + return (zipWith (trPattern tcEnv) vs ts, rhs') trEquation _ _ _ = internalError "Translation of non-FunLhs euqation not defined" @@ -257,8 +402,8 @@ = internalError "CurryToIL.bindRenameEnv" trRhs :: [Ident] -> RenameEnv -> Rhs Type -> TransM IL.Expression -trRhs vs env (SimpleRhs _ e _) = trExpr vs env e -trRhs _ _ (GuardedRhs _ _ _) = internalError "CurryToIL.trRhs: GuardedRhs" +trRhs vs env (SimpleRhs _ _ e _) = trExpr vs env e +trRhs _ _ (GuardedRhs _ _ _ _) = internalError "CurryToIL.trRhs: GuardedRhs" -- Note that the case matching algorithm assumes that the matched -- expression is accessible through a variable. The translation of case @@ -269,22 +414,30 @@ -- instance, if one of the alternatives contains an as-pattern. trExpr :: [Ident] -> RenameEnv -> Expression Type -> TransM IL.Expression -trExpr _ _ (Literal _ ty l) = return $ IL.Literal (transType ty) (trLiteral l) +trExpr _ _ (Literal _ ty l) = do + tcEnv <- getTCEnv + return $ IL.Literal (transType tcEnv ty) (trLiteral l) trExpr _ env (Variable _ ty v) - | isQualified v = fun - | otherwise = case Map.lookup (unqualify v) env of - Nothing -> fun - Just v' -> return $ IL.Variable (transType ty) v' -- apply renaming - where fun = (IL.Function (transType ty) v . arrowArity) <$> varType v -trExpr _ _ (Constructor _ ty c) - = (IL.Constructor (transType ty) c . arrowArity) <$> constrType c + | isQualified v = getTCEnv >>= fun + | otherwise = do + tcEnv <- getTCEnv + case Map.lookup (unqualify v) env of + Nothing -> error $ "unexpected variable" ++ show v --TODO: Replace case by fromJust? + Just v' -> return $ IL.Variable (transType tcEnv ty) v' -- apply renaming + where + fun tcEnv = IL.Function (transType tcEnv ty) v <$> getArity v +trExpr _ _ (Constructor _ ty c) = do + tcEnv <- getTCEnv + IL.Constructor (transType tcEnv ty) c <$> getArity c trExpr vs env (Apply _ e1 e2) = IL.Apply <$> trExpr vs env e1 <*> trExpr vs env e2 -trExpr vs env (Let _ ds e) = do +trExpr vs env (Let _ _ ds e) = do e' <- trExpr vs env' e case ds of [FreeDecl _ vs'] - -> return $ foldr (\ (Var ty v) -> IL.Exist v (transType ty)) e' vs' + -> do tcEnv <- getTCEnv + return $ + foldr (\ (Var ty v) -> IL.Exist v (transType tcEnv ty)) e' vs' [d] | all (`notElem` bv d) (qfv emptyMIdent d) -> flip IL.Let e' <$> trBinding d _ -> flip IL.Letrec e' <$> mapM trBinding ds @@ -294,12 +447,13 @@ trBinding (PatternDecl _ (VariablePattern _ _ v) rhs) = IL.Binding v <$> trRhs vs env' rhs trBinding p = error $ "unexpected binding: " ++ show p -trExpr (v:vs) env (Case _ ct e alts) = do +trExpr (v:vs) env (Case _ _ ct e alts) = do -- the ident v is used for the case expression subject, as this could -- be referenced in the case alternatives by a variable pattern e' <- trExpr vs env e + tcEnv <- getTCEnv let matcher = if ct == Flex then flexMatch else rigidMatch - ty' = transType $ typeOf e + ty' = transType tcEnv $ typeOf e expr <- matcher [(ty', v)] <$> mapM (trAlt (v:vs) env) alts return $ case expr of IL.Case mode (IL.Variable _ v') alts' @@ -309,15 +463,17 @@ -- subject is referenced -> introduce binding for v as subject | v `elem` fv expr -> IL.Let (IL.Binding v e') expr | otherwise -> expr -trExpr vs env (Typed _ e (QualTypeExpr _ _ ty)) = - flip IL.Typed ty' <$> trExpr vs env e - where ty' = transType (toType [] ty) +trExpr vs env (Typed _ e _) = do + tcEnv <- getTCEnv + e' <- trExpr vs env e + return $ IL.Typed e' (transType tcEnv $ typeOf e) trExpr _ _ _ = internalError "CurryToIL.trExpr" trAlt :: [Ident] -> RenameEnv -> Alt Type -> TransM Match trAlt ~(v:vs) env (Alt _ t rhs) = do + tcEnv <- getTCEnv rhs' <- trRhs vs (bindRenameEnv v t env) rhs - return ([trPattern v t], rhs') + return ([trPattern tcEnv v t], rhs') trLiteral :: Literal -> IL.Literal trLiteral (Char c) = IL.Char c @@ -337,18 +493,20 @@ arguments :: NestedTerm -> [NestedTerm] arguments (NestedTerm _ ts) = ts -trPattern :: Ident -> Pattern Type -> NestedTerm -trPattern _ (LiteralPattern _ ty l) - = NestedTerm (IL.LiteralPattern (transType ty) $ trLiteral l) [] -trPattern v (VariablePattern _ ty _) - = NestedTerm (IL.VariablePattern (transType ty) v) [] -trPattern v (ConstructorPattern _ ty c ts) - = NestedTerm (IL.ConstructorPattern (transType ty) c vs') - (zipWith trPattern vs ts) +trPattern :: TCEnv -> Ident -> Pattern Type -> NestedTerm +trPattern tcEnv _ (LiteralPattern _ ty l) + = NestedTerm (IL.LiteralPattern (transType tcEnv ty) $ trLiteral l) [] +trPattern tcEnv v (VariablePattern _ ty _) + = NestedTerm (IL.VariablePattern (transType tcEnv ty) v) [] +trPattern tcEnv v (ConstructorPattern _ ty c ts) + = NestedTerm (IL.ConstructorPattern (transType tcEnv ty) c vs') + (zipWith (trPattern tcEnv) vs ts) where vs = argNames v - vs' = zip (map (transType . typeOf) ts) vs -trPattern v (AsPattern _ _ t) = trPattern v t -trPattern _ _ = internalError "CurryToIL.trPattern" + vs' = zip (map (transType tcEnv . typeOf) ts) vs +trPattern tcEnv v (AsPattern _ _ t) + = trPattern tcEnv v t +trPattern _ _ _ + = internalError "CurryToIL.trPattern" argNames :: Ident -> [Ident] argNames v = [mkIdent (prefix ++ show i) | i <- [1 :: Integer ..] ] diff --git a/src/Transformations/Derive.hs b/src/Transformations/Derive.hs --- a/src/Transformations/Derive.hs +++ b/src/Transformations/Derive.hs @@ -16,6 +16,7 @@ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif +import Control.Monad (replicateM) import qualified Control.Monad.State as S (State, evalState, gets, modify) import Data.List (intercalate, intersperse) import Data.Maybe (fromJust, isJust) @@ -50,8 +51,8 @@ derive :: TCEnv -> ValueEnv -> InstEnv -> OpPrecEnv -> Module PredType -> Module PredType -derive tcEnv vEnv inEnv pEnv (Module spi ps m es is ds) = Module spi ps m es is $ - ds ++ concat (S.evalState (mapM deriveInstances tds) initState) +derive tcEnv vEnv inEnv pEnv (Module spi li ps m es is ds) = Module spi li ps m es is $ + ds ++ concat (S.evalState (deriveAllInstances tds) initState) where tds = filter isTypeDecl ds initState = DVState m tcEnv vEnv inEnv pEnv 1 @@ -80,6 +81,35 @@ type ConstrInfo = (Int, QualIdent, Maybe [Ident], [Type]) +deriveAllInstances :: [Decl PredType] -> DVM [[Decl PredType]] +deriveAllInstances ds = do + derived <- mapM deriveInstances ds + inst <- getInstEnv + mid <- getModuleIdent + let dds = filter (hasDataInstance inst mid) ds + datains <- mapM deriveDataInstance dds + return (datains:derived) + +-- If we ever entered a data instance for this datatype into the instance +-- environment, we can safely derive a data instance +hasDataInstance :: InstEnv -> ModuleIdent -> Decl PredType -> Bool +hasDataInstance inst mid (DataDecl _ tc _ _ _) = + maybe False (\(mid', _, _) -> mid == mid') $ + lookupInstInfo (qDataId, qualifyWith mid tc) inst +hasDataInstance inst mid (NewtypeDecl _ tc _ _ _) = + maybe False (\(mid', _, _) -> mid == mid') $ + lookupInstInfo (qDataId, qualifyWith mid tc) inst +hasDataInstance _ _ _ = + False + +deriveDataInstance :: Decl PredType -> DVM (Decl PredType) +deriveDataInstance (DataDecl p tc tvs _ _) = + head <$> deriveInstances (DataDecl p tc tvs [] [qDataId]) +deriveDataInstance (NewtypeDecl p tc tvs _ _) = + deriveDataInstance $ DataDecl p tc tvs [] [] +deriveDataInstance _ = + internalError "Derive.deriveDataInstance: No DataDel" + -- An instance declaration is created for each type class of a deriving clause. -- Newtype declaration are simply treated as data declarations. @@ -103,7 +133,7 @@ take (length tvs) $ map TypeVariable [0 ..] QualTypeExpr _ cx inst = fromPredType tvs $ PredType ps ty ds <- deriveMethods cls ty cis ps - return $ InstanceDecl NoSpanInfo cx cls inst ds + return $ InstanceDecl NoSpanInfo WhitespaceLayout cx cls inst ds -- Note: The methods and arities of the generated instance declarations have to -- correspond to the methods and arities entered previously into the instance @@ -118,6 +148,7 @@ | cls == qBoundedId = deriveBoundedMethods | cls == qReadId = deriveReadMethods | cls == qShowId = deriveShowMethods + | cls == qDataId = deriveDataMethods | otherwise = internalError $ "Derive.deriveMethods: " ++ show cls -- Binary Operators: @@ -133,7 +164,11 @@ deriveBinOp cls op expr ty cis ps = do pty <- getInstMethodType ps cls ty op eqs <- mapM (deriveBinOpEquation op expr ty) $ sequence [cis, cis] - return $ FunctionDecl NoSpanInfo pty op eqs + return $ FunctionDecl NoSpanInfo pty op $ + if null eqs + then [mkEquation NoSpanInfo op [] $ + preludeFailed $ instType $ unpredType pty] + else eqs deriveBinOpEquation :: Ident -> BinOpExpr -> Type -> [ConstrInfo] -> DVM (Equation PredType) @@ -160,6 +195,39 @@ else foldl1 prelAnd $ zipWith prelEq es1 es2 | otherwise = prelFalse +-- Data: + +deriveDataMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType] +deriveDataMethods ty cis ps = sequence + [ deriveBinOp qDataId dataEqId dataEqOpExpr ty cis ps + , deriveAValue ty cis ps] + +dataEqOpExpr :: BinOpExpr +dataEqOpExpr i1 es1 i2 es2 + | i1 == i2 = if null es1 then prelTrue + else foldl1 prelAnd $ zipWith prelDataEq es1 es2 + | otherwise = prelFalse + +deriveAValue :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType) +deriveAValue ty cis ps = do + pty <- getInstMethodType ps qDataId ty aValueId + return $ FunctionDecl NoSpanInfo pty aValueId $ + if null cis + then [mkEquation NoSpanInfo aValueId [] $ preludeFailed $ instType ty] + else map (aValueEquation ty) cis + +aValueEquation :: Type -> ConstrInfo -> Equation PredType +aValueEquation ty (arity, cns, _, tys) + | arity >= 0 = mkEquation NoSpanInfo aValueId [] $ predType <$> + foldl (Apply NoSpanInfo) + (Constructor NoSpanInfo constrType cns) + (map mkAValue tys') + | otherwise = internalError "Derive.aValueEquation: negative arity" + where + constrType = foldr TypeArrow (instType ty) tys' + mkAValue argTy = Variable NoSpanInfo argTy qAValueId + tys' = map instType tys + -- Ordering: deriveOrdMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType] @@ -194,11 +262,13 @@ -> DVM (Decl PredType) deriveSuccOrPred f ty cis1 cis2 ps = do pty <- getInstMethodType ps qEnumId ty f - FunctionDecl NoSpanInfo pty f <$> if null eqs - then do - v <- freshArgument $ instType ty - return [failedEquation f ty v] - else return eqs + FunctionDecl NoSpanInfo pty f <$> + if null eqs + then do + v <- freshArgument $ instType ty + return [mkEquation NoSpanInfo f [uncurry (VariablePattern NoSpanInfo) v] $ + preludeFailed $ instType ty] + else return eqs where eqs = zipWith (succOrPredEquation f ty) cis1 cis2 succOrPredEquation :: Ident -> Type -> ConstrInfo -> ConstrInfo @@ -208,11 +278,6 @@ Constructor NoSpanInfo pty c2 where pty = predType $ instType ty -failedEquation :: Ident -> Type -> (PredType, Ident) -> Equation PredType -failedEquation f ty v = - mkEquation NoSpanInfo f [uncurry (VariablePattern NoSpanInfo) v] $ - preludeFailed $ instType ty - deriveToEnum :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType) deriveToEnum ty cis ps = do pty <- getInstMethodType ps qEnumId ty toEnumId @@ -253,7 +318,7 @@ -> DVM (Decl PredType) deriveEnumFromThen ty (_, c1, _, _) (_, c2, _, _) ps = do pty <- getInstMethodType ps qEnumId ty enumFromId - vs <- mapM (freshArgument . instType) $ replicate 2 ty + vs <- replicateM 2 ((freshArgument . instType) ty) let [v1, v2] = vs return $ funDecl NoSpanInfo pty enumFromThenId (map (uncurry (VariablePattern NoSpanInfo)) vs) $ @@ -262,7 +327,7 @@ enumFromThenExpr :: (PredType, Ident) -> (PredType, Ident) -> QualIdent -> QualIdent -> Expression PredType enumFromThenExpr v1 v2 c1 c2 = - prelEnumFromThenTo (uncurry mkVar v1) (uncurry mkVar v2) $ boundedExpr + prelEnumFromThenTo (uncurry mkVar v1) (uncurry mkVar v2) boundedExpr where boundedExpr = IfThenElse NoSpanInfo (prelLeq (prelFromEnum $ uncurry mkVar v1) @@ -299,7 +364,7 @@ deriveReadsPrec :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType) deriveReadsPrec ty cis ps = do - pty <- getInstMethodType ps qReadId ty $ readsPrecId + pty <- getInstMethodType ps qReadId ty readsPrecId d <- freshArgument intType r <- freshArgument stringType let pats = map (uncurry (VariablePattern NoSpanInfo)) [d, r] @@ -310,7 +375,7 @@ -> Expression PredType -> DVM (Expression PredType) deriveReadsPrecExpr ty cis d r = do es <- mapM (deriveReadsPrecReadParenExpr ty d) cis - return $ foldr1 prelAppend $ map (flip (Apply NoSpanInfo) r) $ es + return $ foldr1 prelAppend $ map (flip (Apply NoSpanInfo) r) es deriveReadsPrecReadParenExpr :: Type -> Expression PredType -> ConstrInfo -> DVM (Expression PredType) @@ -334,7 +399,7 @@ deriveReadsPrecLambdaExpr ty (_, c, ls, tys) p = do r <- freshArgument stringType (stmts, vs, s) <- deriveReadsPrecStmts (unqualify c) (p + 1) r ls tys - let pty = predType $ foldr TypeArrow (instType ty) $ map instType tys + let pty = predType $ foldr (TypeArrow . instType) (instType ty) tys e = Tuple NoSpanInfo [ apply (Constructor NoSpanInfo pty c) $ map (uncurry mkVar) vs , uncurry mkVar s @@ -401,7 +466,7 @@ deriveReadsPrecLexStmt :: String -> (PredType, Ident) -> DVM ((PredType, Ident), Statement PredType) deriveReadsPrecLexStmt str r = do - s <- freshArgument $ stringType + s <- freshArgument stringType let pat = TuplePattern NoSpanInfo [ LiteralPattern NoSpanInfo predStringType $ String str , uncurry (VariablePattern NoSpanInfo) s @@ -427,7 +492,7 @@ deriveShowsPrec :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType) deriveShowsPrec ty cis ps = do - pty <- getInstMethodType ps qShowId ty $ showsPrecId + pty <- getInstMethodType ps qShowId ty showsPrecId eqs <- mapM (deriveShowsPrecEquation ty) cis return $ FunctionDecl NoSpanInfo pty showsPrecId eqs @@ -541,7 +606,7 @@ instMethodType vEnv ps cls ty f = PredType (ps `Set.union` ps'') ty'' where PredType ps' ty' = case qualLookupValue (qualifyLike cls f) vEnv of [Value _ _ _ (ForAll _ pty)] -> pty - _ -> internalError $ "Derive.instMethodType" + _ -> internalError "Derive.instMethodType" PredType ps'' ty'' = instanceType ty $ PredType (Set.deleteMin ps') ty' -- ----------------------------------------------------------------------------- @@ -577,6 +642,12 @@ where ty = typeOf e1 pty = predType $ foldr1 TypeArrow [ty, ty, boolType] +prelDataEq :: Expression PredType -> Expression PredType -> Expression PredType +prelDataEq e1 e2 = foldl1 (Apply NoSpanInfo) + [Variable NoSpanInfo pty qDataEqId, e1, e2] + where ty = typeOf e1 + pty = predType $ foldr1 TypeArrow [ty, ty, boolType] + prelLeq :: Expression PredType -> Expression PredType -> Expression PredType prelLeq e1 e2 = foldl1 (Apply NoSpanInfo) [Variable NoSpanInfo pty qLeqOpId, e1, e2] @@ -626,7 +697,7 @@ ] preludeLex :: Expression PredType -> Expression PredType -preludeLex e = Apply NoSpanInfo (Variable NoSpanInfo pty qLexId) e +preludeLex = Apply NoSpanInfo (Variable NoSpanInfo pty qLexId) where pty = predType $ TypeArrow stringType $ listType $ tupleType [stringType, stringType] diff --git a/src/Transformations/Desugar.hs b/src/Transformations/Desugar.hs --- a/src/Transformations/Desugar.hs +++ b/src/Transformations/Desugar.hs @@ -96,8 +96,8 @@ desugar :: [KnownExtension] -> ValueEnv -> TCEnv -> Module PredType -> (Module PredType, ValueEnv) -desugar xs vEnv tcEnv (Module spi ps m es is ds) - = (Module spi ps m es is ds', valueEnv s') +desugar xs vEnv tcEnv (Module spi li ps m es is ds) + = (Module spi li ps m es is ds', valueEnv s') where (ds', s') = S.runState (desugarModuleDecls ds) (DesugarState m xs tcEnv vEnv 1) @@ -156,23 +156,54 @@ desugarModuleDecls :: [Decl PredType] -> DsM [Decl PredType] desugarModuleDecls ds = do - ds' <- concatMapM dsRecordDecl ds - ds'' <- mapM dsClassAndInstanceDecl ds' - ds''' <- dsDeclGroup ds'' - return $ filter (not . liftM2 (||) isValueDecl isTypeSig) ds'' ++ ds''' + ds' <- concatMapM dsRecordDecl ds + ds'' <- concatMapM dsTypeDecl ds' + ds''' <- mapM dsClassAndInstanceDecl ds'' + ds'''' <- dsDeclGroup ds''' + return $ filter (not . liftM2 (||) isValueDecl isTypeSig) ds''' ++ ds'''' -- ----------------------------------------------------------------------------- +-- Desugaring of type declarations +-- ----------------------------------------------------------------------------- + +dsTypeDecl :: Decl PredType -> DsM [Decl PredType] +dsTypeDecl (DataDecl si tc tvs cs clss) = do + cs' <- mapM dsConstrDecl cs + return $ [DataDecl si tc tvs cs' clss] +dsTypeDecl (NewtypeDecl si tc tvs nc clss) = do + nc' <- dsNewConstrDecl nc + return $ [NewtypeDecl si tc tvs nc' clss] +dsTypeDecl (TypeDecl _ _ _ _) = return [] +dsTypeDecl d = return [d] + +dsConstrDecl :: ConstrDecl -> DsM ConstrDecl +dsConstrDecl (ConstrDecl si c tys) = ConstrDecl si c <$> mapM dsTypeExpr tys +dsConstrDecl (ConOpDecl si ty1 op ty2) = + ConstrDecl si op <$> mapM dsTypeExpr [ty1, ty2] +dsConstrDecl cd = internalError $ "Desugar.dsConstrDecl: " ++ show cd + +dsNewConstrDecl :: NewConstrDecl -> DsM NewConstrDecl +dsNewConstrDecl (NewConstrDecl si c ty) = NewConstrDecl si c <$> dsTypeExpr ty +dsNewConstrDecl nc = internalError $ "Desugar.dsNewConstrDecl: " ++ show nc + +-- ----------------------------------------------------------------------------- -- Desugaring of class and instance declarations -- ----------------------------------------------------------------------------- dsClassAndInstanceDecl :: Decl PredType -> DsM (Decl PredType) -dsClassAndInstanceDecl (ClassDecl p cx cls tv ds) = - ClassDecl p cx cls tv . (tds ++) <$> dsDeclGroup vds +dsClassAndInstanceDecl (ClassDecl p li cx cls tv ds) = do + tds' <- mapM dsTypeSig tds + vds' <- dsDeclGroup vds + return $ ClassDecl p li cx cls tv $ tds' ++ vds' where (tds, vds) = partition isTypeSig ds -dsClassAndInstanceDecl (InstanceDecl p cx cls ty ds) = - InstanceDecl p cx cls ty <$> dsDeclGroup ds +dsClassAndInstanceDecl (InstanceDecl p li cx cls ty ds) = + InstanceDecl p li cx cls ty <$> dsDeclGroup ds dsClassAndInstanceDecl d = return d +dsTypeSig :: Decl PredType -> DsM (Decl PredType) +dsTypeSig (TypeSig s fs qty) = TypeSig s fs <$> dsQualTypeExpr qty +dsTypeSig d = internalError $ "Desugar.dsTypeSig: " ++ show d + -- ----------------------------------------------------------------------------- -- Desugaring of type declarations: records -- ----------------------------------------------------------------------------- @@ -306,9 +337,9 @@ expandRhs :: Expression PredType -> (Expression PredType -> Expression PredType) -> Rhs PredType -> DsM (Expression PredType) -expandRhs _ f (SimpleRhs _ e ds) = return $ Let NoSpanInfo ds (f e) -expandRhs e0 f (GuardedRhs _ es ds) = (Let NoSpanInfo ds . f) - <$> expandGuards e0 es +expandRhs _ f (SimpleRhs _ _ e ds) = return $ mkLet ds (f e) +expandRhs e0 f (GuardedRhs _ _ es ds) = mkLet ds . f + <$> expandGuards e0 es expandGuards :: Expression PredType -> [CondExpr PredType] -> DsM (Expression PredType) @@ -325,8 +356,8 @@ -- Add additional declarations to a right-hand side addDecls :: [Decl PredType] -> Rhs PredType -> Rhs PredType -addDecls ds (SimpleRhs p e ds') = SimpleRhs p e (ds ++ ds') -addDecls ds (GuardedRhs spi es ds') = GuardedRhs spi es (ds ++ ds') +addDecls ds (SimpleRhs p li e ds') = SimpleRhs p li e (ds ++ ds') +addDecls ds (GuardedRhs spi li es ds') = GuardedRhs spi li es (ds ++ ds') -- ----------------------------------------------------------------------------- -- Desugaring of non-linear patterns @@ -673,7 +704,7 @@ dsExpr p (applyConstr pty c tys es) dsExpr p (RecordUpdate _ e fs) = do alts <- constructors tc >>= concatMapM updateAlt - dsExpr p $ Case NoSpanInfo Flex e (map (uncurry (caseAlt p)) alts) + dsExpr p $ mkCase Flex e (map (uncurry (caseAlt p)) alts) where ty = typeOf e pty = predType ty tc = rootOfType (arrowBase ty) @@ -733,19 +764,19 @@ where TypeArrow ty1 (TypeArrow ty2 ty3) = typeOf (infixOp op) dsExpr p expr@(Lambda _ ts e) = do (pty, f) <- freshVar "_#lambda" expr - dsExpr p $ Let NoSpanInfo [funDecl p pty f ts e] $ mkVar pty f -dsExpr p (Let _ ds e) = do + dsExpr p $ mkLet [funDecl p pty f ts e] $ mkVar pty f +dsExpr p (Let _ _ ds e) = do ds' <- dsDeclGroup ds e' <- dsExpr p e - return (if null ds' then e' else Let NoSpanInfo ds' e') -dsExpr p (Do _ sts e) = dsDo sts e >>= dsExpr p + return $ mkLet ds' e' +dsExpr p (Do _ _ sts e) = dsDo sts e >>= dsExpr p dsExpr p (IfThenElse _ e1 e2 e3) = do e1' <- dsExpr p e1 e2' <- dsExpr p e2 e3' <- dsExpr p e3 - return $ Case NoSpanInfo Rigid e1' + return $ mkCase Rigid e1' [caseAlt p truePat e2', caseAlt p falsePat e3'] -dsExpr p (Case _ ct e alts) = dsCase p ct e alts +dsExpr p (Case _ _ ct e alts) = dsCase p ct e alts -- We ignore the context in the type signature of a typed expression, since -- there should be no possibility to provide an non-empty context without @@ -760,7 +791,8 @@ dsTypeExpr ty = do m <- getModuleIdent tcEnv <- getTyConsEnv - return $ fromType (typeVariables ty) (expandType m tcEnv (toType [] ty)) + let tvs = typeVariables ty + return $ fromType tvs $ expandType m tcEnv $ toType tvs ty -- ----------------------------------------------------------------------------- -- Desugaring of case expressions @@ -784,12 +816,12 @@ v <- freshVar "_#case" e alts' <- mapM dsAltLhs alts alts'' <- mapM (expandAlt v ct) (init (tails alts')) >>= mapM dsAltRhs - return (mkCase m v e' alts'') + return (mkMyCase m v e' alts'') where - mkCase m (pty, v) e' bs - | v `elem` qfv m bs = Let NoSpanInfo [varDecl p pty v e'] - (Case NoSpanInfo ct (mkVar pty v) bs) - | otherwise = Case NoSpanInfo ct e' bs + mkMyCase m (pty, v) e' bs + | v `elem` qfv m bs = mkLet [varDecl p pty v e'] + (mkCase ct (mkVar pty v) bs) + | otherwise = mkCase ct e' bs dsAltLhs :: Alt PredType -> DsM (Alt PredType) dsAltLhs (Alt p t rhs) = do @@ -805,7 +837,7 @@ expandAlt v ct (Alt p t rhs : alts) = caseAlt p t <$> expandRhs e0 id rhs where e0 | ct == Flex || null compAlts = prelFailed (typeOf rhs) - | otherwise = Case NoSpanInfo ct (uncurry mkVar v) compAlts + | otherwise = mkCase ct (uncurry mkVar v) compAlts compAlts = filter (isCompatible t . altPattern) alts altPattern (Alt _ t1 _) = t1 @@ -839,18 +871,56 @@ return $ apply (prelBind_ (typeOf e1) (typeOf e')) [e1, e'] dsStmt (StmtBind _ t e1) e' = do v <- freshVar "_#var" t - let func = Lambda NoSpanInfo [uncurry (VariablePattern NoSpanInfo) v] $ - Case NoSpanInfo Rigid (uncurry mkVar v) - [ caseAlt NoSpanInfo t e' - , caseAlt NoSpanInfo (uncurry (VariablePattern NoSpanInfo) v) - (failedPatternMatch $ typeOf e') - ] + failable <- checkFailableBind t + let func = mkLambda [uncurry (VariablePattern NoSpanInfo) v] $ + mkCase Rigid (uncurry mkVar v) $ + caseAlt NoSpanInfo t e' : + if failable + then [caseAlt NoSpanInfo + (uncurry (VariablePattern NoSpanInfo) v) + (failedPatternMatch $ typeOf e')] + else [] return $ apply (prelBind (typeOf e1) (typeOf t) (typeOf e')) [e1, func] where failedPatternMatch ty = apply (prelFail ty) [Literal NoSpanInfo predStringType $ String "Pattern match failed!"] -dsStmt (StmtDecl _ ds) e' = return $ Let NoSpanInfo ds e' +dsStmt (StmtDecl _ _ ds) e' = return $ mkLet ds e' +checkFailableBind :: Pattern a -> DsM Bool +checkFailableBind (ConstructorPattern _ _ idt ps ) = do + tcEnv <- getTyConsEnv + case qualLookupTypeInfo idt tcEnv of + [RenamingType _ _ _ ] -> or <$> mapM checkFailableBind ps -- or [] == False + [DataType _ _ cs] + | length cs == 1 -> or <$> mapM checkFailableBind ps + | otherwise -> return True + _ -> return True +checkFailableBind (InfixPattern _ _ p1 idt p2) = do + tcEnv <- getTyConsEnv + case qualLookupTypeInfo idt tcEnv of + [RenamingType _ _ _ ] -> (||) <$> checkFailableBind p1 + <*> checkFailableBind p2 + [DataType _ _ cs] + | length cs == 1 -> (||) <$> checkFailableBind p1 + <*> checkFailableBind p2 + | otherwise -> return True + _ -> return True +checkFailableBind (RecordPattern _ _ idt fs ) = do + tcEnv <- getTyConsEnv + case qualLookupTypeInfo idt tcEnv of + [RenamingType _ _ _ ] -> or <$> mapM (checkFailableBind . fieldContent) fs + [DataType _ _ cs] + | length cs == 1 -> or <$> mapM (checkFailableBind . fieldContent) fs + | otherwise -> return True + _ -> return True + where fieldContent (Field _ _ c) = c +checkFailableBind (TuplePattern _ ps ) = + or <$> mapM checkFailableBind ps +checkFailableBind (AsPattern _ _ p ) = checkFailableBind p +checkFailableBind (ParenPattern _ p ) = checkFailableBind p +checkFailableBind (LazyPattern _ _ ) = return False +checkFailableBind (VariablePattern _ _ _ ) = return False +checkFailableBind _ = return True -- ----------------------------------------------------------------------------- -- Desugaring of List Comprehensions -- ----------------------------------------------------------------------------- @@ -891,7 +961,7 @@ -> DsM (Expression PredType) dsQual p (StmtExpr _ b) e = dsExpr p (IfThenElse NoSpanInfo b e (List NoSpanInfo (predType $ typeOf e) [])) -dsQual p (StmtDecl _ ds) e = dsExpr p (Let NoSpanInfo ds e) +dsQual p (StmtDecl _ _ ds) e = dsExpr p (mkLet ds e) dsQual p (StmtBind _ t l) e | isVariablePattern t = dsExpr p (qualExpr t e l) | otherwise = do @@ -901,13 +971,13 @@ [foldFunct v l' e, List NoSpanInfo (predType $ typeOf e) [], l]) where qualExpr v (ListCompr NoSpanInfo e1 []) l1 - = apply (prelMap (typeOf v) (typeOf e1)) [Lambda NoSpanInfo [v] e1, l1] + = apply (prelMap (typeOf v) (typeOf e1)) [mkLambda [v] e1, l1] qualExpr v e1 l1 = apply (prelConcatMap (typeOf v) (elemType $ typeOf e1)) - [Lambda NoSpanInfo [v] e1, l1] + [mkLambda [v] e1, l1] foldFunct v l1 e1 - = Lambda NoSpanInfo (map (uncurry (VariablePattern NoSpanInfo)) [v, l1]) - (Case NoSpanInfo Rigid (uncurry mkVar v) + = mkLambda (map (uncurry (VariablePattern NoSpanInfo)) [v, l1]) + (mkCase Rigid (uncurry mkVar v) [ caseAlt p t (append e1 (uncurry mkVar l1)) , caseAlt p (uncurry (VariablePattern NoSpanInfo) v) (uncurry mkVar l1)]) diff --git a/src/Transformations/Dictionary.hs b/src/Transformations/Dictionary.hs --- a/src/Transformations/Dictionary.hs +++ b/src/Transformations/Dictionary.hs @@ -62,7 +62,6 @@ , classEnv :: ClassEnv , instEnv :: InstEnv , opPrecEnv :: OpPrecEnv - , augmentEnv :: AugmentEnv -- for augmenting nullary class methods , dictEnv :: DictEnv -- for dictionary insertion , specEnv :: SpecEnv -- for dictionary specialization , nextId :: Integer @@ -70,15 +69,15 @@ type DTM = S.State DTState -insertDicts :: InterfaceEnv -> TCEnv -> ValueEnv -> ClassEnv -> InstEnv - -> OpPrecEnv -> Module PredType +insertDicts :: Bool -> InterfaceEnv -> TCEnv -> ValueEnv -> ClassEnv + -> InstEnv -> OpPrecEnv -> Module PredType -> (Module Type, InterfaceEnv, TCEnv, ValueEnv, OpPrecEnv) -insertDicts intfEnv tcEnv vEnv clsEnv inEnv pEnv mdl@(Module _ _ m _ _ _) = +insertDicts inlDi intfEnv tcEnv vEnv clsEnv inEnv pEnv mdl@(Module _ _ _ m _ _ _) = (mdl', intfEnv', tcEnv', vEnv', pEnv') where initState = - DTState m tcEnv vEnv clsEnv inEnv pEnv emptyAugEnv emptyDictEnv emptySpEnv 1 + DTState m tcEnv vEnv clsEnv inEnv pEnv emptyDictEnv emptySpEnv 1 (mdl', tcEnv', vEnv', pEnv') = - runDTM (augment mdl >>= dictTrans >>= specialize >>= cleanup) initState + runDTM (dictTrans mdl >>= (if inlDi then specialize else return) >>= cleanup) initState intfEnv' = dictTransInterfaces vEnv' clsEnv intfEnv runDTM :: DTM a -> DTState -> (a, TCEnv, ValueEnv, OpPrecEnv) @@ -122,12 +121,6 @@ modifyPrecEnv :: (OpPrecEnv -> OpPrecEnv) -> DTM () modifyPrecEnv f = S.modify $ \s -> s { opPrecEnv = f $ opPrecEnv s } -getAugEnv :: DTM AugmentEnv -getAugEnv = S.gets augmentEnv - -setAugEnv :: AugmentEnv -> DTM () -setAugEnv augEnv = S.modify $ \s -> s { augmentEnv = augEnv } - getDictEnv :: DTM DictEnv getDictEnv = S.gets dictEnv @@ -154,167 +147,6 @@ return nid -- ----------------------------------------------------------------------------- --- Augmenting nullary class methods --- ----------------------------------------------------------------------------- - --- To prevent unwanted sharing of non-determinism for nullary class methods --- we augment them with an additional unit argument. - -type AugmentEnv = [QualIdent] - -emptyAugEnv :: AugmentEnv -emptyAugEnv = [] - -initAugEnv :: ValueEnv -> AugmentEnv -initAugEnv = foldr (bindValue . snd) emptyAugEnv . allBindings - where bindValue (Value f True _ (ForAll _ (PredType _ ty))) - | arrowArity ty == 0 = (f :) - bindValue _ = id - -isAugmented :: AugmentEnv -> QualIdent -> Bool -isAugmented = flip elem - -augmentValues :: ValueEnv -> ValueEnv -augmentValues = fmap augmentValueInfo - -augmentValueInfo :: ValueInfo -> ValueInfo -augmentValueInfo (Value f True a (ForAll n (PredType ps ty))) - | arrowArity ty == 0 = Value f True a $ ForAll n $ PredType ps ty' - where ty' = augmentType ty -augmentValueInfo vi = vi - -augmentTypes :: TCEnv -> TCEnv -augmentTypes = fmap augmentTypeInfo - -augmentTypeInfo :: TypeInfo -> TypeInfo -augmentTypeInfo (TypeClass cls k ms) = - TypeClass cls k $ map augmentClassMethod ms -augmentTypeInfo ti = ti - -augmentClassMethod :: ClassMethod -> ClassMethod -augmentClassMethod mthd@(ClassMethod f a (PredType ps ty)) - | arrowArity ty == 0 = - ClassMethod f (Just $ fromMaybe 0 a + 1) $ PredType ps $ augmentType ty - | otherwise = mthd - -augmentInstances :: AugmentEnv -> InstEnv -> InstEnv -augmentInstances = Map.mapWithKey . augmentInstInfo - -augmentInstInfo :: AugmentEnv -> InstIdent -> InstInfo -> InstInfo -augmentInstInfo augEnv (cls, _) (m, ps, is) = - (m, ps, map (augmentInstImpl augEnv cls) is) - -augmentInstImpl :: AugmentEnv -> QualIdent -> (Ident, Int) -> (Ident, Int) -augmentInstImpl augEnv cls (f, a) - | isAugmented augEnv (qualifyLike cls f) = (f, a + 1) - | otherwise = (f, a) - -class Augment a where - augment :: a PredType -> DTM (a PredType) - -instance Augment Module where - augment (Module spi ps m es is ds) = do - augEnv <- initAugEnv <$> getValueEnv - setAugEnv augEnv - modifyValueEnv $ augmentValues - modifyTyConsEnv $ augmentTypes - modifyInstEnv $ augmentInstances augEnv - Module spi ps m es is <$> mapM (augmentDecl Nothing) ds - --- The first parameter of the functions 'augmentDecl', 'augmentEquation' and --- 'augmentLhs' determines whether we have to unrename the function identifiers --- before checking if the function has to augmented or not. Furthermore, it --- specifies the module unqualified identifiers have to be qualified with. --- The unrenaming is necessary for both class and instance declarations as all --- identifiers within these have been renamed during the syntax check, while the --- qualifying is needed for function declarations within instance declarations --- as the implemented class methods can originate from another module. If not --- qualified properly, the lookup in the augmentation environment would fail. - --- Since type signatures remain only in class declarations due to desugaring, --- we can always perform the unrenaming and it is safe to assume that all other --- functions mentioned in a type signature have to be augmented as well if the --- first one is affected. - -augmentDecl :: Maybe ModuleIdent -> Decl PredType -> DTM (Decl PredType) -augmentDecl _ d@(TypeSig p fs qty) = do - m <- getModuleIdent - augEnv <- getAugEnv - return $ if isAugmented augEnv (qualifyWith m $ unRenameIdent $ head fs) - then TypeSig p fs $ augmentQualTypeExpr qty - else d -augmentDecl mm (FunctionDecl p pty f eqs) = do - eqs' <- mapM (augmentEquation mm) eqs - m <- maybe getModuleIdent return mm - augEnv <- getAugEnv - if isAugmented augEnv (qualifyWith m $ unRenameIdentIf (isJust mm) f) - then return $ FunctionDecl p (augmentPredType pty) f eqs' - else return $ FunctionDecl p pty f eqs' -augmentDecl _ (PatternDecl p t rhs) = PatternDecl p t <$> augment rhs -augmentDecl _ (ClassDecl p cx cls tv ds) = do - m <- getModuleIdent - ClassDecl p cx cls tv <$> mapM (augmentDecl $ Just m) ds -augmentDecl _ (InstanceDecl p cx cls ty ds) = - InstanceDecl p cx cls ty <$> mapM (augmentDecl $ qidModule cls) ds -augmentDecl _ d = return d - -augmentEquation :: Maybe ModuleIdent -> Equation PredType - -> DTM (Equation PredType) -augmentEquation mm (Equation p lhs rhs) = - Equation p <$> augmentLhs mm lhs <*> augment rhs - -augmentLhs :: Maybe ModuleIdent -> Lhs PredType -> DTM (Lhs PredType) -augmentLhs mm lhs@(FunLhs spi f ts) = do - m <- maybe getModuleIdent return mm - augEnv <- getAugEnv - if isAugmented augEnv (qualifyWith m $ unRenameIdentIf (isJust mm) f) - then return $ FunLhs spi f - $ ConstructorPattern NoSpanInfo predUnitType qUnitId [] : ts - else return lhs -augmentLhs _ lhs = - internalError $ "Dictionary.augmentLhs" ++ show lhs - -instance Augment Rhs where - augment (SimpleRhs p e []) = simpleRhs p <$> augment e - augment rhs = - internalError $ "Dictionary.augment: " ++ show rhs - -instance Augment Expression where - augment l@(Literal _ _ _) = return l - augment v@(Variable _ pty v') = do - augEnv <- getAugEnv - return $ if isAugmented augEnv v' - then apply (Variable NoSpanInfo (augmentPredType pty) v') - [Constructor NoSpanInfo predUnitType qUnitId] - else v - augment c@(Constructor _ _ _) = return c - augment (Typed spi e qty) = flip (Typed spi) qty <$> augment e - augment (Apply spi e1 e2) = Apply spi <$> augment e1 <*> augment e2 - augment (Lambda spi ts e) = Lambda spi ts <$> augment e - augment (Let spi ds e) = - Let spi <$> mapM (augmentDecl Nothing) ds <*> augment e - augment (Case spi ct e as) = - Case spi ct <$> augment e <*> mapM augment as - augment e = - internalError $ "Dictionary.augment: " ++ show e - -instance Augment Alt where - augment (Alt p t rhs) = Alt p t <$> augment rhs - -augmentPredType :: PredType -> PredType -augmentPredType (PredType ps ty) = PredType ps $ augmentType ty - -augmentType :: Type -> Type -augmentType = TypeArrow unitType - -augmentQualTypeExpr :: QualTypeExpr -> QualTypeExpr -augmentQualTypeExpr (QualTypeExpr spi cx ty) = - QualTypeExpr spi cx $ augmentTypeExpr ty - -augmentTypeExpr :: TypeExpr -> TypeExpr -augmentTypeExpr = ArrowType NoSpanInfo $ ConstructorType NoSpanInfo qUnitId - --- ----------------------------------------------------------------------------- -- Lifting class and instance declarations -- ----------------------------------------------------------------------------- @@ -324,10 +156,10 @@ liftDecls :: Decl PredType -> DTM [Decl PredType] liftDecls (DefaultDecl _ _) = return [] -liftDecls (ClassDecl _ _ cls tv ds) = do +liftDecls (ClassDecl _ _ _ cls tv ds) = do m <- getModuleIdent liftClassDecls (qualifyWith m cls) tv ds -liftDecls (InstanceDecl _ cx cls ty ds) = do +liftDecls (InstanceDecl _ _ cx cls ty ds) = do clsEnv <- getClassEnv let PredType ps ty' = toPredType [] $ QualTypeExpr NoSpanInfo cx ty ps' = minPredSet clsEnv ps @@ -390,7 +222,7 @@ createInstDictDecl :: PredSet -> QualIdent -> Type -> DTM (Decl PredType) createInstDictDecl ps cls ty = do pty <- PredType ps . arrowBase <$> getInstDictConstrType cls ty - funDecl NoSpanInfo pty (instFunId cls ty) [] <$> createInstDictExpr cls ty + funDecl NoSpanInfo pty (instFunId cls ty) [ConstructorPattern NoSpanInfo predUnitType qUnitId []] <$> createInstDictExpr cls ty createInstDictExpr :: QualIdent -> Type -> DTM (Expression PredType) createInstDictExpr cls ty = do @@ -414,13 +246,7 @@ defaultClassMethodDecl :: QualIdent -> Ident -> DTM (Decl PredType) defaultClassMethodDecl cls f = do pty@(PredType _ ty) <- getClassMethodType cls f - augEnv <- getAugEnv - let augmented = isAugmented augEnv (qualifyLike cls f) - pats = if augmented - then [ConstructorPattern NoSpanInfo predUnitType qUnitId []] - else [] - ty' = if augmented then arrowBase ty else ty - return $ funDecl NoSpanInfo pty f pats $ preludeError (instType ty') $ + return $ funDecl NoSpanInfo pty f [] $ preludeError (instType ty) $ "No instance or default method for class operation " ++ escName f getClassMethodType :: QualIdent -> Ident -> DTM PredType @@ -482,7 +308,7 @@ -- class dictionary from the provided class dictionary. createStubs :: Decl PredType -> DTM [Decl Type] -createStubs (ClassDecl _ _ cls _ _) = do +createStubs (ClassDecl _ _ _ cls _ _) = do m <- getModuleIdent vEnv <- getValueEnv clsEnv <- getClassEnv @@ -498,52 +324,42 @@ splitAt (length sclss) $ map (TypeArrow dictTy) superDictAndMethodTys superDictVs <- mapM (freshVar "_#super" . instType) superDictTys methodVs <- mapM (freshVar "_#meth" . instType) methodTys - methodDictTyss <- zipWithM (computeMethodDictTypes ocls) fs methodTys - methodDictVss <- mapM (mapM $ freshVar "_#dict" . instType) methodDictTyss let patternVs = superDictVs ++ methodVs pattern = createDictPattern (instType dictTy) ocls patternVs superStubs = zipWith3 (createSuperDictStubDecl pattern ocls) superStubTys sclss superDictVs - methodStubs = zipWith4 (createMethodStubDecl pattern) - methodStubTys fs methodVs methodDictVss + methodStubs = zipWith3 (createMethodStubDecl pattern) + methodStubTys fs methodVs return $ superStubs ++ methodStubs createStubs _ = return [] --- Computes the additional dictionary arguments of a transformed method type --- which correspond to the constraints of the original class method's type. - -computeMethodDictTypes :: QualIdent -> Ident -> Type -> DTM [Type] -computeMethodDictTypes cls f ty = do - PredType _ ty' <- getClassMethodType cls f - return $ take (length tys - arrowArity ty') tys - where tys = arrowArgs ty - -createDictPattern :: a -> QualIdent -> [(a, Ident)] -> Pattern a +createDictPattern :: Type -> QualIdent -> [(Type, Ident)] -> Pattern Type createDictPattern a cls = constrPattern a (qDictConstrId cls) -createSuperDictStubDecl :: Pattern a -> QualIdent -> a -> QualIdent - -> (a, Ident) -> Decl a +createSuperDictStubDecl :: Pattern Type -> QualIdent -> Type -> QualIdent + -> (Type, Ident) -> Decl Type createSuperDictStubDecl t cls a super v = - createStubDecl t a (superDictStubId cls super) v [] + createStubDecl t a (superDictStubId cls super) v -createMethodStubDecl :: Pattern a -> a -> Ident -> (a, Ident) -> [(a, Ident)] - -> Decl a +createMethodStubDecl :: Pattern Type -> Type -> Ident -> (Type, Ident) -> Decl Type createMethodStubDecl = createStubDecl -createStubDecl :: Pattern a -> a -> Ident -> (a, Ident) -> [(a, Ident)] - -> Decl a -createStubDecl t a f v us = - FunctionDecl NoSpanInfo a f [createStubEquation t f v us] +createStubDecl :: Pattern Type -> Type -> Ident -> (Type, Ident) -> Decl Type +createStubDecl t a f v = + FunctionDecl NoSpanInfo a f [createStubEquation t f v] -createStubEquation :: Pattern a -> Ident -> (a, Ident) -> [(a, Ident)] - -> Equation a -createStubEquation t f v us = - mkEquation NoSpanInfo f (t : map (uncurry (VariablePattern NoSpanInfo)) us) $ - apply (uncurry mkVar v) (map (uncurry mkVar) us) +createStubEquation :: Pattern Type -> Ident -> (Type, Ident) -> Equation Type +createStubEquation t f v = + mkEquation NoSpanInfo f [VariablePattern NoSpanInfo (TypeArrow unitType (typeOf t)) (mkIdent "_#temp")] $ + mkLet [FunctionDecl NoSpanInfo (TypeArrow (typeOf t) (fst v)) (mkIdent "_#lambda") + [mkEquation NoSpanInfo (mkIdent "_#lambda") [t] $ uncurry mkVar v]] + (apply (Variable NoSpanInfo (TypeArrow (typeOf t) (fst v)) (qualify $ mkIdent "_#lambda")) + [apply (Variable NoSpanInfo (TypeArrow unitType (typeOf t)) (qualify $ mkIdent "_#temp")) + [Constructor NoSpanInfo unitType qUnitId]]) superDictStubType :: QualIdent -> QualIdent -> Type -> Type superDictStubType cls super ty = - TypeArrow (dictType $ Pred cls ty) (dictType $ Pred super ty) + TypeArrow (rtDictType $ Pred cls ty) (rtDictType $ Pred super ty) -- ----------------------------------------------------------------------------- -- Entering new bindings into the environments @@ -557,7 +373,7 @@ bindDictType m clsEnv (TypeClass cls k ms) = bindEntity m tc ti where ti = DataType tc (KindArrow k KindStar) [c] tc = qDictTypeId cls - c = DataConstr (dictConstrId cls) (map dictType (Set.toAscList ps) ++ tys) + c = DataConstr (dictConstrId cls) (map rtDictType (Set.toAscList ps) ++ tys) sclss = superClasses cls clsEnv ps = Set.fromList [Pred scls (TypeVariable 0) | scls <- sclss] tys = map (generalizeMethodType . transformMethodPredType . methodType) ms @@ -603,7 +419,7 @@ bindSuperStubs m = flip . foldr . bindSuperStub m bindSuperStub :: ModuleIdent -> QualIdent -> QualIdent -> ValueEnv -> ValueEnv -bindSuperStub m cls scls = bindEntity m f $ Value f False 1 $ polyType ty +bindSuperStub m cls scls = bindEntity m f $ Value f Nothing 1 $ polyType ty where f = qSuperDictStubId cls scls ty = superDictStubType cls scls (TypeVariable 0) @@ -622,7 +438,7 @@ bindInstDict :: ModuleIdent -> QualIdent -> Type -> ModuleIdent -> PredSet -> ValueEnv -> ValueEnv bindInstDict m cls ty m' ps = - bindMethod m (qInstFunId m' cls ty) 0 $ PredType ps $ dictType $ Pred cls ty + bindMethod m (qInstFunId m' cls ty) 1 $ PredType ps $ rtDictType $ Pred cls ty bindInstMethods :: ModuleIdent -> ClassEnv -> QualIdent -> Type -> ModuleIdent -> PredSet -> [(Ident, Int)] -> ValueEnv -> ValueEnv @@ -638,7 +454,7 @@ bindMethod :: ModuleIdent -> QualIdent -> Int -> PredType -> ValueEnv -> ValueEnv -bindMethod m f n pty = bindEntity m f $ Value f False n $ typeScheme pty +bindMethod m f n pty = bindEntity m f $ Value f Nothing n $ typeScheme pty -- The function 'bindEntity' introduces a binding for an entity into a top-level -- environment. Depending on whether the entity is defined in the current module @@ -696,8 +512,8 @@ dictTransValueInfo (NewtypeConstructor c l (ForAll n pty)) = NewtypeConstructor c l (ForAll n (predType (unpredType pty))) dictTransValueInfo (Value f cm a (ForAll n pty)) = - Value f False a' $ ForAll n $ predType ty - where a' = a + if cm then 1 else arrowArity ty - arrowArity (unpredType pty) + Value f Nothing a' $ ForAll n $ predType ty + where a' = a + if isJust cm then 1 else arrowArity ty - arrowArity (unpredType pty) ty = transformPredType pty dictTransValueInfo (Label l cs (ForAll n pty)) = Label l cs $ ForAll n $ predType $ unpredType pty @@ -711,11 +527,11 @@ addExports Nothing _ = internalError "Dictionary.addExports" dictExports :: Decl a -> DTM [Export] -dictExports (ClassDecl _ _ cls _ _) = do +dictExports (ClassDecl _ _ _ cls _ _) = do m <- getModuleIdent clsEnv <- getClassEnv return $ classExports m clsEnv cls -dictExports (InstanceDecl _ _ cls ty _) = do +dictExports (InstanceDecl _ _ _ cls ty _) = do m <- getModuleIdent clsEnv <- getClassEnv return $ instExports m clsEnv cls (toType [] ty) @@ -746,7 +562,7 @@ dictTrans :: a PredType -> DTM (a Type) instance DictTrans Module where - dictTrans (Module spi ps m es is ds) = do + dictTrans (Module spi li ps m es is ds) = do liftedDs <- concatMapM liftDecls ds stubDs <- concatMapM createStubs ds tcEnv <- getTyConsEnv @@ -759,7 +575,7 @@ modifyValueEnv $ dictTransValues modifyTyConsEnv $ dictTransTypes dictEs <- addExports es <$> concatMapM dictExports ds - return $ Module spi ps m dictEs is $ transDs ++ stubDs + return $ Module spi li ps m dictEs is $ transDs ++ stubDs -- We use and transform the type from the type constructor environment for -- transforming a constructor declaration as it contains the reduced and @@ -788,7 +604,7 @@ dictTrans $ FunctionDecl p pty v [Equation p (FunLhs NoSpanInfo v []) rhs] _ -> withLocalDictEnv $ PatternDecl p <$> dictTrans t <*> dictTrans rhs dictTrans d@(FreeDecl _ _) = return $ fmap unpredType d - dictTrans d@(ExternalDecl _ _) = return $ fmap unpredType d + dictTrans d@(ExternalDecl _ _) = return $ fmap transformPredType d dictTrans d = internalError $ "Dictionary.dictTrans: " ++ show d @@ -812,8 +628,8 @@ internalError $ "Dictionary.dictTrans: " ++ show eq instance DictTrans Rhs where - dictTrans (SimpleRhs p e []) = simpleRhs p <$> dictTrans e - dictTrans rhs = + dictTrans (SimpleRhs p _ e []) = simpleRhs p <$> dictTrans e + dictTrans rhs = internalError $ "Dictionary.dictTrans: " ++ show rhs instance DictTrans Pattern where @@ -850,12 +666,12 @@ dictTrans (Lambda _ ts e) = withLocalValueEnv $ withLocalDictEnv $ do ts' <- mapM dictTrans ts modifyValueEnv $ bindPatterns ts' - Lambda NoSpanInfo ts' <$> dictTrans e - dictTrans (Let _ ds e) = withLocalValueEnv $ do + mkLambda ts' <$> dictTrans e + dictTrans (Let _ _ ds e) = withLocalValueEnv $ do modifyValueEnv $ bindDecls ds - Let NoSpanInfo <$> mapM dictTrans ds <*> dictTrans e - dictTrans (Case _ ct e as) = - Case NoSpanInfo ct <$> dictTrans e <*> mapM dictTrans as + mkLet <$> mapM dictTrans ds <*> dictTrans e + dictTrans (Case _ _ ct e as) = + mkCase ct <$> dictTrans e <*> mapM dictTrans as dictTrans e = internalError $ "Dictionary.dictTrans: " ++ show e @@ -875,7 +691,7 @@ addDictArgs :: [Pred] -> [Pattern PredType] -> DTM [Pattern Type] addDictArgs pls ts = do - dictVars <- mapM (freshVar "_#dict" . dictType) pls + dictVars <- mapM (freshVar "_#dict" . rtDictType) pls clsEnv <- getClassEnv modifyDictEnv $ (++) $ dicts clsEnv $ zip pls (map (uncurry mkVar) dictVars) (++) (map (uncurry (VariablePattern NoSpanInfo )) dictVars) @@ -911,7 +727,7 @@ instFunApp m pls p@(Pred cls ty) = apply (Variable NoSpanInfo ty' f) <$> mapM dictArg pls where f = qInstFunId m cls ty - ty' = foldr1 TypeArrow $ map dictType $ pls ++ [p] + ty' = foldr1 TypeArrow $ map rtDictType $ pls ++ [p] instPredList :: Pred -> DTM (ModuleIdent, [Pred]) instPredList (Pred cls ty) = case unapplyType True ty of @@ -954,7 +770,7 @@ predListMatch [] ty = Just ty predListMatch (p:ps) ty = case ty of TypeForall _ ty' -> predListMatch (p : ps) ty' - TypeArrow ty1 ty2 | ty1 == dictType (instPred p) -> predListMatch ps ty2 + TypeArrow ty1 ty2 | ty1 == rtDictType (instPred p) -> predListMatch ps ty2 _ -> Nothing splits :: [a] -> [([a], [a])] @@ -986,11 +802,11 @@ specialize :: a Type -> DTM (a Type) instance Specialize Module where - specialize (Module spi ps m es is ds) = do + specialize (Module spi li ps m es is ds) = do clsEnv <- getClassEnv inEnv <- getInstEnv setSpEnv $ initSpEnv clsEnv inEnv - Module spi ps m es is <$> mapM specialize ds + Module spi li ps m es is <$> mapM specialize ds instance Specialize Decl where specialize (FunctionDecl p ty f eqs) = @@ -1002,8 +818,8 @@ specialize (Equation p lhs rhs) = Equation p lhs <$> specialize rhs instance Specialize Rhs where - specialize (SimpleRhs p e []) = simpleRhs p <$> specialize e - specialize rhs = + specialize (SimpleRhs p _ e []) = simpleRhs p <$> specialize e + specialize rhs = internalError $ "Dictionary.specialize: " ++ show rhs instance Specialize Expression where @@ -1029,14 +845,14 @@ specialize' (Lambda _ ts e) es = do e' <- specialize e return $ apply (Lambda NoSpanInfo ts e') es -specialize' (Let _ ds e) es = do +specialize' (Let _ _ ds e) es = do ds' <- mapM specialize ds e' <- specialize e - return $ apply (Let NoSpanInfo ds' e') es -specialize' (Case _ ct e as) es = do + return $ apply (mkLet ds' e') es +specialize' (Case _ _ ct e as) es = do e' <- specialize e as' <- mapM specialize as - return $ apply (Case NoSpanInfo ct e' as') es + return $ apply (mkCase ct e' as') es specialize' e _ = internalError $ "Dictionary.specialize': " ++ show e @@ -1055,12 +871,12 @@ -- transformation. cleanup :: Module a -> DTM (Module a) -cleanup (Module spi ps m es is ds) = do +cleanup (Module spi li ps m es is ds) = do cleanedEs <- traverse cleanupExportSpec es cleanedDs <- concatMapM cleanupInfixDecl ds cleanupTyConsEnv cleanupPrecEnv - return $ Module spi ps m cleanedEs is cleanedDs + return $ Module spi li ps m cleanedEs is cleanedDs cleanupExportSpec :: ExportSpec -> DTM ExportSpec cleanupExportSpec (Exporting p es) = Exporting p <$> concatMapM cleanupExport es @@ -1229,6 +1045,9 @@ -- The function 'dictType' returns the type of the dictionary corresponding to -- a particular C-T instance. +rtDictType :: Pred -> Type +rtDictType = TypeArrow unitType . dictType + dictType :: Pred -> Type dictType (Pred cls ty) = TypeApply (TypeConstructor $ qDictTypeId cls) ty @@ -1237,7 +1056,7 @@ transformPredType :: PredType -> Type transformPredType (PredType ps ty) = - foldr (TypeArrow . dictType) ty $ Set.toList ps + foldr (TypeArrow . rtDictType) ty $ Set.toList ps -- The function 'transformMethodPredType' first deletes the implicit class -- constraint and then transforms the resulting predicated type as above. diff --git a/src/Transformations/Lift.hs b/src/Transformations/Lift.hs --- a/src/Transformations/Lift.hs +++ b/src/Transformations/Lift.hs @@ -47,11 +47,11 @@ import Env.Value lift :: ValueEnv -> Module Type -> (Module Type, ValueEnv) -lift vEnv (Module spi ps m es is ds) = (lifted, valueEnv s') +lift vEnv (Module spi li ps m es is ds) = (lifted, valueEnv s') where (ds', s') = S.runState (mapM (absDecl "" []) ds) initState initState = LiftState m vEnv Map.empty - lifted = Module spi ps m es is $ concatMap liftFunDecl ds' + lifted = Module spi li ps m es is $ concatMap liftFunDecl ds' -- ----------------------------------------------------------------------------- -- Abstraction @@ -113,8 +113,8 @@ absEquation _ _ = error "Lift.absEquation: no pattern match" absRhs :: String -> [Ident] -> Rhs Type -> LiftM (Rhs Type) -absRhs pre lvs (SimpleRhs p e _) = simpleRhs p <$> absExpr pre lvs e -absRhs _ _ _ = error "Lift.absRhs: no simple RHS" +absRhs pre lvs (SimpleRhs p _ e _) = simpleRhs p <$> absExpr pre lvs e +absRhs _ _ _ = error "Lift.absRhs: no simple RHS" -- Within a declaration group we have to split the list of declarations -- into the function and value declarations. Only the function @@ -178,7 +178,7 @@ absFunDecls pre lvs [] vds e = do vds' <- mapM (absDecl pre lvs) vds e' <- absExpr pre lvs e - return (Let NoSpanInfo vds' e') + return (mkLet vds' e') absFunDecls pre lvs (fds:fdss) vds e = do m <- getModuleIdent env <- getAbstractEnv @@ -236,7 +236,7 @@ fds' <- mapM (absFunDecl pre fvs lvs) [d | d <- fds, any (`elem` fs') (bv d)] -- abstract remaining declarations e' <- absFunDecls pre lvs fdss vds e - return (Let NoSpanInfo fds' e') + return (mkLet fds' e') -- When the free variables of a function are abstracted, the type of the -- function must be changed as well. @@ -248,7 +248,8 @@ d <- absDecl pre lvs $ FunctionDecl p undefined f' eqs' let FunctionDecl _ _ _ eqs'' = d modifyValueEnv $ bindGlobalInfo - (\qf tySc -> Value qf False (eqnArity $ head eqs') tySc) m f' $ polyType ty'' + (\qf tySc -> Value qf Nothing (eqnArity $ head eqs') tySc) m f' $ + polyType ty'' return $ FunctionDecl p ty'' f' eqs'' where f' = liftIdent pre f ty' = foldr TypeArrow (typeOf rhs') (map typeOf ts') @@ -269,7 +270,7 @@ absVar pre (Var ty f) = do m <- getModuleIdent modifyValueEnv $ bindGlobalInfo - (\qf tySc -> Value qf False (arrowArity ty) tySc) m f' $ polyType ty + (\qf tySc -> Value qf Nothing (arrowArity ty) tySc) m f' $ polyType ty return $ Var ty f' where f' = liftIdent pre f @@ -296,9 +297,9 @@ absExpr _ _ c@(Constructor _ _ _) = return c absExpr pre lvs (Apply spi e1 e2) = Apply spi <$> absExpr pre lvs e1 <*> absExpr pre lvs e2 -absExpr pre lvs (Let _ ds e) = absDeclGroup pre lvs ds e -absExpr pre lvs (Case spi ct e bs) = - Case spi ct <$> absExpr pre lvs e <*> mapM (absAlt pre lvs) bs +absExpr pre lvs (Let _ _ ds e) = absDeclGroup pre lvs ds e +absExpr pre lvs (Case _ _ ct e bs) = + mkCase ct <$> absExpr pre lvs e <*> mapM (absAlt pre lvs) bs absExpr pre lvs (Typed spi e ty) = flip (Typed spi) ty <$> absExpr pre lvs e absExpr _ _ e = internalError $ "Lift.absExpr: " ++ show e @@ -331,8 +332,8 @@ where (rhs', ds') = liftRhs rhs liftRhs :: Eq a => Rhs a -> (Rhs a, [Decl a]) -liftRhs (SimpleRhs p e _) = first (simpleRhs p) (liftExpr e) -liftRhs _ = error "Lift.liftRhs: no pattern match" +liftRhs (SimpleRhs p _ e _) = first (simpleRhs p) (liftExpr e) +liftRhs _ = error "Lift.liftRhs: no pattern match" liftDeclGroup :: Eq a => [Decl a] -> ([Decl a], [Decl a]) liftDeclGroup ds = (vds', concat (map liftFunDecl fds ++ dss')) @@ -346,10 +347,10 @@ liftExpr (Apply spi e1 e2) = (Apply spi e1' e2', ds1 ++ ds2) where (e1', ds1) = liftExpr e1 (e2', ds2) = liftExpr e2 -liftExpr (Let _ ds e) = (mkLet ds' e', ds1 ++ ds2) +liftExpr (Let _ _ ds e) = (mkLet ds' e', ds1 ++ ds2) where (ds', ds1) = liftDeclGroup ds (e' , ds2) = liftExpr e -liftExpr (Case spi ct e alts) = (Case spi ct e' alts', concat $ ds' : dss') +liftExpr (Case _ _ ct e alts) = (mkCase ct e' alts', concat $ ds' : dss') where (e' , ds' ) = liftExpr e (alts', dss') = unzip $ map liftAlt alts liftExpr (Typed spi e ty) = @@ -393,8 +394,8 @@ renamePattern t (rm, ts) = (rm, t : ts) renameRhs :: Eq a => RenameMap a -> Rhs a -> Rhs a -renameRhs rm (SimpleRhs p e _) = simpleRhs p (renameExpr rm e) -renameRhs _ _ = error "Lift.renameRhs" +renameRhs rm (SimpleRhs p _ e _) = simpleRhs p (renameExpr rm e) +renameRhs _ _ = error "Lift.renameRhs" renameExpr :: Eq a => RenameMap a -> Expression a -> Expression a renameExpr _ l@(Literal _ _ _) = l @@ -407,10 +408,10 @@ renameExpr rm (Typed spi e ty) = Typed spi (renameExpr rm e) ty renameExpr rm (Apply spi e1 e2) = Apply spi (renameExpr rm e1) (renameExpr rm e2) -renameExpr rm (Let spi ds e) = - Let spi (map (renameDecl rm) ds) (renameExpr rm e) -renameExpr rm (Case spi ct e alts) = - Case spi ct (renameExpr rm e) (map (renameAlt rm) alts) +renameExpr rm (Let _ _ ds e) = + mkLet (map (renameDecl rm) ds) (renameExpr rm e) +renameExpr rm (Case _ _ ct e alts) = + mkCase ct (renameExpr rm e) (map (renameAlt rm) alts) renameExpr _ _ = error "Lift.renameExpr" renameDecl :: Eq a => RenameMap a -> Decl a -> Decl a diff --git a/src/Transformations/Newtypes.hs b/src/Transformations/Newtypes.hs --- a/src/Transformations/Newtypes.hs +++ b/src/Transformations/Newtypes.hs @@ -30,8 +30,10 @@ import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue) -removeNewtypes :: ValueEnv -> Module Type -> Module Type -removeNewtypes vEnv mdl = R.runReader (nt mdl) vEnv +removeNewtypes :: Bool -> ValueEnv -> Module Type -> Module Type +removeNewtypes remNT vEnv mdl + | remNT = R.runReader (nt mdl) vEnv + | otherwise = mdl type NTM a = R.Reader ValueEnv a @@ -42,7 +44,7 @@ nt = mapM nt instance Show a => Newtypes (Module a) where - nt (Module spi ps m es is ds) = Module spi ps m es is <$> mapM nt ds + nt (Module spi li ps m es is ds) = Module spi li ps m es is <$> mapM nt ds instance Show a => Newtypes (Decl a) where nt d@(InfixDecl _ _ _ _) = return d @@ -66,8 +68,8 @@ "Newtypes.Newtypes.nt: unexpected left-hand-side: " ++ show lhs instance Show a => Newtypes (Rhs a) where - nt (SimpleRhs p e []) = flip (SimpleRhs p) [] <$> nt e - nt rhs = internalError $ + nt (SimpleRhs p li e []) = flip (SimpleRhs p li) [] <$> nt e + nt rhs = internalError $ "Newtypes.Newtypes.nt: unexpected right-hand-side: " ++ show rhs instance Show a => Newtypes (Pattern a) where @@ -94,8 +96,8 @@ isNc <- isNewtypeConstr c if isNc then nt e2 else Apply spi <$> nt e1 <*> nt e2 _ -> Apply spi <$> nt e1 <*> nt e2 - nt (Case spi ct e as) = Case spi ct <$> nt e <*> mapM nt as - nt (Let spi ds e) = Let spi <$> nt ds <*> nt e + nt (Case spi li ct e as) = Case spi li ct <$> nt e <*> mapM nt as + nt (Let spi li ds e) = Let spi li <$> nt ds <*> nt e nt (Typed spi e qty) = flip (Typed spi) qty <$> nt e nt e = internalError $ "Newtypes.Newtypes.nt: unexpected expression: " ++ show e diff --git a/src/Transformations/Qual.hs b/src/Transformations/Qual.hs --- a/src/Transformations/Qual.hs +++ b/src/Transformations/Qual.hs @@ -51,10 +51,10 @@ qual m tcEnv tyEnv mdl = R.runReader (qModule mdl) (QualEnv m tcEnv tyEnv) qModule :: Qual (Module a) -qModule (Module spi ps m es is ds) = do +qModule (Module spi li ps m es is ds) = do es' <- qExportSpec es ds' <- mapM qDecl ds - return (Module spi ps m es' is ds') + return (Module spi li ps m es' is ds') qExportSpec :: Qual (Maybe ExportSpec) qExportSpec Nothing = return Nothing @@ -67,22 +67,22 @@ qExport m@(ExportModule _ _) = return m qDecl :: Qual (Decl a) -qDecl i@(InfixDecl _ _ _ _) = return i -qDecl (DataDecl p n vs cs clss) = DataDecl p n vs <$> +qDecl i@(InfixDecl _ _ _ _) = return i +qDecl (DataDecl p n vs cs clss) = DataDecl p n vs <$> mapM qConstrDecl cs <*> mapM qClass clss -qDecl e@(ExternalDataDecl _ _ _) = return e -qDecl (NewtypeDecl p n vs nc clss) = NewtypeDecl p n vs <$> +qDecl e@(ExternalDataDecl _ _ _) = return e +qDecl (NewtypeDecl p n vs nc clss) = NewtypeDecl p n vs <$> qNewConstrDecl nc <*> mapM qClass clss -qDecl (TypeDecl p n vs ty) = TypeDecl p n vs <$> qTypeExpr ty -qDecl (TypeSig p fs qty) = TypeSig p fs <$> qQualTypeExpr qty -qDecl (FunctionDecl a p f eqs) = FunctionDecl a p f <$> mapM qEquation eqs -qDecl e@(ExternalDecl _ _) = return e -qDecl (PatternDecl p t rhs) = PatternDecl p <$> qPattern t <*> qRhs rhs -qDecl vs@(FreeDecl _ _) = return vs -qDecl (DefaultDecl p tys) = DefaultDecl p <$> mapM qTypeExpr tys -qDecl (ClassDecl p cx cls tv ds) = ClassDecl p <$> +qDecl (TypeDecl p n vs ty) = TypeDecl p n vs <$> qTypeExpr ty +qDecl (TypeSig p fs qty) = TypeSig p fs <$> qQualTypeExpr qty +qDecl (FunctionDecl a p f eqs) = FunctionDecl a p f <$> mapM qEquation eqs +qDecl e@(ExternalDecl _ _) = return e +qDecl (PatternDecl p t rhs) = PatternDecl p <$> qPattern t <*> qRhs rhs +qDecl vs@(FreeDecl _ _) = return vs +qDecl (DefaultDecl p tys) = DefaultDecl p <$> mapM qTypeExpr tys +qDecl (ClassDecl p li cx cls tv ds) = ClassDecl p li <$> qContext cx <*> pure cls <*> pure tv <*> mapM qDecl ds -qDecl (InstanceDecl p cx qcls ty ds) = InstanceDecl p <$> +qDecl (InstanceDecl p li cx qcls ty ds) = InstanceDecl p li <$> qContext cx <*> qClass qcls <*> qTypeExpr ty <*> mapM qDecl ds qConstrDecl :: Qual ConstrDecl @@ -156,10 +156,10 @@ InfixFuncPattern spi a <$> qPattern t1 <*> qIdent op <*> qPattern t2 qRhs :: Qual (Rhs a) -qRhs (SimpleRhs spi e ds) = - SimpleRhs spi <$> qExpr e <*> mapM qDecl ds -qRhs (GuardedRhs spi es ds) = - GuardedRhs spi <$> mapM qCondExpr es <*> mapM qDecl ds +qRhs (SimpleRhs spi li e ds) = + SimpleRhs spi li <$> qExpr e <*> mapM qDecl ds +qRhs (GuardedRhs spi li es ds) = + GuardedRhs spi li <$> mapM qCondExpr es <*> mapM qDecl ds qCondExpr :: Qual (CondExpr a) qCondExpr (CondExpr p g e) = CondExpr p <$> qExpr g <*> qExpr e @@ -199,16 +199,16 @@ <*> qExpr e qExpr (Lambda spi ts e) = Lambda spi <$> mapM qPattern ts <*> qExpr e -qExpr (Let spi ds e) = Let spi <$> mapM qDecl ds <*> qExpr e -qExpr (Do spi sts e) = Do spi <$> mapM qStmt sts <*> qExpr e +qExpr (Let spi li ds e) = Let spi li <$> mapM qDecl ds <*> qExpr e +qExpr (Do spi li sts e) = Do spi li <$> mapM qStmt sts <*> qExpr e qExpr (IfThenElse spi e1 e2 e3) = IfThenElse spi <$> qExpr e1 <*> qExpr e2 <*> qExpr e3 -qExpr (Case spi ct e as) = Case spi ct <$> qExpr e <*> mapM qAlt as +qExpr (Case spi li ct e as) = Case spi li ct <$> qExpr e <*> mapM qAlt as qStmt :: Qual (Statement a) -qStmt (StmtExpr spi e) = StmtExpr spi <$> qExpr e -qStmt (StmtBind spi t e) = StmtBind spi <$> qPattern t <*> qExpr e -qStmt (StmtDecl spi ds) = StmtDecl spi <$> mapM qDecl ds +qStmt (StmtExpr spi e) = StmtExpr spi <$> qExpr e +qStmt (StmtBind spi t e) = StmtBind spi <$> qPattern t <*> qExpr e +qStmt (StmtDecl spi li ds) = StmtDecl spi li <$> mapM qDecl ds qAlt :: Qual (Alt a) qAlt (Alt p t rhs) = Alt p <$> qPattern t <*> qRhs rhs diff --git a/src/Transformations/Simplify.hs b/src/Transformations/Simplify.hs --- a/src/Transformations/Simplify.hs +++ b/src/Transformations/Simplify.hs @@ -53,7 +53,7 @@ -- ----------------------------------------------------------------------------- simplify :: ValueEnv -> Module Type -> (Module Type, ValueEnv) -simplify vEnv mdl@(Module _ _ m _ _ _) = (mdl', valueEnv s') +simplify vEnv mdl@(Module _ _ _ m _ _ _) = (mdl', valueEnv s') where (mdl', s') = S.runState (simModule mdl) (SimplifyState m vEnv 1) -- ----------------------------------------------------------------------------- @@ -96,8 +96,8 @@ -- ----------------------------------------------------------------------------- simModule :: Module Type -> SIM (Module Type) -simModule (Module spi ps m es is ds) = Module spi ps m es is - <$> mapM (simDecl Map.empty) ds +simModule (Module spi li ps m es is ds) = Module spi li ps m es is + <$> mapM (simDecl Map.empty) ds -- Inline an expression for a variable type InlineEnv = Map.Map Ident (Expression Type) @@ -114,8 +114,8 @@ inlineFun env p lhs rhs' simRhs :: InlineEnv -> Rhs Type -> SIM (Rhs Type) -simRhs env (SimpleRhs p e _) = simpleRhs p <$> simExpr env e -simRhs _ (GuardedRhs _ _ _) = error "Simplify.simRhs: guarded rhs" +simRhs env (SimpleRhs p _ e _) = simpleRhs p <$> simExpr env e +simRhs _ (GuardedRhs _ _ _ _) = error "Simplify.simRhs: guarded rhs" -- ----------------------------------------------------------------------------- -- Inlining of Functions @@ -152,7 +152,7 @@ inlineFun env p lhs rhs = do m <- getModuleIdent case rhs of - SimpleRhs _ (Let NoSpanInfo [FunctionDecl _ _ f' eqs'] e) _ + SimpleRhs _ _ (Let _ _ [FunctionDecl _ _ f' eqs'] e) _ | -- @f'@ is not recursive f' `notElem` qfv m eqs' -- @f'@ does not perform any pattern matching @@ -161,7 +161,7 @@ let a = eqnArity $ head eqs' (n, vs', e') = etaReduce 0 [] (reverse (snd $ flatLhs lhs)) e if -- the eta-reduced rhs of @f@ is a call to @f'@ - e' == Variable NoSpanInfo (typeOf e') (qualify f') + setSpanInfo NoSpanInfo e' == Variable NoSpanInfo (typeOf e') (qualify f') -- @f'@ was fully applied before eta-reduction && n == a then mapM (mergeEqns p vs') eqs' @@ -169,12 +169,12 @@ _ -> return [Equation p lhs rhs] where etaReduce n1 vs (VariablePattern _ ty v : ts1) - (Apply NoSpanInfo e1 (Variable NoSpanInfo _ v')) + (Apply _ e1 (Variable _ _ v')) | qualify v == v' = etaReduce (n1 + 1) ((ty, v) : vs) ts1 e1 etaReduce n1 vs _ e1 = (n1, vs, e1) - mergeEqns p1 vs (Equation _ (FunLhs _ _ ts2) (SimpleRhs p2 e _)) - = Equation p1 lhs <$> simRhs env (simpleRhs p2 (Let NoSpanInfo ds e)) + mergeEqns p1 vs (Equation _ (FunLhs _ _ ts2) (SimpleRhs p2 _ e _)) + = Equation p1 lhs <$> simRhs env (simpleRhs p2 (mkLet ds e)) where ds = zipWith (\t v -> PatternDecl NoSpanInfo t (simpleRhs p2 (uncurry mkVar v))) ts2 @@ -215,20 +215,20 @@ maybe (return v) (simExpr env . withType ty) (Map.lookup (unqualify x) env) -- simplification of application simExpr env (Apply _ e1 e2) = case e1 of - Let _ ds e' -> simExpr env (Let NoSpanInfo ds (Apply NoSpanInfo e' e2)) - Case _ ct e' bs -> simExpr env (Case NoSpanInfo ct e' (map (applyToAlt e2) bs)) - _ -> Apply NoSpanInfo <$> simExpr env e1 <*> simExpr env e2 + Let _ _ ds e' -> simExpr env (mkLet ds (Apply NoSpanInfo e' e2)) + Case _ _ ct e' bs -> simExpr env (mkCase ct e' (map (applyToAlt e2) bs)) + _ -> Apply NoSpanInfo <$> simExpr env e1 <*> simExpr env e2 where applyToAlt e (Alt p t rhs) = Alt p t (applyToRhs e rhs) - applyToRhs e (SimpleRhs p e1' _) = simpleRhs p (Apply NoSpanInfo e1' e) - applyToRhs _ (GuardedRhs _ _ _) = error "Simplify.simExpr.applyRhs: Guarded rhs" + applyToRhs e (SimpleRhs p _ e1' _) = simpleRhs p (Apply NoSpanInfo e1' e) + applyToRhs _ (GuardedRhs _ _ _ _) = error "Simplify.simExpr.applyRhs: Guarded rhs" -- simplification of declarations -simExpr env (Let _ ds e) = do +simExpr env (Let _ _ ds e) = do m <- getModuleIdent dss <- mapM sharePatternRhs ds simplifyLet env (scc bv (qfv m) (foldr hoistDecls [] (concat dss))) e -simExpr env (Case _ ct e bs) = - Case NoSpanInfo ct <$> simExpr env e <*> mapM (simplifyAlt env) bs +simExpr env (Case _ _ ct e bs) = + mkCase ct <$> simExpr env e <*> mapM (simplifyAlt env) bs simExpr env (Typed _ e qty) = flip (Typed NoSpanInfo) qty <$> simExpr env e simExpr _ _ = error "Simplify.simExpr: no pattern match" @@ -256,7 +256,7 @@ -- Lift up nested let declarations in pattern declarations, i.e., replace -- @let p = let ds' in e'; ds in e@ by @let ds'; p = e'; ds in e@. hoistDecls :: Decl a -> [Decl a] -> [Decl a] -hoistDecls (PatternDecl p t (SimpleRhs p' (Let NoSpanInfo ds' e) _)) ds +hoistDecls (PatternDecl p t (SimpleRhs p' _ (Let _ _ ds' e) _)) ds = foldr hoistDecls ds (PatternDecl p t (simpleRhs p' e) : ds') hoistDecls d ds = d : ds @@ -293,7 +293,7 @@ inlineVars :: InlineEnv -> [Decl Type] -> SIM InlineEnv inlineVars env ds = case ds of - [PatternDecl _ (VariablePattern _ _ v) (SimpleRhs _ e _)] -> do + [PatternDecl _ (VariablePattern _ _ v) (SimpleRhs _ _ e _)] -> do allowed <- canInlineVar v e return $ if allowed then Map.insert v e env else env _ -> return env @@ -308,13 +308,13 @@ mkLet' :: ModuleIdent -> [Decl Type] -> Expression Type -> Expression Type mkLet' m [FreeDecl p vs] e | null vs' = e - | otherwise = Let NoSpanInfo [FreeDecl p vs'] e -- remove unused free variables + | otherwise = mkLet [FreeDecl p vs'] e -- remove unused free variables where vs' = filter ((`elem` qfv m e) . varIdent) vs -mkLet' m [PatternDecl _ (VariablePattern _ ty v) (SimpleRhs _ e _)] (Variable _ _ v') +mkLet' m [PatternDecl _ (VariablePattern _ ty v) (SimpleRhs _ _ e _)] (Variable _ _ v') | v' == qualify v && v `notElem` qfv m e = withType ty e -- inline single binding mkLet' m ds e | not (any (`elem` qfv m e) (bv ds)) = e -- removed unused bindings - | otherwise = Let NoSpanInfo ds e + | otherwise = mkLet ds e -- In order to implement lazy pattern matching in local declarations, -- pattern declarations 't = e' where 't' is not a variable @@ -331,17 +331,17 @@ -- fvs contains all variables used in the declarations and the body -- of the let expression. expandPatternBindings :: [Ident] -> Decl Type -> SIM [Decl Type] -expandPatternBindings fvs d@(PatternDecl p t (SimpleRhs _ e _)) = case t of +expandPatternBindings fvs d@(PatternDecl p t (SimpleRhs _ _ e _)) = case t of VariablePattern _ _ _ -> return [d] _ -> -- used variables mapM mkSelectorDecl (filter ((`elem` fvs) . fst3) (patternVars t)) where - pty = typeOf t -- type of patternNoSpaNoSpanInfonInfo + pty = typeOf t -- type of pattern mkSelectorDecl (v, _, vty) = do let fty = TypeArrow pty vty f <- freshIdent (updIdentName (++ '#' : idName v) . fpSelectorId) return $ varDecl p vty v $ - Let NoSpanInfo [funDecl p fty f [t] (mkVar vty v)] + mkLet [funDecl p fty f [t] (mkVar vty v)] (Apply NoSpanInfo (mkVar fty f) e) expandPatternBindings _ d = return [d] diff --git a/src/cymake.hs b/src/cymake.hs deleted file mode 100644 --- a/src/cymake.hs +++ /dev/null @@ -1,57 +0,0 @@ -{- | - Module : $Header$ - Description : Main module - Copyright : (c) 2005 Martin Engelke - 2011 - 2016 Björn Peemöller - License : BSD-3-clause - - Maintainer : bjp@informatik.uni-kiel.de - Stability : experimental - Portability : portable - - Command line tool for generating Curry representations (e.g. FlatCurry, - AbstractCurry) for a Curry source file including all imported modules. --} -module Main (main) where - -import Curry.Base.Monad (runCYIO) - -import Base.Messages -import Files.CymakePath (cymakeGreeting, cymakeVersion) - -import CurryBuilder (buildCurry) -import CompilerOpts (Options (..), CymakeMode (..), getCompilerOpts, usage) - --- |The command line tool cymake -main :: IO () -main = getCompilerOpts >>= cymake - --- |Invoke the curry builder w.r.t the command line arguments -cymake :: (String, Options, [String], [String]) -> IO () -cymake (prog, opts, files, errs) = case optMode opts of - ModeHelp -> printUsage prog - ModeVersion -> printVersion - ModeNumericVersion -> printNumericVersion - ModeMake | not (null errs) -> badUsage prog errs - | null files -> badUsage prog ["No input files"] - | otherwise -> runCYIO (mapM_ (buildCurry opts) files) >>= - either abortWithMessages continueWithMessages - where continueWithMessages = warnOrAbort (optWarnOpts opts) . snd - --- |Print the usage information of the command line tool -printUsage :: String -> IO () -printUsage prog = putStrLn $ usage prog - --- |Print the program version -printVersion :: IO () -printVersion = putStrLn cymakeGreeting - --- |Print the numeric program version -printNumericVersion :: IO () -printNumericVersion = putStrLn cymakeVersion - --- |Print errors and abort execution on bad parameters -badUsage :: String -> [String] -> IO () -badUsage prog errs = do - putErrsLn $ map (\ err -> prog ++ ": " ++ err) errs - abortWith ["Try '" ++ prog ++ " --help' for more information"] diff --git a/test/TestFrontend.hs b/test/TestFrontend.hs --- a/test/TestFrontend.hs +++ b/test/TestFrontend.hs @@ -28,7 +28,10 @@ import qualified Control.Exception as E (SomeException, catch) import Data.List (isInfixOf, sort) -import Distribution.TestSuite +import qualified Data.Map as Map (insert) +import Distribution.TestSuite ( Test (..), TestInstance (..) + , Progress (..), Result (..) + , OptionDescr) import System.FilePath (FilePath, (), (<.>)) import Curry.Base.Message (Message, message, ppMessages, ppError) @@ -36,11 +39,12 @@ import Curry.Base.Pretty (text) import qualified CompilerOpts as CO ( Options (..), WarnOpts (..) , WarnFlag (..), Verbosity (VerbQuiet) - , defaultOptions, defaultWarnOpts) + , CppOpts (..) + , defaultOptions) import CurryBuilder (buildCurry) tests :: IO [Test] -tests = return [passingTests, warningTests, failingTests] +tests = return [failingTests, passingTests, warningTests] runSecure :: CYIO a -> IO (Either [Message] (a, [Message])) runSecure act = runCYIO act `E.catch` handler @@ -48,40 +52,47 @@ -- Execute a test by calling cymake runTest :: CO.Options -> String -> [String] -> IO Progress -runTest opts test [] = passOrFail <$> runSecure (buildCurry opts' test) - where - wOpts = CO.optWarnOpts opts - wFlags = CO.WarnUnusedBindings - : CO.WarnUnusedGlobalBindings - : CO.wnWarnFlags wOpts - opts' = opts { CO.optForce = True - , CO.optWarnOpts = wOpts { CO.wnWarnFlags = wFlags } - } - passOrFail = Finished . either fail pass - fail msgs - | null msgs = Pass - | otherwise = Fail $ "An unexpected failure occurred: " ++ showMessages msgs - pass _ = Pass -runTest opts test errorMsgs = catchE <$> runSecure (buildCurry opts' test) - where - wOpts = CO.optWarnOpts opts - wFlags = CO.WarnUnusedBindings - : CO.WarnUnusedGlobalBindings - : CO.wnWarnFlags wOpts - opts' = opts { CO.optForce = True - , CO.optWarnOpts = wOpts { CO.wnWarnFlags = wFlags } - } - catchE = Finished . either pass fail - pass msgs = let errorStr = showMessages msgs - leftOverMsgs = filter (not . flip isInfixOf errorStr) errorMsgs - in if null leftOverMsgs - then Pass - else Fail $ "Expected warnings/failures did not occur: " ++ unwords leftOverMsgs - fail = pass . snd +runTest opts test errorMsgs = + if null errorMsgs + then passOrFail <$> runSecure (buildCurry opts' test) + else catchE <$> runSecure (buildCurry opts' test) + where + cppOpts = CO.optCppOpts opts + cppDefs = Map.insert "__PAKCS__" 3 (CO.cppDefinitions cppOpts) + wOpts = CO.optWarnOpts opts + wFlags = CO.WarnUnusedBindings + : CO.WarnUnusedGlobalBindings + : CO.wnWarnFlags wOpts + opts' = opts { CO.optForce = True + , CO.optWarnOpts = wOpts + { CO.wnWarnFlags = wFlags } + , CO.optCppOpts = cppOpts + { CO.cppDefinitions = cppDefs } + } + passOrFail = Finished . either fail (const Pass) + catchE = Finished . either pass (pass . snd) + fail msgs + | null msgs = Pass + | otherwise = Fail $ "An unexpected failure occurred: " ++ + showMessages msgs + pass msgs + | null otherMsgs = Pass + | otherwise = Fail $ "Expected warnings/failures did not occur: " ++ + unwords otherMsgs + where + errorStr = showMessages msgs + otherMsgs = filter (not . flip isInfixOf errorStr) errorMsgs showMessages :: [Message] -> String showMessages = show . ppMessages ppError . sort +-- group of test which should fail yielding a specific error message +failingTests :: Test +failingTests = Group { groupName = "Failing Tests" +, concurrently = False +, groupTests = map (mkTest "test/fail/") failInfos +} + -- group of tests which should pass passingTests :: Test passingTests = Group { groupName = "Passing Tests" @@ -89,13 +100,6 @@ , groupTests = map (mkTest "test/pass/") passInfos } --- group of test which should fail yielding a specific error message -failingTests :: Test -failingTests = Group { groupName = "Failing Tests" - , concurrently = False - , groupTests = map (mkTest "test/fail/") failInfos - } - -- group of tests which should pass producing a specific warning message warningTests :: Test warningTests = Group { groupName = "Warning Tests" @@ -130,57 +134,6 @@ type SetOption = String -> String -> Either String TestInstance -------------------------------------------------------------------------------- --- Definition of passing tests --------------------------------------------------------------------------------- - --- generate a simple passing test -mkPassTest :: String -> TestInfo -mkPassTest name = (name, [], [], Nothing, []) - --- To add a passing test to the test suite simply add the module name of the --- test code to the following list -passInfos :: [TestInfo] -passInfos = map mkPassTest - [ "AbstractCurryBug" - , "ACVisibility" - , "AnonymVar" - , "CaseComplete" - , "DefaultPrecedence" - , "Dequeue" - , "ExplicitLayout" - , "FCase" - , "FP_Lifting" - , "FP_NonCyclic" - , "FP_NonLinearity" - , "FunctionalPatterns" - , "HaskellRecords" - , "Hierarchical" - , "Infix" - , "Inline" - , "Lambda" - , "Maybe" - , "NegLit" - , "Newtype1" - , "Newtype2" - , "NonLinearLHS" - , "OperatorDefinition" - , "PatDecl" - , "Prelude" - , "Pretty" - , "RecordsPolymorphism" - , "RecordTest1" - , "RecordTest2" - , "RecordTest3" - , "ReexportTest" - , "SelfExport" - , "SpaceLeak" - , "TyConsTest" - , "TypedExpr" - , "UntypedAcy" - , "Unzip" - ] - --------------------------------------------------------------------------------- -- Definition of failing tests -------------------------------------------------------------------------------- @@ -192,7 +145,15 @@ -- test code and the expected error message(s) to the following list failInfos :: [TestInfo] failInfos = map (uncurry mkFailTest) - [ ("ErrorMultipleSignature", ["More than one type signature for `f'"]) + [ ("DataFail", + [ "Missing instance for Prelude.Data Test1" + , "Missing instance for Prelude.Data (Test2" + , "Missing instance for Prelude.Data (Test2" + , "Missing instance for Prelude.Data Test1" + ] + ) + , ("ErrorMultipleSignature", ["More than one type signature for `f'"]) + , ("ErrorMultipleSignature", ["More than one type signature for `f'"]) , ("ExportCheck/AmbiguousName", ["Ambiguous name `not'"]) , ("ExportCheck/AmbiguousType", ["Ambiguous type `Bool'"]) , ("ExportCheck/ModuleNotImported", ["Module `Foo' not imported"]) @@ -212,6 +173,7 @@ , "Functional patterns are not supported inside a do sequence" ] ) + , ("HaskellRecordsFail", ["Unexpected token `,'"]) , ("FP_NonGlobal", ["Function `f1' in functional pattern is not global"]) , ("ImportError", [ "Module Prelude does not export foo" @@ -223,6 +185,8 @@ , "Type variable b occurs more than once in left hand side of type declaration" ] ) + , ("MissingLabelInUpdate", + ["Undefined record label `l1'"] ) , ("MultipleArities", ["Equations for `test' have different arities"]) , ("MultipleDefinitions", ["Multiple definitions for data/record constructor `Rec'"] @@ -248,11 +212,75 @@ , "Function: h" , "Type signature too general" , "Function: g'" + , "Type signature too general" + , "Function: n" ] ) + , ("UnboundTypeVariable", + [ "Unbound type variable b" + , "Unbound type variable c" + ] + ) ] -------------------------------------------------------------------------------- +-- Definition of passing tests +-------------------------------------------------------------------------------- + +-- generate a simple passing test +mkPassTest :: String -> TestInfo +mkPassTest = flip mkFailTest [] + +-- To add a passing test to the test suite simply add the module name of the +-- test code to the following list +passInfos :: [TestInfo] +passInfos = map mkPassTest + [ "AbstractCurryBug" + , "ACVisibility" + , "AnonymVar" + , "CaseComplete" + , "DataPass" + , "DefaultPrecedence" + , "Dequeue" + , "EmptyWhere" + , "ExplicitLayout" + , "FCase" + , "FP_Lifting" + , "FP_NonCyclic" + , "FP_NonLinearity" + , "FunctionalPatterns" + , "HaskellRecords" + , "HaskellRecordsPass" + , "Hierarchical" + , "ImportRestricted" + , "ImportRestricted2" + , "Infix" + , "Inline" + , "Lambda" + , "Maybe" + , "NegLit" + , "Newtype1" + , "Newtype2" + , "NonLinearLHS" + , "OperatorDefinition" + , "PatDecl" + , "Prelude" + , "Pretty" + , "RecordsPolymorphism" + , "RecordTest1" + , "RecordTest2" + , "RecordTest3" + , "ReexportTest" + , "SelfExport" + , "SpaceLeak" + , "TyConsTest" + , "TypedExpr" + , "UntypedAcy" + , "Unzip" + , "WhereAfterDo" + ] + +-------------------------------------------------------------------------------- -- Definition of warning tests -------------------------------------------------------------------------------- @@ -305,6 +333,7 @@ , "In an equation for `tuple'", "In an equation for `tuple2'" , "In an equation for `g'", "In an equation for `rec'"] ) + , ("NoRedundant", []) , ("OverlappingPatterns", [ "Pattern matches are potentially unreachable", "In a case alternative" , "An fcase expression is potentially non-deterministic due to overlapping rules" @@ -312,6 +341,12 @@ , "Function `j' is potentially non-deterministic due to overlapping rules" , "Function `k' is potentially non-deterministic due to overlapping rules" ] + ) + , ("QualRedundant", + [ "Redundant context in type signature for function `f': 'P.Eq a'"] + ) + , ("Redundant", + [ "Redundant context in type signature for function `f': 'Eq a'"] ) , ("ShadowingSymbols", [ "Unused declaration of variable `x'", "Shadowing symbol `x'"])