language-ocaml (empty) → 0.1.31
raw patch · 201 files changed
+9587/−0 lines, 201 filesdep +arraydep +basedep +containers
Dependencies added: array, base, containers, data-default, extensible-effects, interpolate, language-ocaml, lens, megaparsec, mtl, prettyprinter, string-qq, tasty, tasty-hunit
Files
- LICENSE +21/−0
- language-ocaml.cabal +253/−0
- lib/Language/OCaml/Definitions/Parsing/ASTHelper/Common.hs +8/−0
- lib/Language/OCaml/Definitions/Parsing/ASTHelper/Exception.hs +57/−0
- lib/Language/OCaml/Definitions/Parsing/ASTHelper/Exp.hs +202/−0
- lib/Language/OCaml/Definitions/Parsing/ASTHelper/Mb.hs +37/−0
- lib/Language/OCaml/Definitions/Parsing/ASTHelper/Mod.hs +34/−0
- lib/Language/OCaml/Definitions/Parsing/ASTHelper/Mtd.hs +41/−0
- lib/Language/OCaml/Definitions/Parsing/ASTHelper/Mty.hs +47/−0
- lib/Language/OCaml/Definitions/Parsing/ASTHelper/Opn.hs +38/−0
- lib/Language/OCaml/Definitions/Parsing/ASTHelper/Pat.hs +34/−0
- lib/Language/OCaml/Definitions/Parsing/ASTHelper/Str.hs +51/−0
- lib/Language/OCaml/Definitions/Parsing/ASTHelper/Te.hs +91/−0
- lib/Language/OCaml/Definitions/Parsing/ASTHelper/Typ.hs +86/−0
- lib/Language/OCaml/Definitions/Parsing/ASTHelper/Type.hs +109/−0
- lib/Language/OCaml/Definitions/Parsing/ASTHelper/Val.hs +38/−0
- lib/Language/OCaml/Definitions/Parsing/ASTHelper/Vb.hs +36/−0
- lib/Language/OCaml/Definitions/Parsing/ASTTypes.hs +76/−0
- lib/Language/OCaml/Definitions/Parsing/Docstrings.hs +222/−0
- lib/Language/OCaml/Definitions/Parsing/Location.hs +35/−0
- lib/Language/OCaml/Definitions/Parsing/Longident.hs +22/−0
- lib/Language/OCaml/Definitions/Parsing/ParseTree.hs +515/−0
- lib/Language/OCaml/Definitions/Parsing/Parser/LetBinding.hs +21/−0
- lib/Language/OCaml/Definitions/Parsing/Parser/LetBindings.hs +19/−0
- lib/Language/OCaml/Definitions/StdLib/Lexing.hs +18/−0
- lib/Language/OCaml/Definitions/StdLib/Parsing.hs +26/−0
- lib/Language/OCaml/Parser.hs +27/−0
- lib/Language/OCaml/Parser/AndTypeDeclaration.hs +29/−0
- lib/Language/OCaml/Parser/AttrId.hs +21/−0
- lib/Language/OCaml/Parser/Attribute.hs +21/−0
- lib/Language/OCaml/Parser/Attributes.hs +13/−0
- lib/Language/OCaml/Parser/BarConstructorDeclaration.hs +27/−0
- lib/Language/OCaml/Parser/Common.hs +376/−0
- lib/Language/OCaml/Parser/Constant.hs +23/−0
- lib/Language/OCaml/Parser/ConstrIdent.hs +18/−0
- lib/Language/OCaml/Parser/ConstrLongident.hs +28/−0
- lib/Language/OCaml/Parser/ConstructorArguments.hs +15/−0
- lib/Language/OCaml/Parser/ConstructorDeclaration.hs +25/−0
- lib/Language/OCaml/Parser/ConstructorDeclarations.hs +23/−0
- lib/Language/OCaml/Parser/CoreType.hs +18/−0
- lib/Language/OCaml/Parser/CoreType2.hs +26/−0
- lib/Language/OCaml/Parser/CoreTypeCommaList.hs +12/−0
- lib/Language/OCaml/Parser/CoreTypeList.hs +21/−0
- lib/Language/OCaml/Parser/CoreTypeNoAttr.hs +15/−0
- lib/Language/OCaml/Parser/Expr.hs +99/−0
- lib/Language/OCaml/Parser/ExprSemiList.hs +18/−0
- lib/Language/OCaml/Parser/FunBinding.hs +22/−0
- lib/Language/OCaml/Parser/FunDef.hs +27/−0
- lib/Language/OCaml/Parser/GeneralizedConstructorArguments.hs +17/−0
- lib/Language/OCaml/Parser/Generator/Lexer.x +653/−0
- lib/Language/OCaml/Parser/Generator/Parser.y +1232/−0
- lib/Language/OCaml/Parser/Implementation.hs +13/−0
- lib/Language/OCaml/Parser/Internal.hs +200/−0
- lib/Language/OCaml/Parser/Label.hs +9/−0
- lib/Language/OCaml/Parser/LabelDeclaration.hs +24/−0
- lib/Language/OCaml/Parser/LabelDeclarationSemi.hs +26/−0
- lib/Language/OCaml/Parser/LabelDeclarations.hs +20/−0
- lib/Language/OCaml/Parser/LabelLongident.hs +20/−0
- lib/Language/OCaml/Parser/LabeledSimpleExpr.hs +18/−0
- lib/Language/OCaml/Parser/LabeledSimplePattern.hs +18/−0
- lib/Language/OCaml/Parser/LblExpr.hs +23/−0
- lib/Language/OCaml/Parser/LblExprList.hs +31/−0
- lib/Language/OCaml/Parser/LblPattern.hs +29/−0
- lib/Language/OCaml/Parser/LblPatternList.hs +40/−0
- lib/Language/OCaml/Parser/LetBinding.hs +23/−0
- lib/Language/OCaml/Parser/LetBindingBody.hs +61/−0
- lib/Language/OCaml/Parser/LetBindings.hs +28/−0
- lib/Language/OCaml/Parser/MatchCase.hs +33/−0
- lib/Language/OCaml/Parser/MatchCases.hs +13/−0
- lib/Language/OCaml/Parser/ModExtLongident.hs +21/−0
- lib/Language/OCaml/Parser/ModLongident.hs +11/−0
- lib/Language/OCaml/Parser/ModuleBinding.hs +25/−0
- lib/Language/OCaml/Parser/ModuleBindingBody.hs +18/−0
- lib/Language/OCaml/Parser/ModuleExpr.hs +17/−0
- lib/Language/OCaml/Parser/MutableFlag.hs +15/−0
- lib/Language/OCaml/Parser/NonRecFlag.hs +15/−0
- lib/Language/OCaml/Parser/OpenStatement.hs +37/−0
- lib/Language/OCaml/Parser/Operator.hs +17/−0
- lib/Language/OCaml/Parser/OptBar.hs +14/−0
- lib/Language/OCaml/Parser/OptPatternTypeConstraint.hs +16/−0
- lib/Language/OCaml/Parser/OptSemi.hs +14/−0
- lib/Language/OCaml/Parser/OptTypeConstraint.hs +15/−0
- lib/Language/OCaml/Parser/OptionalTypeParameter.hs +15/−0
- lib/Language/OCaml/Parser/OptionalTypeParameters.hs +18/−0
- lib/Language/OCaml/Parser/OptionalTypeVariable.hs +12/−0
- lib/Language/OCaml/Parser/OverrideFlag.hs +15/−0
- lib/Language/OCaml/Parser/Pattern.hs +40/−0
- lib/Language/OCaml/Parser/PatternGen.hs +22/−0
- lib/Language/OCaml/Parser/PatternNoExn.hs +34/−0
- lib/Language/OCaml/Parser/PatternSemiList.hs +18/−0
- lib/Language/OCaml/Parser/Payload.hs +13/−0
- lib/Language/OCaml/Parser/PolyTypeNoAttr.hs +16/−0
- lib/Language/OCaml/Parser/PostItemAttribute.hs +20/−0
- lib/Language/OCaml/Parser/PostItemAttributes.hs +13/−0
- lib/Language/OCaml/Parser/PrivateFlag.hs +15/−0
- lib/Language/OCaml/Parser/RecFlag.hs +15/−0
- lib/Language/OCaml/Parser/RecordExpr.hs +28/−0
- lib/Language/OCaml/Parser/SeqExpr.hs +30/−0
- lib/Language/OCaml/Parser/SigExceptionDeclaration.hs +39/−0
- lib/Language/OCaml/Parser/SimpleCoreType.hs +21/−0
- lib/Language/OCaml/Parser/SimpleCoreType2.hs +38/−0
- lib/Language/OCaml/Parser/SimpleCoreTypeOrTuple.hs +26/−0
- lib/Language/OCaml/Parser/SimpleDelimitedPattern.hs +45/−0
- lib/Language/OCaml/Parser/SimpleExpr.hs +50/−0
- lib/Language/OCaml/Parser/SimpleLabeledExprList.hs +16/−0
- lib/Language/OCaml/Parser/SimplePattern.hs +21/−0
- lib/Language/OCaml/Parser/SimplePatternNotIdent.hs +33/−0
- lib/Language/OCaml/Parser/SingleAttrId.hs +15/−0
- lib/Language/OCaml/Parser/StrExceptionDeclaration.hs +15/−0
- lib/Language/OCaml/Parser/StrictBinding.hs +24/−0
- lib/Language/OCaml/Parser/Structure.hs +39/−0
- lib/Language/OCaml/Parser/StructureItem.hs +32/−0
- lib/Language/OCaml/Parser/Tokens.hs +322/−0
- lib/Language/OCaml/Parser/TypeConstraint.hs +30/−0
- lib/Language/OCaml/Parser/TypeDeclaration.hs +34/−0
- lib/Language/OCaml/Parser/TypeDeclarations.hs +25/−0
- lib/Language/OCaml/Parser/TypeKind.hs +40/−0
- lib/Language/OCaml/Parser/TypeLongident.hs +20/−0
- lib/Language/OCaml/Parser/TypeVariable.hs +12/−0
- lib/Language/OCaml/Parser/TypeVariance.hs +16/−0
- lib/Language/OCaml/Parser/Utils/Combinators.hs +77/−0
- lib/Language/OCaml/Parser/Utils/Types.hs +8/−0
- lib/Language/OCaml/Parser/Utils/Utils.hs +115/−0
- lib/Language/OCaml/Parser/ValIdent.hs +20/−0
- lib/Language/OCaml/Parser/ValLongident.hs +23/−0
- lib/Language/OCaml/PrettyPrinter.hs +10/−0
- lib/Language/OCaml/PrettyPrinter/ArgLabel.hs +23/−0
- lib/Language/OCaml/PrettyPrinter/Case.hs +26/−0
- lib/Language/OCaml/PrettyPrinter/Constant.hs +25/−0
- lib/Language/OCaml/PrettyPrinter/ConstructorArguments.hs +24/−0
- lib/Language/OCaml/PrettyPrinter/ConstructorDeclaration.hs +25/−0
- lib/Language/OCaml/PrettyPrinter/CoreType.hs +18/−0
- lib/Language/OCaml/PrettyPrinter/CoreTypeDesc.hs +37/−0
- lib/Language/OCaml/PrettyPrinter/Expression.hs +18/−0
- lib/Language/OCaml/PrettyPrinter/ExpressionDesc.hs +91/−0
- lib/Language/OCaml/PrettyPrinter/Internal.hs +6/−0
- lib/Language/OCaml/PrettyPrinter/LabelDeclaration.hs +23/−0
- lib/Language/OCaml/PrettyPrinter/Loc.hs +18/−0
- lib/Language/OCaml/PrettyPrinter/Longident.hs +21/−0
- lib/Language/OCaml/PrettyPrinter/ModuleBinding.hs +22/−0
- lib/Language/OCaml/PrettyPrinter/ModuleExpr.hs +19/−0
- lib/Language/OCaml/PrettyPrinter/ModuleExprDesc.hs +27/−0
- lib/Language/OCaml/PrettyPrinter/MutableFlag.hs +24/−0
- lib/Language/OCaml/PrettyPrinter/OpenDescription.hs +25/−0
- lib/Language/OCaml/PrettyPrinter/OverrideFlag.hs +20/−0
- lib/Language/OCaml/PrettyPrinter/Pattern.hs +18/−0
- lib/Language/OCaml/PrettyPrinter/PatternDesc.hs +56/−0
- lib/Language/OCaml/PrettyPrinter/Payload.hs +33/−0
- lib/Language/OCaml/PrettyPrinter/RecFlag.hs +22/−0
- lib/Language/OCaml/PrettyPrinter/Structure.hs +13/−0
- lib/Language/OCaml/PrettyPrinter/StructureItem.hs +19/−0
- lib/Language/OCaml/PrettyPrinter/StructureItemDesc.hs +58/−0
- lib/Language/OCaml/PrettyPrinter/TypeDeclaration.hs +51/−0
- lib/Language/OCaml/PrettyPrinter/ValueBinding.hs +23/−0
- lib/Language/OCaml/PrettyPrinter/Variance.hs +25/−0
- lib/Language/OCaml/Utils.hs +9/−0
- test/Language/OCaml/Parser/AndLetBinding/Test.hs +28/−0
- test/Language/OCaml/Parser/AttrId/Test.hs +21/−0
- test/Language/OCaml/Parser/Attribute/Test.hs +16/−0
- test/Language/OCaml/Parser/Attributes/Test.hs +22/−0
- test/Language/OCaml/Parser/Common/Test.hs +52/−0
- test/Language/OCaml/Parser/Constant/Test.hs +27/−0
- test/Language/OCaml/Parser/ConstrLongident/Test.hs +34/−0
- test/Language/OCaml/Parser/Expr/Test.hs +9/−0
- test/Language/OCaml/Parser/ExtAttributes/Test.hs +9/−0
- test/Language/OCaml/Parser/Generator/Expr/Test.hs +19/−0
- test/Language/OCaml/Parser/Generator/Implementation/Test.hs +64/−0
- test/Language/OCaml/Parser/Generator/SeqExpr/Test.hs +23/−0
- test/Language/OCaml/Parser/Generator/SimpleExpr/Test.hs +17/−0
- test/Language/OCaml/Parser/Generator/ValLongident/Test.hs +17/−0
- test/Language/OCaml/Parser/Implementation/Test.hs +45/−0
- test/Language/OCaml/Parser/Int/Test.hs +36/−0
- test/Language/OCaml/Parser/LetBinding/Test.hs +31/−0
- test/Language/OCaml/Parser/LetBindingBody/Test.hs +23/−0
- test/Language/OCaml/Parser/LetBindings/Test.hs +25/−0
- test/Language/OCaml/Parser/MatchCase/Test.hs +25/−0
- test/Language/OCaml/Parser/ModLongident/Test.hs +25/−0
- test/Language/OCaml/Parser/OpenStatement/Test.hs +27/−0
- test/Language/OCaml/Parser/Operator/Test.hs +17/−0
- test/Language/OCaml/Parser/Pattern/Test.hs +31/−0
- test/Language/OCaml/Parser/Payload/Test.hs +11/−0
- test/Language/OCaml/Parser/PostItemAttribute/Test.hs +32/−0
- test/Language/OCaml/Parser/PostItemAttributes/Test.hs +32/−0
- test/Language/OCaml/Parser/RecFlag/Test.hs +6/−0
- test/Language/OCaml/Parser/SeqExpr/Test.hs +22/−0
- test/Language/OCaml/Parser/SimpleExpr/Test.hs +21/−0
- test/Language/OCaml/Parser/SimplePattern/Test.hs +26/−0
- test/Language/OCaml/Parser/SingleAttrId/Test.hs +63/−0
- test/Language/OCaml/Parser/StrictBinding/Test.hs +21/−0
- test/Language/OCaml/Parser/Structure/Test.hs +43/−0
- test/Language/OCaml/Parser/StructureItem/Test.hs +16/−0
- test/Language/OCaml/Parser/StructureTail/Test.hs +27/−0
- test/Language/OCaml/Parser/TestStrings.hs +43/−0
- test/Language/OCaml/Parser/TestUtils.hs +64/−0
- test/Language/OCaml/Parser/Tokens/Test.hs +37/−0
- test/Language/OCaml/Parser/ValIdent/Test.hs +14/−0
- test/Language/OCaml/Parser/ValLongident/Test.hs +18/−0
- test/Language/OCaml/PrettyPrinter/Structure/Test.hs +42/−0
- test/Language/OCaml/PrettyPrinter/StructureItem/Test.hs +130/−0
- test/Language/OCaml/PrettyPrinter/TestUtils.hs +71/−0
- test/Main.hs +89/−0
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2018 Valentin Robert++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ language-ocaml.cabal view
@@ -0,0 +1,253 @@+Name: language-ocaml+Version: 0.1.31+Synopsis: Language tools for manipulating OCaml programs in Haskell+Description: Language tools for manipulating OCaml programs in Haskell.+ Curently includes a Alex/Happy parser, and a pretty-printer.+License: MIT+License-file: LICENSE+Author: Valentin Robert+Maintainer: valentin.robert.42@gmail.com+Stability: Experimental+Category: Language, OCaml+Build-type: Simple+Cabal-version: 1.22++Source-repository head+ type: git+ location: https://github.com/Ptival/language-ocaml++Library+ default-language: Haskell2010+ ghc-options: -Wall -Wno-orphans+ hs-source-dirs: lib, test+ pkgconfig-depends: zlib+ build-tools: alex, happy+ build-depends: array >= 0.5 && < 0.6,+ base >= 4.9 && < 4.11,+ containers >= 0.5 && < 0.7,+ data-default >= 0.7 && < 0.8,+ extensible-effects >= 3.0 && < 3.1,+ interpolate >= 0.2 && < 0.3,+ lens >= 4.16 && < 4.17,+ megaparsec >= 6.0 && < 6.5,+ mtl >= 2.2 && < 2.3,+ prettyprinter >= 1.2 && < 1.3,+ string-qq >= 0.0 && < 0.1,+ tasty >= 1.0 && < 1.1,+ tasty-hunit >= 0.9 && < 0.11+ exposed-modules:+ Language.OCaml.Parser.Common+ Language.OCaml.Definitions.Parsing.ASTHelper.Exception+ Language.OCaml.Definitions.Parsing.ASTHelper.Exp+ Language.OCaml.Definitions.Parsing.ASTHelper.Mb+ Language.OCaml.Definitions.Parsing.ASTHelper.Mod+ Language.OCaml.Definitions.Parsing.ASTHelper.Mtd+ Language.OCaml.Definitions.Parsing.ASTHelper.Mty+ Language.OCaml.Definitions.Parsing.ASTHelper.Opn+ Language.OCaml.Definitions.Parsing.ASTHelper.Pat+ Language.OCaml.Definitions.Parsing.ASTHelper.Str+ Language.OCaml.Definitions.Parsing.ASTHelper.Te+ Language.OCaml.Definitions.Parsing.ASTHelper.Typ+ Language.OCaml.Definitions.Parsing.ASTHelper.Type+ Language.OCaml.Definitions.Parsing.ASTHelper.Val+ Language.OCaml.Definitions.Parsing.ASTHelper.Vb+ Language.OCaml.Definitions.Parsing.Docstrings+ Language.OCaml.Definitions.Parsing.Location+ Language.OCaml.Definitions.Parsing.Longident+ Language.OCaml.Definitions.Parsing.Parser.LetBinding+ Language.OCaml.Definitions.Parsing.Parser.LetBindings+ Language.OCaml.Definitions.Parsing.ASTTypes+ Language.OCaml.Definitions.Parsing.ParseTree+ Language.OCaml.Parser+ Language.OCaml.Parser.Generator.Lexer+ Language.OCaml.Parser.Generator.Parser+ Language.OCaml.Parser.Internal+ Language.OCaml.Parser.Utils.Utils+ Language.OCaml.PrettyPrinter+ Language.OCaml.PrettyPrinter.Internal+ other-modules:+ Language.OCaml.Definitions.Parsing.ASTHelper.Common+ Language.OCaml.Definitions.StdLib.Lexing+ Language.OCaml.Definitions.StdLib.Parsing+ Language.OCaml.Utils+ Language.OCaml.Parser.AndTypeDeclaration+ Language.OCaml.Parser.Attribute+ Language.OCaml.Parser.Attributes+ Language.OCaml.Parser.AttrId+ Language.OCaml.Parser.BarConstructorDeclaration+ Language.OCaml.Parser.Constant+ Language.OCaml.Parser.ConstrIdent+ Language.OCaml.Parser.ConstrLongident+ Language.OCaml.Parser.ConstructorArguments+ Language.OCaml.Parser.ConstructorDeclaration+ Language.OCaml.Parser.ConstructorDeclarations+ Language.OCaml.Parser.CoreType+ Language.OCaml.Parser.CoreType2+ Language.OCaml.Parser.CoreTypeCommaList+ Language.OCaml.Parser.CoreTypeList+ Language.OCaml.Parser.CoreTypeNoAttr+ Language.OCaml.Parser.Expr+ Language.OCaml.Parser.ExprSemiList+ Language.OCaml.Parser.FunBinding+ Language.OCaml.Parser.FunDef+ Language.OCaml.Parser.GeneralizedConstructorArguments+ Language.OCaml.Parser.Implementation+ Language.OCaml.Parser.Label+ Language.OCaml.Parser.LabelDeclaration+ Language.OCaml.Parser.LabelDeclarationSemi+ Language.OCaml.Parser.LabelDeclarations+ Language.OCaml.Parser.LabelLongident+ Language.OCaml.Parser.LabeledSimpleExpr+ Language.OCaml.Parser.LabeledSimplePattern+ Language.OCaml.Parser.LblExpr+ Language.OCaml.Parser.LblExprList+ Language.OCaml.Parser.LblPattern+ Language.OCaml.Parser.LblPatternList+ Language.OCaml.Parser.LetBinding+ Language.OCaml.Parser.LetBindingBody+ Language.OCaml.Parser.LetBindings+ Language.OCaml.Parser.MatchCase+ Language.OCaml.Parser.MatchCases+ Language.OCaml.Parser.ModExtLongident+ Language.OCaml.Parser.ModLongident+ Language.OCaml.Parser.ModuleBinding+ Language.OCaml.Parser.ModuleBindingBody+ Language.OCaml.Parser.ModuleExpr+ Language.OCaml.Parser.MutableFlag+ Language.OCaml.Parser.NonRecFlag+ Language.OCaml.Parser.OpenStatement+ Language.OCaml.Parser.Operator+ Language.OCaml.Parser.OptBar+ Language.OCaml.Parser.OptPatternTypeConstraint+ Language.OCaml.Parser.OptTypeConstraint+ Language.OCaml.Parser.OptSemi+ Language.OCaml.Parser.OptionalTypeParameter+ Language.OCaml.Parser.OptionalTypeParameters+ Language.OCaml.Parser.OptionalTypeVariable+ Language.OCaml.Parser.OverrideFlag+ Language.OCaml.Parser.Pattern+ Language.OCaml.Parser.PatternGen+ Language.OCaml.Parser.PatternNoExn+ Language.OCaml.Parser.PatternSemiList+ Language.OCaml.Parser.Payload+ Language.OCaml.Parser.PolyTypeNoAttr+ Language.OCaml.Parser.PostItemAttribute+ Language.OCaml.Parser.PostItemAttributes+ Language.OCaml.Parser.PrivateFlag+ Language.OCaml.Parser.RecFlag+ Language.OCaml.Parser.RecordExpr+ Language.OCaml.Parser.SeqExpr+ Language.OCaml.Parser.SigExceptionDeclaration+ Language.OCaml.Parser.SimpleCoreType+ Language.OCaml.Parser.SimpleCoreType2+ Language.OCaml.Parser.SimpleCoreTypeOrTuple+ Language.OCaml.Parser.SimpleDelimitedPattern+ Language.OCaml.Parser.SimpleExpr+ Language.OCaml.Parser.SimplePattern+ Language.OCaml.Parser.SimpleLabeledExprList+ Language.OCaml.Parser.SimplePatternNotIdent+ Language.OCaml.Parser.SingleAttrId+ Language.OCaml.Parser.StrExceptionDeclaration+ Language.OCaml.Parser.StrictBinding+ Language.OCaml.Parser.Structure+ Language.OCaml.Parser.StructureItem+ Language.OCaml.Parser.TestUtils+ Language.OCaml.Parser.Tokens+ Language.OCaml.Parser.TypeConstraint+ Language.OCaml.Parser.TypeDeclaration+ Language.OCaml.Parser.TypeDeclarations+ Language.OCaml.Parser.TypeKind+ Language.OCaml.Parser.TypeVariable+ Language.OCaml.Parser.TypeVariance+ Language.OCaml.Parser.TypeLongident+ Language.OCaml.Parser.Utils.Combinators+ Language.OCaml.Parser.Utils.Types+ Language.OCaml.Parser.ValIdent+ Language.OCaml.Parser.ValLongident+ Language.OCaml.PrettyPrinter.ArgLabel+ Language.OCaml.PrettyPrinter.Case+ Language.OCaml.PrettyPrinter.Constant+ Language.OCaml.PrettyPrinter.ConstructorArguments+ Language.OCaml.PrettyPrinter.ConstructorDeclaration+ Language.OCaml.PrettyPrinter.CoreType+ Language.OCaml.PrettyPrinter.CoreTypeDesc+ Language.OCaml.PrettyPrinter.Expression+ Language.OCaml.PrettyPrinter.ExpressionDesc+ Language.OCaml.PrettyPrinter.LabelDeclaration+ Language.OCaml.PrettyPrinter.Loc+ Language.OCaml.PrettyPrinter.Longident+ Language.OCaml.PrettyPrinter.ModuleBinding+ Language.OCaml.PrettyPrinter.ModuleExpr+ Language.OCaml.PrettyPrinter.ModuleExprDesc+ Language.OCaml.PrettyPrinter.MutableFlag+ Language.OCaml.PrettyPrinter.OpenDescription+ Language.OCaml.PrettyPrinter.OverrideFlag+ Language.OCaml.PrettyPrinter.Pattern+ Language.OCaml.PrettyPrinter.PatternDesc+ Language.OCaml.PrettyPrinter.Payload+ Language.OCaml.PrettyPrinter.RecFlag+ Language.OCaml.PrettyPrinter.Structure+ Language.OCaml.PrettyPrinter.StructureItem+ Language.OCaml.PrettyPrinter.StructureItemDesc+ Language.OCaml.PrettyPrinter.TypeDeclaration+ Language.OCaml.PrettyPrinter.ValueBinding+ Language.OCaml.PrettyPrinter.Variance++Test-suite Test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ build-depends: language-ocaml,+ base,+ interpolate,+ megaparsec,+ prettyprinter,+ string-qq,+ tasty,+ tasty-hunit+ other-modules:+ Language.OCaml.Parser.AndLetBinding.Test+ Language.OCaml.Parser.Attribute.Test+ Language.OCaml.Parser.Attributes.Test+ Language.OCaml.Parser.AttrId.Test+ Language.OCaml.Parser.Common.Test+ Language.OCaml.Parser.Constant.Test+ Language.OCaml.Parser.ConstrLongident.Test+ Language.OCaml.Parser.Expr.Test+ Language.OCaml.Parser.ExtAttributes.Test+ Language.OCaml.Parser.Generator.Expr.Test+ Language.OCaml.Parser.Generator.Implementation.Test+ Language.OCaml.Parser.Generator.SeqExpr.Test+ Language.OCaml.Parser.Generator.SimpleExpr.Test+ Language.OCaml.Parser.Generator.ValLongident.Test+ Language.OCaml.Parser.Implementation.Test+ Language.OCaml.Parser.Int.Test+ Language.OCaml.Parser.LetBinding.Test+ Language.OCaml.Parser.LetBindingBody.Test+ Language.OCaml.Parser.LetBindings.Test+ Language.OCaml.Parser.MatchCase.Test+ Language.OCaml.Parser.ModLongident.Test+ Language.OCaml.Parser.OpenStatement.Test+ Language.OCaml.Parser.Operator.Test+ Language.OCaml.Parser.Pattern.Test+ Language.OCaml.Parser.Payload.Test+ Language.OCaml.Parser.PostItemAttribute.Test+ Language.OCaml.Parser.PostItemAttributes.Test+ Language.OCaml.Parser.RecFlag.Test+ Language.OCaml.Parser.SeqExpr.Test+ Language.OCaml.Parser.SimpleExpr.Test+ Language.OCaml.Parser.SimplePattern.Test+ Language.OCaml.Parser.SingleAttrId.Test+ Language.OCaml.Parser.StrictBinding.Test+ Language.OCaml.Parser.Structure.Test+ Language.OCaml.Parser.StructureItem.Test+ Language.OCaml.Parser.StructureTail.Test+ Language.OCaml.Parser.TestStrings+ Language.OCaml.Parser.TestUtils+ Language.OCaml.Parser.Tokens.Test+ Language.OCaml.Parser.ValIdent.Test+ Language.OCaml.Parser.ValLongident.Test+ Language.OCaml.PrettyPrinter.Structure.Test+ Language.OCaml.PrettyPrinter.StructureItem.Test+ Language.OCaml.PrettyPrinter.TestUtils
+ lib/Language/OCaml/Definitions/Parsing/ASTHelper/Common.hs view
@@ -0,0 +1,8 @@+module Language.OCaml.Definitions.Parsing.ASTHelper.Common+ ( defaultLoc+ ) where++import Language.OCaml.Definitions.Parsing.Location++defaultLoc :: Location+defaultLoc = none
+ lib/Language/OCaml/Definitions/Parsing/ASTHelper/Exception.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RecordWildCards #-}++module Language.OCaml.Definitions.Parsing.ASTHelper.Exception+ ( MkOpts(..)+ , RebindOpts(..)+ , mk+ , rebind+ ) where++import Data.Default++import Language.OCaml.Definitions.Parsing.ASTTypes hiding (loc)+import Language.OCaml.Definitions.Parsing.ASTHelper.Common+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Definitions.Parsing.Docstrings+import Language.OCaml.Definitions.Parsing.Location++mk :: MkOpts -> ExtensionConstructor -> TypeException+mk (MkOpts {..}) ctor = TypeException+ { ptyexnConstructor = ctor+ , ptyexnAttributes = attrs+ }++data MkOpts = MkOpts+ { attrs :: [Attribute]+ , docs :: Docs+ }++instance Default MkOpts where+ def = MkOpts+ { attrs = []+ , docs = emptyDocs+ }++rebind :: RebindOpts -> Loc String -> Loc Longident -> ExtensionConstructor+rebind (RebindOpts {..}) name lid = ExtensionConstructor+ { pextName = name+ , pextKind = PextRebind lid+ , pextLoc = loc+ , pextAttributes = addDocsAttrs docs (addInfoAttrs info attrs)+ }++data RebindOpts = RebindOpts+ { attrs :: [Attribute]+ , docs :: Docs+ , loc :: Location+ , info :: Info+ }++instance Default RebindOpts where+ def = RebindOpts+ { attrs = []+ , docs = emptyDocs+ , loc = defaultLoc+ , info = emptyInfo+ }
+ lib/Language/OCaml/Definitions/Parsing/ASTHelper/Exp.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}++module Language.OCaml.Definitions.Parsing.ASTHelper.Exp+ ( CaseOpts(..)+ , MkOpts(..)+ , apply+ , array+ , assert+ , attr+ , case'+ , coerce+ , constant+ , constraint+ , construct+ , extension+ , field+ , for+ , fun+ , function+ , ident+ , ifThenElse+ , lazy+ , let'+ , letException+ , letModule+ , match+ , mk+ , new+ , newType+ , object+ , open+ , override+ , pack+ , poly+ , record+ , send+ , sequence+ , setField+ , setInstVar+ , try+ , tuple+ , unreachable+ , variant+ , while+ ) where++import Data.Default+import Prelude hiding (sequence)++import Language.OCaml.Definitions.Parsing.ASTHelper.Common+import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree as ParseTree+import Language.OCaml.Definitions.Parsing.Location++attr :: Expression -> Attribute -> Expression+attr d a = d { pexpAttributes = pexpAttributes d ++ [a] }++-- oops! case is a reserved Haskell lexeme+case' :: CaseOpts -> Pattern -> Expression -> Case+case' (CaseOpts {..}) lhs rhs = Case+ { pcLHS = lhs+ , pcGuard = guard+ , pcRHS = rhs+ }++data CaseOpts = CaseOpts+ { guard :: Maybe Expression+ }++instance Default CaseOpts where+ def = CaseOpts+ { guard = Nothing+ }++mk :: MkOpts -> ExpressionDesc -> Expression+mk (MkOpts {..}) desc =+ Expression+ { pexpDesc = desc+ , pexpLoc = loc+ , pexpAttributes = attrs+ }++data MkOpts = MkOpts+ { attrs :: [Attribute]+ , loc :: Location+ }++instance Default MkOpts where+ def = MkOpts+ { attrs = []+ , loc = defaultLoc+ }++ident :: MkOpts -> Loc Longident -> Expression+ident (MkOpts {..}) a = mk (def { loc, attrs }) $ PexpIdent a++constant :: MkOpts -> ParseTree.Constant -> Expression+constant (MkOpts {..}) a = mk (def { loc, attrs }) $ PexpConstant a++let' :: MkOpts -> RecFlag -> [ValueBinding] -> Expression -> Expression+let' (MkOpts {..}) a b c = mk (def { loc, attrs }) $ PexpLet a b c++fun :: MkOpts -> ArgLabel -> Maybe Expression -> Pattern -> Expression -> Expression+fun (MkOpts {..}) a b c d = mk (def { loc, attrs }) $ PexpFun a b c d++function :: MkOpts -> [Case] -> Expression+function (MkOpts {..}) a = mk (def { loc, attrs }) $ PexpFunction a++apply :: MkOpts -> Expression -> [(ArgLabel, Expression)] -> Expression+apply (MkOpts {..}) a b = mk (def { loc, attrs }) $ PexpApply a b++match :: MkOpts -> Expression -> [Case]-> Expression+match (MkOpts {..}) a b = mk (def { loc, attrs }) $ PexpMatch a b++try :: MkOpts -> Expression -> [Case] -> Expression+try (MkOpts {..}) a b = mk (def { loc, attrs }) $ PexpTry a b++tuple :: MkOpts -> [Expression] -> Expression+tuple (MkOpts {..}) a = mk (def { loc, attrs }) $ PexpTuple a++construct :: MkOpts -> Loc Longident -> Maybe Expression -> Expression+construct (MkOpts {..}) a b = mk (def { loc, attrs }) $ PexpConstruct a b++variant :: MkOpts -> Label -> Maybe Expression -> Expression+variant (MkOpts {..}) a b = mk (def { loc, attrs }) $ PexpVariant a b++record :: MkOpts -> [(Loc Longident, Expression)] -> Maybe Expression -> Expression+record (MkOpts {..}) a b = mk (def { loc, attrs }) $ PexpRecord a b++field :: MkOpts -> Expression -> Loc Longident -> Expression+field (MkOpts {..}) a b = mk (def { loc, attrs }) $ PexpField a b++setField :: MkOpts -> Expression -> Loc Longident -> Expression -> Expression+setField (MkOpts {..}) a b c = mk (def { loc, attrs }) $ PexpSetField a b c++array :: MkOpts -> [Expression] -> Expression+array (MkOpts {..}) a = mk (def { loc, attrs }) $ PexpArray a++ifThenElse :: MkOpts -> Expression -> Expression -> Maybe Expression -> Expression+ifThenElse (MkOpts {..}) a b c = mk (def { loc, attrs }) $ PexpIfThenElse a b c++sequence :: MkOpts -> Expression -> Expression -> Expression+sequence (MkOpts {..}) a b = mk (def { loc, attrs }) $ PexpSequence a b++while :: MkOpts -> Expression -> Expression -> Expression+while (MkOpts {..}) a b = mk (def { loc, attrs }) $ PexpWhile a b++for :: MkOpts -> Pattern -> Expression -> Expression -> DirectionFlag -> Expression -> Expression+for (MkOpts {..}) a b c d e = mk (def { loc, attrs }) $ PexpFor a b c d e++constraint :: MkOpts -> Expression -> CoreType -> Expression+constraint (MkOpts {..}) a b = mk (def { loc, attrs }) $ PexpConstraint a b++coerce :: MkOpts -> Expression -> Maybe CoreType -> CoreType -> Expression+coerce (MkOpts {..}) a b c = mk (def { loc, attrs }) $ PexpCoerce a b c++send :: MkOpts -> Expression -> Loc Label -> Expression+send (MkOpts {..}) a b = mk (def { loc, attrs }) $ PexpSend a b++new :: MkOpts -> Loc Longident -> Expression+new (MkOpts {..}) a = mk (def { loc, attrs }) $ PexpNew a++setInstVar :: MkOpts -> Loc Label -> Expression -> Expression+setInstVar (MkOpts {..}) a b = mk (def { loc, attrs }) $ PexpSetInstVar a b++override :: MkOpts -> [(Loc Label, Expression)] -> Expression+override (MkOpts {..}) a = mk (def { loc, attrs }) $ PexpOverride a++letModule :: MkOpts -> Loc String -> ModuleExpr -> Expression -> Expression+letModule (MkOpts {..}) a b c = mk (def { loc, attrs }) $ PexpLetModule a b c++letException :: MkOpts -> ExtensionConstructor -> Expression -> Expression+letException (MkOpts {..}) a b = mk (def { loc, attrs }) $ PexpLetException a b++assert :: MkOpts -> Expression -> Expression+assert (MkOpts {..}) a = mk (def { loc, attrs }) $ PexpAssert a++lazy :: MkOpts -> Expression -> Expression+lazy (MkOpts {..}) a = mk (def { loc, attrs }) $ PexpLazy a++poly :: MkOpts -> Expression -> Maybe CoreType -> Expression+poly (MkOpts {..}) a b = mk (def { loc, attrs }) $ PexpPoly a b++object :: MkOpts -> ClassStructure -> Expression+object (MkOpts {..}) a = mk (def { loc, attrs }) $ PexpObject a++newType :: MkOpts -> Loc String -> Expression -> Expression+newType (MkOpts {..}) a b = mk (def { loc, attrs }) $ PexpNewType a b++pack :: MkOpts -> ModuleExpr -> Expression+pack (MkOpts {..}) a = mk (def { loc, attrs }) $ PexpPack a++open :: MkOpts -> OverrideFlag -> Loc Longident -> Expression -> Expression+open (MkOpts {..}) a b c = mk (def { loc, attrs }) $ PexpOpen a b c++extension :: MkOpts -> Extension -> Expression+extension (MkOpts {..}) a = mk (def { loc, attrs }) $ PexpExtension a++unreachable :: MkOpts -> () -> Expression+unreachable (MkOpts {..}) () = mk (def { loc, attrs }) PexpUnreachable
+ lib/Language/OCaml/Definitions/Parsing/ASTHelper/Mb.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE RecordWildCards #-}++module Language.OCaml.Definitions.Parsing.ASTHelper.Mb+ ( MkOpts(..)+ , mk+ ) where++import Data.Default++import Language.OCaml.Definitions.Parsing.ASTHelper.Common+import Language.OCaml.Definitions.Parsing.ASTTypes hiding (loc)+import Language.OCaml.Definitions.Parsing.Docstrings+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Definitions.Parsing.Location++mk :: MkOpts -> Loc String -> ModuleExpr -> ModuleBinding+mk (MkOpts {..}) name expr = ModuleBinding+ { pmbName = name+ , pmbExpr = expr+ , pmbAttributes = addTextAttrs text . addDocsAttrs docs $ attrs+ , pmbLoc = loc+ }++data MkOpts = MkOpts+ { attrs :: [Attribute]+ , docs :: Docs+ , loc :: Location+ , text :: [Docstring]+ }++instance Default MkOpts where+ def = MkOpts+ { attrs = []+ , docs = emptyDocs+ , loc = defaultLoc+ , text = []+ }
+ lib/Language/OCaml/Definitions/Parsing/ASTHelper/Mod.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE RecordWildCards #-}++module Language.OCaml.Definitions.Parsing.ASTHelper.Mod+ ( MkOpts(..)+ , attr+ , mk+ ) where++import Data.Default++import Language.OCaml.Definitions.Parsing.ASTHelper.Common+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Definitions.Parsing.Location++attr :: ModuleExpr -> Attribute -> ModuleExpr+attr d a = d { pmodAttributes = pmodAttributes d ++ [a] }++mk :: MkOpts -> ModuleExprDesc -> ModuleExpr+mk (MkOpts {..}) d = ModuleExpr+ { pmodDesc = d+ , pmodLoc = loc+ , pmodAttributes = attrs+ }++data MkOpts = MkOpts+ { attrs :: [Attribute]+ , loc :: Location+ }++instance Default MkOpts where+ def = MkOpts+ { attrs = []+ , loc = defaultLoc+ }
+ lib/Language/OCaml/Definitions/Parsing/ASTHelper/Mtd.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}++module Language.OCaml.Definitions.Parsing.ASTHelper.Mtd+ ( MkOpts(..)+ , mk+ ) where++import Data.Default+import Prelude hiding (sequence)++import Language.OCaml.Definitions.Parsing.ASTHelper.Common+import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.Docstrings+import Language.OCaml.Definitions.Parsing.ParseTree as ParseTree+import Language.OCaml.Definitions.Parsing.Location++mk :: MkOpts -> Maybe ModuleType -> Loc String -> ModuleTypeDeclaration+mk (MkOpts {..}) typ name =+ ModuleTypeDeclaration+ { pmtdName = name+ , pmtdType = typ+ , pmtdAttributes = addTextAttrs text $ addDocsAttrs docs $ attrs+ , pmtdLoc = loc+ }++data MkOpts = MkOpts+ { attrs :: [Attribute]+ , docs :: Docs+ , loc :: Location+ , text :: Text+ }++instance Default MkOpts where+ def = MkOpts+ { attrs = []+ , docs = emptyDocs+ , loc = defaultLoc+ , text = []+ }
+ lib/Language/OCaml/Definitions/Parsing/ASTHelper/Mty.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}++module Language.OCaml.Definitions.Parsing.ASTHelper.Mty+ ( MkOpts(..)+ , attr+ , extension+ , ident+ , mk+ ) where++import Data.Default+import Prelude hiding (sequence)++import Language.OCaml.Definitions.Parsing.ASTHelper.Common+import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree as ParseTree+import Language.OCaml.Definitions.Parsing.Location++attr :: ModuleType -> Attribute -> ModuleType+attr d a = d { pmtyAttributes = pmtyAttributes d ++ [a] }++mk :: MkOpts -> ModuleTypeDesc -> ModuleType+mk (MkOpts {..}) desc =+ ModuleType+ { pmtyDesc = desc+ , pmtyLoc = loc+ , pmtyAttributes = attrs+ }++data MkOpts = MkOpts+ { attrs :: [Attribute]+ , loc :: Location+ }++instance Default MkOpts where+ def = MkOpts+ { attrs = []+ , loc = defaultLoc+ }++ident :: MkOpts -> Loc Longident -> ModuleType+ident (MkOpts {..}) a = mk (def { loc, attrs }) $ PmtyIdent a++extension :: MkOpts -> Extension -> ModuleType+extension (MkOpts {..}) a = mk (def { loc, attrs }) $ PmtyExtension a
+ lib/Language/OCaml/Definitions/Parsing/ASTHelper/Opn.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE RecordWildCards #-}++module Language.OCaml.Definitions.Parsing.ASTHelper.Opn+ ( MkOpts(..)+ , mk+ ) where++import Data.Default++import Language.OCaml.Definitions.Parsing.ASTHelper.Common+import Language.OCaml.Definitions.Parsing.ASTTypes hiding (loc)+import Language.OCaml.Definitions.Parsing.Docstrings+import Language.OCaml.Definitions.Parsing.Location+import Language.OCaml.Definitions.Parsing.ParseTree++mk :: MkOpts -> Loc Longident -> OpenDescription+mk (MkOpts {..}) lid =+ OpenDescription+ { popenLid = lid+ , popenOverride = override+ , popenLoc = loc+ , popenAttributes = addDocsAttrs docs attrs+ }++data MkOpts = MkOpts+ { attrs :: [Attribute]+ , docs :: Docs+ , loc :: Location+ , override :: OverrideFlag+ }++instance Default MkOpts where+ def = MkOpts+ { attrs = []+ , docs = emptyDocs+ , loc = defaultLoc+ , override = Fresh+ }
+ lib/Language/OCaml/Definitions/Parsing/ASTHelper/Pat.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE RecordWildCards #-}++module Language.OCaml.Definitions.Parsing.ASTHelper.Pat+ ( MkOpts(..)+ , attr+ , mk+ ) where++import Data.Default++import Language.OCaml.Definitions.Parsing.ASTHelper.Common+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Definitions.Parsing.Location++attr :: Pattern -> Attribute -> Pattern+attr d a = d { ppatAttributes = ppatAttributes d ++ [a] }++mk :: MkOpts -> PatternDesc -> Pattern+mk (MkOpts {..}) d = Pattern+ { ppatDesc = d+ , ppatLoc = loc+ , ppatAttributes = attrs+ }++data MkOpts = MkOpts+ { attrs :: [Attribute]+ , loc :: Location+ }++instance Default MkOpts where+ def = MkOpts+ { attrs = []+ , loc = defaultLoc+ }
+ lib/Language/OCaml/Definitions/Parsing/ASTHelper/Str.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RecordWildCards #-}++module Language.OCaml.Definitions.Parsing.ASTHelper.Str+ ( AttributeOpts(..)+ , MkOpts(..)+ , attribute+ , mk+ , text+ ) where++import Data.Default++import Language.OCaml.Definitions.Parsing.ASTHelper.Common+import Language.OCaml.Definitions.Parsing.Docstrings+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Definitions.Parsing.Location++attribute :: AttributeOpts -> Attribute -> StructureItem+attribute (AttributeOpts {..}) a = mk (def { loc }) (PstrAttribute a)++data AttributeOpts = AttributeOpts+ { loc :: Location+ }++instance Default AttributeOpts where+ def = AttributeOpts+ { loc = defaultLoc+ }++mk :: MkOpts -> StructureItemDesc -> StructureItem+mk (MkOpts {..}) d =+ StructureItem+ { pstrDesc = d+ , pstrLoc = loc+ }++data MkOpts = MkOpts+ { loc :: Location+ }++instance Default MkOpts where+ def = MkOpts+ { loc = defaultLoc+ }++text :: [Docstring] -> [StructureItem]+text txt =+ let fTxt = filter (\ ds -> docstringBody ds /= "") txt in+ map (\ ds -> attribute (def { loc = docstringLoc ds }) (textAttr ds)) fTxt
+ lib/Language/OCaml/Definitions/Parsing/ASTHelper/Te.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RecordWildCards #-}++module Language.OCaml.Definitions.Parsing.ASTHelper.Te+ ( DeclOpts(..)+ , MkOpts(..)+ , RebindOpts(..)+ , decl+ , mk+ , rebind+ ) where++import Data.Default++import Language.OCaml.Definitions.Parsing.ASTTypes hiding (loc)+import Language.OCaml.Definitions.Parsing.ASTHelper.Common+import Language.OCaml.Definitions.Parsing.Docstrings+import Language.OCaml.Definitions.Parsing.Location+import Language.OCaml.Definitions.Parsing.ParseTree++decl :: DeclOpts -> Maybe CoreType -> Loc String -> ExtensionConstructor+decl (DeclOpts {..}) res name = ExtensionConstructor+ { pextName = name+ , pextKind = PextDecl args res+ , pextLoc = loc+ , pextAttributes = addDocsAttrs docs (addInfoAttrs info attrs)+ }++data DeclOpts = DeclOpts+ { args :: ConstructorArguments+ , attrs :: [Attribute]+ , docs :: Docs+ , loc :: Location+ , info :: Info+ }++instance Default DeclOpts where+ def = DeclOpts+ { args = PcstrTuple []+ , attrs = []+ , docs = emptyDocs+ , loc = defaultLoc+ , info = emptyInfo+ }++mk :: MkOpts -> Loc Longident -> [ExtensionConstructor] -> TypeExtension+mk (MkOpts {..}) path constructors = TypeExtension+ { ptyextPath = path+ , ptyextParams = params+ , ptyextConstructors = constructors+ , ptyextPrivate = priv+ , ptyextAttributes = attrs+ }++data MkOpts = MkOpts+ { attrs :: [Attribute]+ , docs :: Docs+ , params :: [(CoreType, Variance)]+ , priv :: PrivateFlag+ }++instance Default MkOpts where+ def = MkOpts+ { attrs = []+ , docs = emptyDocs+ , params = []+ , priv = Public+ }++rebind :: RebindOpts -> Loc String -> Loc Longident -> ExtensionConstructor+rebind (RebindOpts {..}) name lid = ExtensionConstructor+ { pextName = name+ , pextKind = PextRebind lid+ , pextLoc = loc+ , pextAttributes = addDocsAttrs docs $ addInfoAttrs info $ attrs+ }++data RebindOpts = RebindOpts+ { attrs :: [Attribute]+ , docs :: Docs+ , loc :: Location+ , info :: Info+ }++instance Default RebindOpts where+ def = RebindOpts+ { attrs = []+ , docs = emptyDocs+ , loc = defaultLoc+ , info = emptyInfo+ }
+ lib/Language/OCaml/Definitions/Parsing/ASTHelper/Typ.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE RecordWildCards #-}++module Language.OCaml.Definitions.Parsing.ASTHelper.Typ+ ( MkOpts(..)+ , mk+ , varifyConstructors+ ) where++import Control.Eff+import Control.Eff.Exception+import Data.Default++import Language.OCaml.Definitions.Parsing.ASTHelper.Common+import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.Location+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Utils++mk :: MkOpts -> CoreTypeDesc -> CoreType+mk (MkOpts {..}) desc =+ CoreType+ { ptypDesc = desc+ , ptypLoc = loc+ , ptypAttributes = attrs+ }++data MkOpts = MkOpts+ { loc :: Location+ , attrs :: [Attribute]+ }++instance Default MkOpts where+ def = MkOpts+ { loc = defaultLoc+ , attrs = []+ }++varifyConstructors ::+ (Member (Exc String) r) =>+ [Loc String] -> CoreType -> Eff r CoreType+varifyConstructors varNames0 = loop+ where++ checkVariable :: (Member (Exc String) r) => [String] -> Location -> String -> Eff r ()+ checkVariable vl pos v =+ if v `elem` vl+ then throwError $ "Variable in scope " ++ show v ++ " at " ++ show pos+ else return ()++ loopRowField :: (Member (Exc String) r) => RowField -> Eff r RowField+ loopRowField = \case+ Rtag label attrs flag lst -> Rtag label attrs flag <$> traverse loop lst+ Rinherit t -> Rinherit <$> loop t++ loopObjectField :: (Member (Exc String) r) => ObjectField -> Eff r ObjectField+ loopObjectField = \case+ Otag label attrs t -> Otag label attrs <$> loop t+ Oinherit t -> Oinherit <$> loop t++ varNames = map (\ v -> txt v) varNames0++ loop:: (Member (Exc String) r) => CoreType -> Eff r CoreType+ loop t = do+ desc <- case ptypDesc t of+ PtypAny -> return PtypAny+ PtypVar x -> do+ checkVariable varNames (ptypLoc t) x+ return $ PtypVar x+ PtypArrow label coreType coreType' -> PtypArrow label <$> loop coreType <*> loop coreType'+ PtypTuple lst -> PtypTuple <$> traverse loop lst+ PtypConstr (Loc { txt = Lident s }) [] | s `elem` varNames -> return $ PtypVar s+ PtypConstr longident lst -> PtypConstr longident <$> traverse loop lst+ PtypObject lst o -> PtypObject <$> traverse loopObjectField lst <*^> o+ PtypClass longident lst -> PtypClass longident <$> traverse loop lst+ PtypAlias coreType string -> do+ checkVariable varNames (ptypLoc t) string+ PtypAlias <$> loop coreType <*^> string+ PtypVariant rowFieldList flag lblLstOption ->+ PtypVariant <$> traverse loopRowField rowFieldList <*^> flag <*^> lblLstOption+ PtypPoly _stringLst _coreType -> error "TODO"+ PtypPackage (_longident, _lst) -> error "TODO"+ PtypExtension (s, arg) -> return $ PtypExtension (s, arg)+ return $ t { ptypDesc = desc }
+ lib/Language/OCaml/Definitions/Parsing/ASTHelper/Type.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RecordWildCards #-}++module Language.OCaml.Definitions.Parsing.ASTHelper.Type+ ( ConstructorOpts(..)+ , FieldOpts(..)+ , MkOpts(..)+ , constructor+ , field+ , mk+ ) where++import Data.Default++import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.ASTHelper.Common+import Language.OCaml.Definitions.Parsing.Docstrings+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Definitions.Parsing.Location++constructor ::+ ConstructorOpts ->+ Maybe CoreType ->+ Loc String ->+ ConstructorDeclaration+constructor (ConstructorOpts {..}) res name =+ ConstructorDeclaration+ { pcdName = name+ , pcdArgs = args+ , pcdRes = res+ , pcdLoc = loc+ , pcdAttributes = attrs+ }++data ConstructorOpts = ConstructorOpts+ { args :: ConstructorArguments+ , attrs :: [Attribute]+ , loc :: Location+ , info :: Info+ }++instance Default ConstructorOpts where+ def = ConstructorOpts+ { args = PcstrTuple []+ , attrs = []+ , loc = defaultLoc+ , info = emptyInfo+ }++field :: FieldOpts -> Loc String -> CoreType -> LabelDeclaration+field (FieldOpts {..}) name typ =+ LabelDeclaration+ { pldName = name+ , pldMutable = mut+ , pldType = typ+ , pldLoc = loc+ , pldAttributes = addInfoAttrs info attrs+ }++data FieldOpts = FieldOpts+ { attrs :: [Attribute]+ , info :: Info+ , loc :: Location+ , mut :: MutableFlag+ }++instance Default FieldOpts where+ def = FieldOpts+ { attrs = []+ , info = emptyInfo+ , loc = defaultLoc+ , mut = Immutable+ }++mk :: MkOpts -> Maybe CoreType -> Loc String -> TypeDeclaration+mk (MkOpts {..}) manifest name =+ TypeDeclaration+ { ptypeName = name+ , ptypeParams = params+ , ptypeCstrs = cstrs+ , ptypeKind = kind+ , ptypePrivate = priv+ , ptypeManifest = manifest+ , ptypeAttributes = attrs+ , ptypeLoc = loc+ }++data MkOpts = MkOpts+ { attrs :: [Attribute]+ , docs :: Docs+ , cstrs :: [(CoreType, CoreType, Location)]+ , kind :: TypeKind+ , loc :: Location+ , params :: [(CoreType, Variance)]+ , priv :: PrivateFlag+ , text :: Text+ }++instance Default MkOpts where+ def = MkOpts+ { attrs = []+ , cstrs = []+ , docs = emptyDocs+ , kind = PtypeAbstract+ , loc = defaultLoc+ , params = []+ , priv = Public+ , text = []+ }
+ lib/Language/OCaml/Definitions/Parsing/ASTHelper/Val.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE RecordWildCards #-}++module Language.OCaml.Definitions.Parsing.ASTHelper.Val+ ( MkOpts(..)+ , mk+ ) where++import Data.Default++import Language.OCaml.Definitions.Parsing.ASTHelper.Common+import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.Docstrings+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Definitions.Parsing.Location++mk :: MkOpts -> Loc String -> CoreType -> ValueDescription+mk (MkOpts {..}) name typ = ValueDescription+ { pvalName = name+ , pvalType = typ+ , pvalAttributes = addDocsAttrs docs attrs+ , pvalLoc = loc+ , pvalPrim = prim+ }++data MkOpts = MkOpts+ { attrs :: [Attribute]+ , docs :: Docs+ , loc :: Location+ , prim :: [String]+ }++instance Default MkOpts where+ def = MkOpts+ { attrs = []+ , docs = emptyDocs+ , loc = defaultLoc+ , prim = []+ }
+ lib/Language/OCaml/Definitions/Parsing/ASTHelper/Vb.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE RecordWildCards #-}++module Language.OCaml.Definitions.Parsing.ASTHelper.Vb+ ( MkOpts(..)+ , mk+ ) where++import Data.Default++import Language.OCaml.Definitions.Parsing.ASTHelper.Common+import Language.OCaml.Definitions.Parsing.Docstrings+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Definitions.Parsing.Location++mk :: MkOpts -> Pattern -> Expression -> ValueBinding+mk (MkOpts {..}) pat expr = ValueBinding+ { pvbPat = pat+ , pvbExpr = expr+ , pvbAttributes = addTextAttrs text . addDocsAttrs docs $ attrs+ , pvbLoc = loc+ }++data MkOpts = MkOpts+ { attrs :: [Attribute]+ , docs :: Docs+ , loc :: Location+ , text :: [Docstring]+ }++instance Default MkOpts where+ def = MkOpts+ { attrs = []+ , docs = emptyDocs+ , loc = defaultLoc+ , text = []+ }
+ lib/Language/OCaml/Definitions/Parsing/ASTTypes.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DeriveGeneric #-}++module Language.OCaml.Definitions.Parsing.ASTTypes+ ( ArgLabel(..)+ , ClosedFlag(..)+ , Constant(..)+ , DirectionFlag(..)+ , Label+ , Loc(..)+ , OverrideFlag(..)+ , RecFlag(..)+ , Variance(..)+ , VirtualFlag(..)+ ) where++import GHC.Generics++import Language.OCaml.Definitions.Parsing.Location++data Constant+ = ConstInt Int+ | ConstChar Char+ | ConstString String (Maybe String)+ | ConstFloat String+ -- | ConstInt32 Int32+ -- | ConstInt64 Int64+ -- | Const_nativeint Nativeint+ deriving (Eq, Generic, Show)++data Loc a = Loc+ { txt :: a+ , loc :: Location+ }+ deriving (Generic, Show)++instance Eq a => Eq (Loc a) where+ a == b = txt a == txt b++data OverrideFlag+ = Override+ | Fresh+ deriving (Eq, Generic, Show)++data RecFlag+ = NonRecursive+ | Recursive+ deriving (Eq, Generic, Show)++data ArgLabel+ = Nolabel+ | Labelled String+ | Optional String+ deriving (Eq, Generic, Show)++data Variance+ = Covariant+ | Contravariant+ | Invariant+ deriving (Eq, Generic, Show)++data ClosedFlag+ = Closed+ | Open+ deriving (Eq, Generic, Show)++type Label = String++data DirectionFlag+ = UpTo+ | DownTo+ deriving (Eq, Generic, Show)++data VirtualFlag+ = Virtual+ | Concrete+ deriving (Eq, Generic, Show)
+ lib/Language/OCaml/Definitions/Parsing/Docstrings.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++module Language.OCaml.Definitions.Parsing.Docstrings+ ( Docs+ , Docstring(..)+ , Info+ , Text+ , addDocsAttrs+ , addInfoAttrs+ , addTextAttrs+ , docsAttr+ , docstringBody+ , docstringLoc+ , emptyDocs+ , emptyInfo+ , rhsInfo+ , rhsPostText+ , rhsPreText+ , rhsPostExtraText+ , rhsPreExtraText+ , rhsText+ , symbolInfo+ , symbolText+ , symbolTextLazy+ , textAttr+ ) where++import GHC.Generics+import qualified Data.Map.Strict as M+import Prelude hiding (exp)++import Language.OCaml.Definitions.StdLib.Lexing+import Language.OCaml.Definitions.StdLib.Parsing as Parsing+import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.Location+import Language.OCaml.Definitions.Parsing.ParseTree++data DsAttached+ = Unattached {- Not yet attached anything. -}+ | Info {- Attached to a field or constructor. -}+ | Docs {- Attached to an item or as floating text. -}+ deriving (Eq, Generic, Show)++{- A docstring is "associated" with an item if there are no blank lines between+ them. This is used for generating docstring ambiguity warnings. -}+data DsAssociated+ = Zero {- Not associated with an item -}+ | One {- Associated with one item -}+ | Many+ deriving (Eq, Generic, Show)++data Docstring = Docstring+ { dsBody :: String+ , dsLoc :: Location+ , dsAttached :: DsAttached+ , dsAssociated :: DsAssociated+ }+ deriving (Eq, Generic, Show)++type Text = [Docstring]++textLoc :: Loc String+textLoc = Loc+ { txt = "ocaml.text"+ , loc = none+ }++textAttr :: Docstring -> Attribute+textAttr ds =+ let exp =+ Expression+ { pexpDesc = PexpConstant (PconstString (dsBody ds) Nothing)+ , pexpLoc = dsLoc ds+ , pexpAttributes = []+ }+ in+ let item =+ StructureItem+ { pstrDesc = PstrEval exp []+ , pstrLoc = pexpLoc exp+ }+ in+ (textLoc, PStr [item])++addTextAttrs :: [Docstring] -> [Attribute] -> [Attribute]+addTextAttrs dsl attrs = (map textAttr dsl) ++ attrs++rhsText :: a -> [b]+rhsText pos = getText (rhsStartPos pos)++getText :: a -> [b]+getText _pos = [] -- FIXME++data Docs = Docs'+ { docsPre :: Maybe Docstring+ , docsPost :: Maybe Docstring+ }+ deriving (Eq, Generic, Show)++addDocsAttrs :: Docs -> [(Loc String, Payload)] -> [(Loc String, Payload)]+addDocsAttrs docs attrs =+ let attrs1 = case docsPre docs of+ Nothing -> attrs+ Just ds -> docsAttr ds : attrs+ in+ let attrs2 = case docsPost docs of+ Nothing -> attrs1+ Just ds -> attrs1 ++ [docsAttr ds]+ in+ attrs2++addInfoAttrs :: a -> b -> b+addInfoAttrs _info attrs = attrs -- FIXME++emptyDocs :: Docs+emptyDocs =+ Docs'+ { docsPre = Nothing+ , docsPost = Nothing+ }++docLoc :: Loc String+docLoc =+ Loc+ { txt = "ocaml.doc"+ , loc = none+ }++docsAttr :: Docstring -> (Loc String, Payload)+docsAttr ds =+ let exp = Expression+ { pexpDesc = PexpConstant $ PconstString (dsBody ds) Nothing+ , pexpLoc = dsLoc ds+ , pexpAttributes = []+ }+ in+ let item = StructureItem+ { pstrDesc = PstrEval exp []+ , pstrLoc = pexpLoc exp+ }+ in+ (docLoc, PStr [item])++type Info = Maybe Docstring++emptyInfo :: Info+emptyInfo = Nothing++docstringBody :: Docstring -> String+docstringBody = dsBody++docstringLoc :: Docstring -> Location+docstringLoc = dsLoc++symbolInfo :: () -> Info+symbolInfo () = Nothing -- FIXME++symbolText :: () -> Text+symbolText () = [] -- FIXM++symbolTextLazy :: () -> Text+symbolTextLazy () = [] -- FIXMEE++preTable :: M.Map Position Text+preTable = M.empty++postTable :: M.Map Position Text+postTable = M.empty++preExtraTable :: M.Map Position Text+preExtraTable = M.empty++postExtraTable :: M.Map Position Text+postExtraTable = M.empty++getDocstrings :: [Docstring] -> [Docstring]+getDocstrings dsl = loop [] dsl+ where+ loop acc = \case+ [] -> reverse acc+ (Docstring {..}) : rest | dsAttached == Info -> loop acc rest+ ds : rest -> loop (ds { dsAttached = Docs } : acc) rest++getPreText :: Position -> Text+getPreText pos = getDocstrings $ M.findWithDefault [] pos preTable++rhsPreText :: a -> Text+rhsPreText pos = getPreText (Parsing.rhsStartPos pos)++getPostText :: Position -> Text+getPostText pos = getDocstrings $ M.findWithDefault [] pos postTable++rhsPostText :: a -> Text+rhsPostText pos = getPostText (Parsing.rhsEndPos pos)++getPreExtraText :: Position -> Text+getPreExtraText pos = getDocstrings $ M.findWithDefault [] pos preExtraTable++rhsPreExtraText :: a -> Text+rhsPreExtraText pos = getPreExtraText (Parsing.rhsStartPos pos)++getPostExtraText :: Position -> Text+getPostExtraText pos = getDocstrings $ M.findWithDefault [] pos postExtraTable++rhsPostExtraText :: a -> Text+rhsPostExtraText pos = getPostExtraText (Parsing.rhsEndPos pos)++rhsInfo :: Int -> Info+rhsInfo pos = getInfo (Parsing.rhsEndPos pos)++getInfo :: Position -> Maybe Docstring+getInfo pos = M.lookup pos postTable >>= getDocstring True++getDocstring :: Bool -> [Docstring] -> Maybe Docstring+getDocstring info dsl = loop dsl+ where+ loop = \case+ [] -> Nothing+ (Docstring { dsAttached = Info }) : rest -> loop rest+ ds : _ -> Just $ ds { dsAttached = if info then Info else Docs }
+ lib/Language/OCaml/Definitions/Parsing/Location.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DeriveGeneric #-}++module Language.OCaml.Definitions.Parsing.Location+ ( Location(..)+ , none+ ) where++import GHC.Generics++import Language.OCaml.Definitions.StdLib.Lexing++data Location = Location+ { locStart :: Position+ , locEnd :: Position+ , locGhost :: Bool+ }+ deriving (Eq, Generic, Show)++inFile :: String -> Location+inFile name =+ Location+ { locStart = loc+ , locEnd = loc+ , locGhost = True+ }+ where+ loc = Position+ { posFName = name+ , posLNum = 1+ , posBOL = 0+ , posCNum = -1+ }++none :: Location+none = inFile "__none__"
+ lib/Language/OCaml/Definitions/Parsing/Longident.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}++module Language.OCaml.Definitions.Parsing.Longident+ ( Longident(..)+ , last+ ) where++import GHC.Generics+import Prelude hiding (last)++data Longident+ = Lident String+ | Ldot Longident String+ | Lapply Longident Longident+ deriving (Eq, Generic, Show)++last :: Longident -> String+last = \case+ Lident s -> s+ Ldot _ s -> s+ Lapply _ _ -> error "Longident.last"
+ lib/Language/OCaml/Definitions/Parsing/ParseTree.hs view
@@ -0,0 +1,515 @@+{-# LANGUAGE DeriveGeneric #-}++module Language.OCaml.Definitions.Parsing.ParseTree+ ( Attribute+ , Attributes+ , Case(..)+ , ClassDeclaration+ , ClassExpr(..)+ , ClassField(..)+ , ClassInfos(..)+ , ClassSignature(..)+ , ClassStructure(..)+ , ClassType(..)+ , ClassTypeDeclaration+ , ClassTypeField(..)+ , Constant(..)+ , ConstructorArguments(..)+ , ConstructorDeclaration(..)+ , CoreType(..)+ , CoreTypeDesc(..)+ , Expression(..)+ , ExpressionDesc(..)+ , Extension+ , ExtensionConstructor(..)+ , ExtensionConstructorKind(..)+ , IncludeDeclaration+ , IncludeInfos(..)+ , LabelDeclaration(..)+ , Longident(..)+ , ModuleBinding(..)+ , ModuleExpr(..)+ , ModuleExprDesc(..)+ , ModuleType(..)+ , ModuleTypeDeclaration(..)+ , ModuleTypeDesc(..)+ , MutableFlag(..)+ , ObjectField(..)+ , OpenDescription(..)+ , PackageType+ , Pattern(..)+ , PatternDesc(..)+ , Payload(..)+ , PrivateFlag(..)+ , RowField(..)+ , Signature+ , SignatureItem(..)+ , SignatureItemDesc(..)+ , Structure+ , StructureItem(..)+ , StructureItemDesc(..)+ , TypeDeclaration(..)+ , TypeException(..)+ , TypeExtension(..)+ , TypeKind(..)+ , ValueBinding(..)+ , ValueDescription(..)+ , WithConstraint(..)+ , none+ ) where++import GHC.Generics++import Language.OCaml.Definitions.Parsing.ASTTypes hiding (Constant)+import Language.OCaml.Definitions.Parsing.Location+import Language.OCaml.Definitions.Parsing.Longident++data Constant+ = PconstInteger String (Maybe Char)+ | PconstChar Char+ | PconstString String (Maybe String)+ | PconstFloat String (Maybe Char)+ deriving (Eq, Generic, Show)++type Attribute = (Loc String, Payload)+type Extension = (Loc String, Payload)+type Attributes = [Attribute]++data Payload+ = PStr Structure+ | PSig Signature+ | PTyp CoreType+ | PPat Pattern (Maybe Expression)+ deriving (Eq, Generic, Show)++data CoreType = CoreType+ { ptypDesc :: CoreTypeDesc+ , ptypLoc :: Location+ , ptypAttributes :: Attributes+ }+ deriving (Eq, Generic, Show)++data CoreTypeDesc+ = PtypAny+ | PtypVar String+ | PtypArrow ArgLabel CoreType CoreType+ | PtypTuple [CoreType]+ | PtypConstr (Loc Longident) [CoreType]+ | PtypObject [ObjectField] ClosedFlag+ | PtypClass (Loc Longident) [CoreType]+ | PtypAlias CoreType String+ | PtypVariant [RowField] ClosedFlag (Maybe [Label])+ | PtypPoly [Loc String] CoreType+ | PtypPackage PackageType+ | PtypExtension Extension+ deriving (Eq, Generic, Show)++data ConstructorArguments+ = PcstrTuple [CoreType]+ | PcstrRecord [LabelDeclaration]+ deriving (Eq, Generic, Show)++data PrivateFlag+ = Private+ | Public+ deriving (Eq, Generic, Show)++data TypeDeclaration = TypeDeclaration+ { ptypeName :: Loc String+ , ptypeParams :: [(CoreType, Variance)]+ , ptypeCstrs :: [(CoreType, CoreType, Location)]+ , ptypeKind :: TypeKind+ , ptypePrivate :: PrivateFlag+ , ptypeManifest :: Maybe CoreType+ , ptypeAttributes :: Attributes+ , ptypeLoc :: Location+ }+ deriving (Eq, Generic, Show)++data TypeKind+ = PtypeAbstract+ | PtypeVariant [ConstructorDeclaration]+ | PtypeRecord [LabelDeclaration]+ | PtypeOpen+ deriving (Eq, Generic, Show)++data LabelDeclaration = LabelDeclaration+ { pldName :: Loc String+ , pldMutable :: MutableFlag+ , pldType :: CoreType+ , pldLoc :: Location+ , pldAttributes :: Attributes+ }+ deriving (Eq, Generic, Show)++data ConstructorDeclaration = ConstructorDeclaration+ { pcdName :: Loc String+ , pcdArgs :: ConstructorArguments+ , pcdRes :: Maybe CoreType+ , pcdLoc :: Location+ , pcdAttributes :: Attributes+ }+ deriving (Eq, Generic, Show)++data MutableFlag+ = Immutable+ | Mutable+ deriving (Eq, Generic, Show)++type Structure = [StructureItem]++data StructureItem = StructureItem+ { pstrDesc :: StructureItemDesc+ , pstrLoc :: Location+ }+ deriving (Eq, Generic, Show)++data StructureItemDesc+ = PstrEval Expression Attributes+ | PstrValue RecFlag [ValueBinding]+ | PstrPrimitive ValueDescription+ | PstrType RecFlag [TypeDeclaration]+ | PstrTypExt TypeExtension+ | PstrException ExtensionConstructor+ | PstrModule ModuleBinding+ | PstrRecModule [ModuleBinding]+ | PstrModType ModuleTypeDeclaration+ | PstrOpen OpenDescription+ | PstrClass [ClassDeclaration]+ | PstrClassType [ClassTypeDeclaration]+ | PstrInclude IncludeDeclaration+ | PstrAttribute Attribute+ | PstrExtension Extension Attributes+ deriving (Eq, Generic, Show)++data Expression = Expression+ { pexpDesc :: ExpressionDesc+ , pexpLoc :: Location+ , pexpAttributes :: Attributes+ }+ deriving (Eq, Generic, Show)++data ExpressionDesc+ = PexpIdent (Loc Longident)+ | PexpConstant Constant+ | PexpLet RecFlag [ValueBinding] Expression+ | PexpFunction [Case]+ | PexpFun ArgLabel (Maybe Expression) Pattern Expression+ | PexpApply Expression [(ArgLabel, Expression)]+ | PexpMatch Expression [Case]+ | PexpTry Expression [Case]+ | PexpTuple [Expression]+ | PexpConstruct (Loc Longident) (Maybe Expression)+ | PexpVariant Label (Maybe Expression)+ | PexpRecord [(Loc Longident, Expression)] (Maybe Expression)+ | PexpField Expression (Loc Longident)+ | PexpSetField Expression (Loc Longident) Expression+ | PexpArray [Expression]+ | PexpIfThenElse Expression Expression (Maybe Expression)+ | PexpSequence Expression Expression+ | PexpWhile Expression Expression+ | PexpFor Pattern Expression Expression DirectionFlag Expression+ | PexpConstraint Expression CoreType+ | PexpCoerce Expression (Maybe CoreType) CoreType+ | PexpSend Expression (Loc Label)+ | PexpNew (Loc Longident)+ | PexpSetInstVar (Loc Label) Expression+ | PexpOverride [(Loc Label, Expression)]+ | PexpLetModule (Loc String) ModuleExpr Expression+ | PexpLetException ExtensionConstructor Expression+ | PexpAssert Expression+ | PexpLazy Expression+ | PexpPoly Expression (Maybe CoreType)+ | PexpObject ClassStructure+ | PexpNewType (Loc String) Expression+ | PexpPack ModuleExpr+ | PexpOpen OverrideFlag (Loc Longident) Expression+ | PexpExtension Extension+ | PexpUnreachable+ deriving (Eq, Generic, Show)++type Signature = [SignatureItem]++data SignatureItem = SignatureItem+ { psigDesc :: SignatureItemDesc+ , psigLoc :: Location+ }+ deriving (Eq, Generic, Show)++data SignatureItemDesc+ = PsigValue ValueDescription+ -- | PsigType Asttypes.recFlag * typeDeclaration list+ -- | PsigTypext type_extension+ -- | Psig_exception extensionConstructor+ -- | PsigModule moduleDeclaration+ -- | PsigRecmodule moduleDeclaration list+ -- | PsigModtype moduleTypeDeclaration+ -- | Psig_open openDescription+ -- | PsigInclude includeDescription+ -- | PsigClass classDescription list+ -- | PsigClassType classTypeDeclaration list+ -- | PsigAttribute attribute+ -- | Psig_extension extension * attributes+ deriving (Eq, Generic, Show)++data ValueDescription = ValueDescription+ { pvalName :: Loc String+ , pvalType :: CoreType+ , pvalPrim :: [String]+ , pvalAttributes :: Attributes+ , pvalLoc :: Location+ }+ deriving (Eq, Generic, Show)++data Pattern = Pattern+ { ppatDesc :: PatternDesc+ , ppatLoc :: Location+ , ppatAttributes :: Attributes+ }+ deriving (Eq, Generic, Show)++data PatternDesc+ = PpatAny+ | PpatVar (Loc String)+ | PpatAlias Pattern (Loc String)+ | PpatConstant Constant+ | PpatInterval Constant Constant+ | PpatTuple [Pattern]+ | PpatConstruct (Loc Longident) (Maybe Pattern)+ | PpatVariant Label (Maybe Pattern)+ | PpatRecord [(Loc Longident, Pattern)] ClosedFlag+ | PpatArray [Pattern]+ | PpatOr Pattern Pattern+ | PpatConstraint Pattern CoreType+ | PpatType (Loc Longident)+ | PpatLazy Pattern+ | PpatUnpack (Loc String)+ | PpatException Pattern+ | PpatExtension Extension+ | PpatOpen (Loc Longident) Pattern+ deriving (Eq, Generic, Show)++data OpenDescription = OpenDescription+ { popenLid :: Loc Longident+ , popenOverride :: OverrideFlag+ , popenLoc :: Location+ , popenAttributes :: Attributes+ }+ deriving (Eq, Generic, Show)++data ModuleExpr = ModuleExpr+ { pmodDesc :: ModuleExprDesc+ , pmodLoc :: Location+ , pmodAttributes :: Attributes+ }+ deriving (Eq, Generic, Show)++data ModuleExprDesc+ = PmodIdent (Loc Longident)+ | PmodStructure Structure+ | PmodFunctor (Loc String) (Maybe ModuleType) ModuleExpr+ | PmodApply ModuleExpr ModuleExpr+ | PmodConstraint ModuleExpr ModuleType+ | PmodUnpack Expression+ | PmodExtension Extension+ deriving (Eq, Generic, Show)++data ModuleBinding = ModuleBinding+ { pmbName :: Loc String+ , pmbExpr :: ModuleExpr+ , pmbAttributes :: Attributes+ , pmbLoc :: Location+ }+ deriving (Eq, Generic, Show)++data ValueBinding = ValueBinding+ { pvbPat :: Pattern+ , pvbExpr :: Expression+ , pvbAttributes :: Attributes+ , pvbLoc :: Location+ }+ deriving (Eq, Generic, Show)++data Case = Case+ { pcLHS :: Pattern+ , pcGuard :: Maybe Expression+ , pcRHS :: Expression+ }+ deriving (Eq, Generic, Show)++data ExtensionConstructor = ExtensionConstructor+ { pextName :: Loc String+ , pextKind :: ExtensionConstructorKind+ , pextLoc :: Location+ , pextAttributes :: Attributes -- C of ... [@id1] [@id2]+ }+ deriving (Eq, Generic, Show)++data ExtensionConstructorKind+ = PextDecl ConstructorArguments (Maybe CoreType)+ | PextRebind (Loc Longident)+ deriving (Eq, Generic, Show)++data TypeExtension = TypeExtension+ { ptyextPath :: Loc Longident+ , ptyextParams :: [(CoreType, Variance)]+ , ptyextConstructors :: [ExtensionConstructor]+ , ptyextPrivate :: PrivateFlag+ , ptyextAttributes :: Attributes+ }+ deriving (Eq, Generic, Show)++data TypeException = TypeException+ { ptyexnConstructor :: ExtensionConstructor+ , ptyexnAttributes :: Attributes+ }+ deriving (Eq, Generic, Show)++data RowField+ = Rtag (Loc Label) Attributes Bool [CoreType]+ | Rinherit CoreType+ deriving (Eq, Generic, Show)++data ClassStructure = ClassStructure+ { pcstrSelf :: Pattern+ , pcstrFields :: [ClassField]+ }+ deriving (Eq, Generic, Show)++data ClassField = ClassField+ { pcfDesc :: ClassFieldDesc+ , pcfLoc :: Location+ , pcfAttributes :: Attributes+ }+ deriving (Eq, Generic, Show)++data ClassFieldDesc+ = PcfInherit OverrideFlag ClassExpr (Maybe (Loc String))+ | PcfVal (Loc Label) MutableFlag ClassFieldKind+ | PcfMethod (Loc Label) PrivateFlag ClassFieldKind+ | PcfConstraint CoreType CoreType+ | PcfInitializer Expression+ | PcfAttribute Attribute+ | PcfExtension Extension+ deriving (Eq, Generic, Show)++data ClassExpr = ClassExpr+ { pclDesc :: ClassExprDesc+ , pclLoc :: Location+ , pclAttributes :: Attributes+ }+ deriving (Eq, Generic, Show)++data ClassExprDesc+ = PclConstr (Loc Longident) [CoreType]+ | PclStructure ClassStructure+ | PclFun ArgLabel (Maybe Expression) Pattern ClassExpr+ | PclApply ClassExpr [(ArgLabel, Expression)]+ | PclLet RecFlag [ValueBinding] ClassExpr+ | PclConstraint ClassExpr ClassType+ | PclExtension Extension+ | PclOpen OverrideFlag (Loc Longident) ClassExpr+ deriving (Eq, Generic, Show)++data ClassType = ClassType+ { pctyDesc :: ClassTypeDesc+ , pctyLoc :: Location+ , pctyAttributes :: Attributes+ }+ deriving (Eq, Generic, Show)++data ClassTypeDesc+ = PctyConstr (Loc Longident) [CoreType]+ | PctySignature ClassSignature+ | PctyArrow ArgLabel CoreType ClassType+ | PctyExtension Extension+ | PctyOpen OverrideFlag (Loc Longident) ClassType+ deriving (Eq, Generic, Show)++data ClassSignature = ClassSignature+ { pcsigSelf :: CoreType+ , pcsigFields :: [ClassTypeField]+ }+ deriving (Eq, Generic, Show)++data ClassTypeField = ClassTypeField+ { pctfDesc :: ClassTypeFieldDesc+ , pctfLoc :: Location+ , pctfAttributes :: Attributes+ }+ deriving (Eq, Generic, Show)++data ClassTypeFieldDesc+ = PctfInherit ClassType+ | PctfVal (Loc Label) MutableFlag VirtualFlag CoreType+ | PtfMethod (Loc Label) PrivateFlag VirtualFlag CoreType+ | PctfConstraint CoreType CoreType+ | PctfAttribute Attribute+ | PctfExtension Extension+ deriving (Eq, Generic, Show)++data ClassFieldKind+ = CfkVirtual CoreType+ | CfkConcrete OverrideFlag Expression+ deriving (Eq, Generic, Show)++data ObjectField+ = Otag (Loc Label) Attributes CoreType+ | Oinherit CoreType+ deriving (Eq, Generic, Show)++data ModuleType = ModuleType+ { pmtyDesc :: ModuleTypeDesc+ , pmtyLoc :: Location+ , pmtyAttributes :: Attributes+ }+ deriving (Eq, Generic, Show)++data ModuleTypeDesc+ = PmtyIdent (Loc Longident)+ | PmtySignature Signature+ | PmtyFunctor (Loc String) (Maybe ModuleType) ModuleType+ | PmtyWith ModuleType [WithConstraint]+ | PmtyTypeOf ModuleExpr+ | PmtyExtension Extension+ | PmtyAlias (Loc Longident)+ deriving (Eq, Generic, Show)++data ModuleTypeDeclaration = ModuleTypeDeclaration+ { pmtdName :: Loc String+ , pmtdType :: Maybe ModuleType+ , pmtdAttributes :: Attributes+ , pmtdLoc :: Location+ }+ deriving (Eq, Generic, Show)++data WithConstraint+ = PwithType (Loc Longident) TypeDeclaration+ | PwithModule (Loc Longident) (Loc Longident)+ | PwithTypeSubst (Loc Longident) TypeDeclaration+ | PwithModSubst (Loc Longident) (Loc Longident)+ deriving (Eq, Generic, Show)++type PackageType = (Loc Longident, [(Loc Longident, CoreType)])++data ClassInfos a = ClassInfos+ { pciVirt :: VirtualFlag+ , pciParams :: [(CoreType, Variance)]+ , pciName :: Loc String+ , pciExpr :: a+ , pciLoc :: Location+ }+ deriving (Eq, Generic, Show)++type ClassDeclaration = ClassInfos ClassExpr++type ClassTypeDeclaration = ClassInfos ClassType++data IncludeInfos a = IncludeInfos+ { pinclMod :: a+ , pinclLoc :: Location+ , pinclAttributes :: Attributes+ }+ deriving (Eq, Generic, Show)++type IncludeDeclaration = IncludeInfos ModuleExpr
+ lib/Language/OCaml/Definitions/Parsing/Parser/LetBinding.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DeriveGeneric #-}++module Language.OCaml.Definitions.Parsing.Parser.LetBinding+ ( LetBinding(..)+ ) where++import GHC.Generics++import Language.OCaml.Definitions.Parsing.Docstrings+import Language.OCaml.Definitions.Parsing.Location+import Language.OCaml.Definitions.Parsing.ParseTree++data LetBinding = LetBinding+ { lbPattern :: Pattern+ , lbExpression :: Expression+ , lbAttributes :: Attributes+ , lbDocs :: Docs+ , lbText :: Text+ , lbLoc :: Location+ }+ deriving (Eq, Generic, Show)
+ lib/Language/OCaml/Definitions/Parsing/Parser/LetBindings.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE DeriveGeneric #-}++module Language.OCaml.Definitions.Parsing.Parser.LetBindings+ ( LetBindings(..)+ ) where++import GHC.Generics++import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.Location+import Language.OCaml.Definitions.Parsing.Parser.LetBinding++data LetBindings = LetBindings+ { lbsBindings :: [LetBinding]+ , lbsRec :: RecFlag+ , lbsExtension :: Maybe (Loc String)+ , lbsLoc :: Location+ }+ deriving (Eq, Generic, Show)
+ lib/Language/OCaml/Definitions/StdLib/Lexing.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE DeriveGeneric #-}++module Language.OCaml.Definitions.StdLib.Lexing+ ( Position(..)+ ) where++import GHC.Generics++data Position = Position+ { posFName :: String+ , posLNum :: Int+ , posBOL :: Int+ , posCNum :: Int+ }+ deriving (Eq, Generic, Show)++instance Ord Position where+ p1 <= p2 = posLNum p1 <= posLNum p2 || (posLNum p1 == posLNum p2 && posCNum p1 <= posCNum p2)
+ lib/Language/OCaml/Definitions/StdLib/Parsing.hs view
@@ -0,0 +1,26 @@+module Language.OCaml.Definitions.StdLib.Parsing+ ( rhsEndPos+ , rhsStart+ , rhsStartPos+ ) where++import Language.OCaml.Definitions.StdLib.Lexing++rhsEndPos :: a -> Position+rhsEndPos _ = Position+ { posFName = "FIXME"+ , posLNum = 0+ , posBOL = 0+ , posCNum = 0+ }++rhsStartPos :: a -> Position+rhsStartPos _ = Position+ { posFName = "FIXME"+ , posLNum = 0+ , posBOL = 0+ , posCNum = 0+ }++rhsStart :: a -> Int+rhsStart _ = 0 -- FIXME
+ lib/Language/OCaml/Parser.hs view
@@ -0,0 +1,27 @@+module Language.OCaml.Parser+ ( ParserC+ , ParserG+ , implementationP+ , parseImplementationC+ , parseImplementationG+ ) where++import Data.Void+import Text.Megaparsec (parse)+import Text.Megaparsec.Error++import Language.OCaml.Definitions.Parsing.ParseTree+-- import qualified Language.OCaml.Parser.Generator.Lexer as GL+import qualified Language.OCaml.Parser.Generator.Parser as GP+import Language.OCaml.Parser.Implementation+import Language.OCaml.Parser.Utils.Types++type ParserC a = Parser a++type ParserG a = GP.Parser a++parseImplementationC :: String -> Either (ParseError Char Void) Structure+parseImplementationC = parse implementationP "Language.OCaml.Parser"++parseImplementationG :: GP.Parser [StructureItem]+parseImplementationG = GP.parseImplementation
+ lib/Language/OCaml/Parser/AndTypeDeclaration.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}++module Language.OCaml.Parser.AndTypeDeclaration+ ( andTypeDeclarationP+ ) where++import Data.Default+import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ASTHelper.Type as Type+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.TypeKind+import Language.OCaml.Parser.PostItemAttributes+import Language.OCaml.Parser.Utils.Types++andTypeDeclarationP :: Parser Structure -> Parser TypeDeclaration+andTypeDeclarationP structureP = do+ try $ andT+ -- TODO: attributes+ -- TODO: optionalTypeParameters+ i <- lIdentT+ (kind, priv, manifest) <- typeKindP structureP+ -- TODO: constraints+ attrs <- postItemAttributesP structureP -- FIXME: use me+ return $ Type.mk (def { attrs, kind, priv }) manifest (mkRHS i 4) -- FIXME: [] and []
+ lib/Language/OCaml/Parser/AttrId.hs view
@@ -0,0 +1,21 @@+module Language.OCaml.Parser.AttrId+ ( attrIdP+ ) where++import Text.Megaparsec++import qualified Language.OCaml.Definitions.Parsing.ASTTypes as ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.SingleAttrId+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++attrIdP :: Parser (ASTTypes.Loc String)+attrIdP = choice+ [ do+ a <- try $ singleAttrIdP <* dotT+ b <- attrIdP+ return $ mkLoc (a ++ "^" ++ ASTTypes.txt b) none -- FIXME symbolRLoc+ , singleAttrIdP >>= \ a -> return $ mkLoc a none -- FIXME symbolRLoc+ ]
+ lib/Language/OCaml/Parser/Attribute.hs view
@@ -0,0 +1,21 @@+module Language.OCaml.Parser.Attribute+ ( attributeP+ ) where++import Text.Megaparsec++import qualified Language.OCaml.Definitions.Parsing.ASTTypes as ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.AttrId+import Language.OCaml.Parser.Payload+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++attributeP :: Parser Structure -> Parser (ASTTypes.Loc String, Payload)+attributeP structureP = do+ i <- try $ do+ lBracketAtT+ attrIdP+ p <- payloadP structureP+ rBracketT+ return (i, p)
+ lib/Language/OCaml/Parser/Attributes.hs view
@@ -0,0 +1,13 @@+module Language.OCaml.Parser.Attributes+ ( attributesP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Attribute+import Language.OCaml.Parser.Utils.Types++attributesP :: Parser Structure -> Parser [(Loc String, Payload)]+attributesP structureP = many (attributeP structureP)
+ lib/Language/OCaml/Parser/BarConstructorDeclaration.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}++module Language.OCaml.Parser.BarConstructorDeclaration+ ( barConstructorDeclarationP+ ) where++import Data.Default+import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ASTHelper.Type as Type+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Attributes+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.ConstrIdent+import Language.OCaml.Parser.GeneralizedConstructorArguments+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++barConstructorDeclarationP ::+ Parser Structure -> Parser CoreType -> Parser ConstructorDeclaration+barConstructorDeclarationP structureP coreTypeP = try $ do+ barT+ i <- constrIdentP+ (args, res) <- generalizedConstructorArgumentsP coreTypeP+ attrs <- attributesP structureP+ return $ Type.constructor (def { args, attrs }) res (mkRHS i (2 :: Int))
+ lib/Language/OCaml/Parser/Common.hs view
@@ -0,0 +1,376 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}++module Language.OCaml.Parser.Common+ ( addlb+ , expOfLabel+ , exprOfLetBindings+ , extraRHSCoreType+ , extraStr+ , extraText+ , ghexp+ , ghtyp+ , ghpat+ , identP+ , mkexp+ , mkexpAttrs+ , mkexpCons+ , mkexpConstraint+ , mkexpOptConstraint+ , mkOperator+ , mkpatOptConstraint+ , mkinfix+ , mkLoc+ , mklb+ , mklbs+ , mkmod+ , mkmty+ , mkNewTypes+ , mkpat+ , mkpatAttrs+ , mkpatCons+ , mkpatvar+ , mkRHS+ , mkstr+ , mkstrExt+ , mkstrexp+ , mktailexp+ , mktailpat+ , mktyp+ , packageTypeOfModuleType+ , patOfLabel+ , relocExp+ , relocPat+ , rhsLoc+ , symbolDocs+ , symbolRLoc+ , textStr+ , valOfLetBindings+ , wrapExpAttrs+ , wrapTypeAnnotation+ ) where++import Control.Eff+import Control.Eff.Exception+import Data.Default+import Data.Maybe+import Prelude hiding (exp)+import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ASTHelper.Exp as Exp hiding (newType)+import Language.OCaml.Definitions.Parsing.ASTHelper.Mod as Mod+import Language.OCaml.Definitions.Parsing.ASTHelper.Mty as Mty+import Language.OCaml.Definitions.Parsing.ASTHelper.Pat as Pat+import Language.OCaml.Definitions.Parsing.ASTHelper.Str as Str hiding (text)+import qualified Language.OCaml.Definitions.Parsing.ASTHelper.Str as Str (text)+import Language.OCaml.Definitions.Parsing.ASTHelper.Typ as Typ+import Language.OCaml.Definitions.Parsing.ASTHelper.Vb as Vb+import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.Docstrings+import Language.OCaml.Definitions.Parsing.Location+import Language.OCaml.Definitions.Parsing.Longident as Longident+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Definitions.Parsing.Parser.LetBinding+import Language.OCaml.Definitions.Parsing.Parser.LetBindings+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Utils+import Language.OCaml.Parser.Utils.Types++identP :: Parser String+identP = lexeme $ choice [ uIdentT, lIdentT ]++mkstr :: StructureItemDesc -> StructureItem+mkstr d = Str.mk def d -- FIXME: symbolRLoc++ghstr :: StructureItemDesc -> StructureItem+ghstr d = Str.mk def d -- FIXME: symbol_gloc++wrapStrExt :: StructureItem -> Maybe (Loc String) -> StructureItem+wrapStrExt body ext = case ext of+ Nothing -> body+ Just i -> ghstr $ PstrExtension (i, PStr [body]) []++mkstrExt :: StructureItemDesc -> Maybe (Loc String) -> StructureItem+mkstrExt d ext = wrapStrExt (mkstr d) ext++mkstrexp :: Expression -> Attributes -> StructureItem+mkstrexp e attrs = StructureItem+ { pstrDesc = PstrEval e attrs+ , pstrLoc = pexpLoc e+ }++mkLoc :: a -> Location -> Loc a+mkLoc t l = Loc+ { txt = t+ , loc = l+ }++rhsLoc :: Int -> Location+rhsLoc _ = none -- FIXME++mkRHS :: a -> Int -> Loc a+mkRHS rhs pos = mkLoc rhs (rhsLoc pos)++mkmod :: Maybe [Attribute] -> ModuleExprDesc -> ModuleExpr+mkmod attrs' d =+ Mod.mk (def { loc = symbolRLoc ()+ , attrs = fromMaybe (Mod.attrs def) attrs'+ }+ ) d++mkpat :: PatternDesc -> Pattern+mkpat d = Pat.mk def d -- FIXME++mkpatvar :: String -> Int -> Pattern+mkpatvar name pos = Pat.mk (def { loc = rhsLoc pos }) (PpatVar (mkRHS name pos))++mkpatCons :: Location -> Pattern -> Location -> Pattern+mkpatCons consloc args loc =+ Pat.mk (def { loc }) (PpatConstruct (mkLoc (Lident "::") consloc) (Just args))++mklb :: t -> (Pattern, Expression) -> Attributes -> LetBinding+mklb _first (p, e) attrs = LetBinding+ { lbPattern = p+ , lbExpression = e+ , lbAttributes = attrs+ , lbDocs = emptyDocs -- symbolDocs_lazy ()+ , lbText = [] --if first then empty_text_lazy+ --else symbol_text_lazy ()+ , lbLoc = none -- symbolRLoc ()+ }++mklbs :: Maybe (Loc String) -> RecFlag -> LetBinding -> LetBindings+mklbs ext rf lb = LetBindings+ { lbsBindings = [lb]+ , lbsRec = rf+ , lbsExtension = ext+ , lbsLoc = none -- symbolRLoc ()+ }++addlb :: LetBindings -> LetBinding -> LetBindings+addlb lbs lb =+ lbs { lbsBindings = lb : lbsBindings lbs }++valOfLetBindings :: LetBindings -> StructureItem+valOfLetBindings lbs =+ let bindings =+ map+ (\ lb -> Vb.mk+ (def { loc = lbLoc lb+ , attrs = lbAttributes lb+ , docs = lbDocs lb+ , Vb.text = lbText lb -- weird, DisambiguateRecordFields should know?+ }+ )+ (lbPattern lb)+ (lbExpression lb)+ )+ (lbsBindings lbs)+ in+ let str = mkstr $ PstrValue (lbsRec lbs) (reverse bindings) in+ case lbsExtension lbs of+ Nothing -> str+ Just i -> ghstr $ PstrExtension (i, PStr [str]) []++exprOfLetBindings :: LetBindings -> Expression -> Expression+exprOfLetBindings lbs body =+ let bindings =+ map+ (\ lb -> Vb.mk+ (def { loc = lbLoc lb+ , attrs = lbAttributes lb+ }+ )+ (lbPattern lb)+ (lbExpression lb)+ )+ (lbsBindings lbs)+ in+ mkexpAttrs (PexpLet (lbsRec lbs) (reverse bindings) body) (lbsExtension lbs, [])++wrapExpAttrs :: Expression -> (Maybe (Loc String), [Attribute]) -> Expression+wrapExpAttrs body (ext, attrs) =+ let body1 = body { pexpAttributes = attrs ++ pexpAttributes body } in+ case ext of+ Nothing -> body1+ Just i -> ghexp $ PexpExtension (i, (PStr [mkstrexp body1 []]))++mkexpAttrs :: ExpressionDesc -> (Maybe (Loc String), [Attribute]) -> Expression+mkexpAttrs d attrs = wrapExpAttrs (mkexp d) attrs++mkexp :: ExpressionDesc -> Expression+mkexp d = Exp.mk def d -- FIXME++mktyp :: CoreTypeDesc -> CoreType+mktyp d = Typ.mk def d -- FIXME++ghexp :: ExpressionDesc -> Expression+ghexp d = Exp.mk def d -- FIXME++ghpat :: PatternDesc -> Pattern+ghpat d = Pat.mk def d -- FIXME++ghtyp :: CoreTypeDesc -> CoreType+ghtyp d = Typ.mk def d -- FIXME++mkexpConstraint :: Expression -> (Maybe CoreType, Maybe CoreType) -> Expression+mkexpConstraint e (t1, t2) = case (t1, t2) of+ (Just t, Nothing) -> ghexp $ PexpConstraint e t+ (_, Just t) -> ghexp $ PexpCoerce e t1 t+ (Nothing, Nothing) -> error "This should not happen"++relocExp :: Expression -> Expression+relocExp e = e { pexpLoc = none } -- FIXME++extraRHSCoreType :: CoreType -> a -> CoreType+extraRHSCoreType ct _pos =+ -- FIXME+ -- let docs = rhsInfo pos in+ ct -- { ptypAttributes = addInfoAttrs docs (ptypAttributes ct) }++symbolRLoc :: () -> Location+symbolRLoc () = none -- FIXME++relocPat :: Pattern -> Pattern+relocPat e = e { ppatLoc = symbolRLoc () }++mkinfix :: Expression -> String -> Expression -> Expression+mkinfix arg1 name arg2 =+ mkexp $ PexpApply (mkoperator name 2) [(Nolabel, arg1), (Nolabel, arg2)]++mkoperator :: String -> Int -> Expression+mkoperator name pos =+ let loc = rhsLoc pos in+ Exp.mk (def { loc }) $ PexpIdent (mkLoc (Lident name) loc)++mktailexp :: Location -> [Expression] -> Expression+mktailexp nilloc = \case+ [] ->+ let loc = nilloc { locGhost = True } in+ let nil = Loc { txt = Lident "[]", loc } in+ Exp.mk (def { loc }) $ PexpConstruct nil Nothing+ e1 : el ->+ let expEl = mktailexp nilloc el in+ let loc = Location+ { locStart = locStart . pexpLoc $ e1+ , locEnd = locEnd . pexpLoc $ e1+ , locGhost = True+ }+ in+ let arg = Exp.mk (def { loc }) $ PexpTuple [e1, expEl] in+ mkexpCons (loc {locGhost = True}) arg loc++mkexpOptConstraint :: Expression -> Maybe (Maybe CoreType, Maybe CoreType) -> Expression+mkexpOptConstraint e = \case+ Nothing -> e+ Just constraint' -> mkexpConstraint e constraint'++mkpatOptConstraint :: Pattern -> Maybe CoreType -> Pattern+mkpatOptConstraint p = \case+ Nothing -> p+ Just typ -> mkpat (PpatConstraint p typ)++patOfLabel :: Longident -> Int -> Pattern+patOfLabel lbl pos = mkpat $ PpatVar $ mkRHS (Longident.last lbl) pos++mktailpat :: Location -> [Pattern] -> Pattern+mktailpat nilloc = \case+ [] ->+ let loc = nilloc { locGhost = True } in+ let nil = Loc { txt = Lident "[]", loc } in+ Pat.mk (def { loc }) $ PpatConstruct nil Nothing+ p1 : pl ->+ let patPl = mktailpat nilloc pl in+ let loc = Location+ { locStart = locStart $ ppatLoc p1+ , locEnd = locEnd $ ppatLoc patPl+ , locGhost = True+ }+ in+ let arg = Pat.mk (def { loc }) $ PpatTuple [p1, patPl] in+ mkpatCons (loc { locGhost = True }) arg loc++symbolDocs :: () -> Docs+symbolDocs () = emptyDocs -- FIXME++textStr :: Int -> [StructureItem]+textStr pos = Str.text (rhsText pos)++extraText :: (Text -> [a]) -> p -> [a] -> [a]+extraText text pos [] = let post = rhsPostText pos in+ let postExtras = rhsPostExtraText pos in+ text post ++ text postExtras+extraText text pos items = let preExtras = rhsPreExtraText pos in+ let postExtras = rhsPostExtraText pos in+ text preExtras ++ items ++ text postExtras++extraStr :: p -> [StructureItem] -> [StructureItem]+extraStr pos items = extraText Str.text pos items++mkNewTypes :: [Loc String] -> Expression -> Expression+mkNewTypes =+ flip $ foldr (\ newType exp -> mkexp $ PexpNewType newType exp)++wrapTypeAnnotation :: [Loc String] -> CoreType -> Expression -> (Expression, CoreType)+wrapTypeAnnotation newTypes coreType body =+ let exp1 = mkexp $ PexpConstraint body coreType in+ let exp2 = mkNewTypes newTypes exp1 in+ -- handling side-effects locally for now+ let varC = case run . runError $ Typ.varifyConstructors newTypes coreType of+ Left e -> error e+ Right r -> r+ in+ (exp2, ghtyp $ PtypPoly newTypes varC)++mkmty :: AttrsOpts -> ModuleTypeDesc -> ModuleType+mkmty (AttrsOpts {..}) d = Mty.mk (def { Mty.attrs = attrs, loc = symbolRLoc () }) d++data AttrsOpts = AttrsOpts { attrs :: Attributes }++instance Default AttrsOpts where+ def = AttrsOpts []++packageTypeOfModuleType :: ModuleType -> PackageType+packageTypeOfModuleType (ModuleType { pmtyDesc = PmtyIdent lid }) = (lid, [])+packageTypeOfModuleType (ModuleType { pmtyDesc = PmtyWith (ModuleType { pmtyDesc = PmtyIdent lid }) cstrs}) =+ (lid, map mapCstr cstrs)+ where+ mapCstr :: WithConstraint -> (Loc Longident, CoreType)+ mapCstr = \case+ PwithType lid' ptyp ->+ case ptyp of+ TypeDeclaration { ptypeParams = [] } -> error "TODO"+ TypeDeclaration { ptypeCstrs = [] } -> error "TODO"+ TypeDeclaration { ptypePrivate } | ptypePrivate /= Public -> error "TODO"+ TypeDeclaration { ptypeKind } | ptypeKind /= PtypeAbstract -> error "TODO"+ TypeDeclaration { ptypeAttributes } | ptypeAttributes /= [] -> error "TODO"+ TypeDeclaration { ptypeManifest } -> case ptypeManifest of+ Just ty -> (lid', ty)+ Nothing -> error "This should not happen"+ _ -> error "Only 'with type t =' constraints are supported"+packageTypeOfModuleType _ = error "TODO"++mkpatAttrs :: PatternDesc -> (Maybe (Loc String), [Attribute]) -> Pattern+mkpatAttrs d attrs = wrapPatAttrs (mkpat d) attrs++wrapPatAttrs :: Pattern -> (Maybe (Loc String), [Attribute]) -> Pattern+wrapPatAttrs pat0 (ext, attrs) =+ let pat = pat0 { ppatAttributes = attrs ++ ppatAttributes pat0 } in+ case ext of+ Nothing -> pat+ Just id' -> ghpat $ PpatExtension (id', PPat pat Nothing)++mkexpCons :: Location -> Expression -> Location -> Expression+mkexpCons consLoc args loc =+ Exp.mk (def { loc }) $ PexpConstruct (mkLoc (Lident "::") consLoc) (Just args)++expOfLabel :: Longident -> Int -> Expression+expOfLabel lbl pos = mkexp $ PexpIdent (mkRHS (Lident (Longident.last lbl)) pos)++mkOperator :: String -> Int -> Expression+mkOperator name pos =+ let loc = rhsLoc pos in+ Exp.mk (def { loc }) $ PexpIdent (mkLoc (Lident name) loc)
+ lib/Language/OCaml/Parser/Constant.hs view
@@ -0,0 +1,23 @@+module Language.OCaml.Parser.Constant+ ( constantP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++constantP :: Parser Constant+constantP = choice+ [ do+ (n, m) <- intT+ return $ PconstInteger n m+ , PconstChar <$> charT+ , do+ (s, d) <- stringT+ return $ PconstString s d+ -- , do+ -- (f, m) <- stringT+ -- return $ PconstFloat f m+ ]
+ lib/Language/OCaml/Parser/ConstrIdent.hs view
@@ -0,0 +1,18 @@+module Language.OCaml.Parser.ConstrIdent+ ( constrIdentP+ ) where++import Text.Megaparsec++import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++constrIdentP :: Parser String+constrIdentP = choice+ [ uIdentT+ , lBracketT *> rBracketT *> return "[]"+ , lParenT *> rParenT *> return "()"+ , lParenT *> colonColonT *> rParenT *> return "::"+ , falseT *> return "false"+ , trueT *> return "true"+ ]
+ lib/Language/OCaml/Parser/ConstrLongident.hs view
@@ -0,0 +1,28 @@+module Language.OCaml.Parser.ConstrLongident+ ( constrLongidentP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.ModLongident+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types+import Language.OCaml.Parser.Utils.Utils++constrLongidentP :: Parser Longident+constrLongidentP = choice+ [ do+ i <- try $ do+ i <- modLongidentP+ dotT+ return i+ parens colonColonT+ return $ Ldot i "::"+ , modLongidentP+ , try $ lBracketT *> rBracketT *> (return $ Lident "[]")+ , try $ lParenT *> rParenT *> (return $ Lident "()")+ , try (lParenT *> colonColonT) *> rParenT *> (return $ Lident "::")+ , falseT *> (return $ Lident "false")+ , trueT *> (return $ Lident "true")+ ]
+ lib/Language/OCaml/Parser/ConstructorArguments.hs view
@@ -0,0 +1,15 @@+module Language.OCaml.Parser.ConstructorArguments+ ( constructorArgumentsP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.CoreTypeList+import Language.OCaml.Parser.Utils.Types++constructorArgumentsP :: Parser CoreType -> Parser ConstructorArguments+constructorArgumentsP coreTypeP = choice+ [ PcstrTuple . reverse <$> coreTypelistP coreTypeP+ -- TODO: label declarations+ ]
+ lib/Language/OCaml/Parser/ConstructorDeclaration.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}++module Language.OCaml.Parser.ConstructorDeclaration+ ( constructorDeclarationP+ ) where++import Data.Default++import Language.OCaml.Definitions.Parsing.ASTHelper.Type as Type+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Attributes+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.ConstrIdent+import Language.OCaml.Parser.GeneralizedConstructorArguments+import Language.OCaml.Parser.Utils.Types++constructorDeclarationP ::+ Parser Structure -> Parser CoreType -> Parser ConstructorDeclaration+constructorDeclarationP structureP coreTypeP = do+ name <- constrIdentP+ (args, res) <- generalizedConstructorArgumentsP coreTypeP+ attrs <- attributesP structureP+ return $ Type.constructor (def { args, attrs }) res (mkRHS name (1 :: Int))
+ lib/Language/OCaml/Parser/ConstructorDeclarations.hs view
@@ -0,0 +1,23 @@+module Language.OCaml.Parser.ConstructorDeclarations+ ( constructorDeclarationsP+ ) where++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.BarConstructorDeclaration+import Language.OCaml.Parser.ConstructorDeclaration+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Combinators+import Language.OCaml.Parser.Utils.Types++constructorDeclarationsP ::+ Parser Structure -> Parser CoreType -> Parser [ConstructorDeclaration]+constructorDeclarationsP structureP coreTypeP = leftRecursive+ [ (: []) <$> constructorDeclarationP'+ , (: []) <$> barConstructorDeclarationP'+ , barT *> return []+ ]+ [ (:) <$> barConstructorDeclarationP'+ ]+ where+ constructorDeclarationP' = constructorDeclarationP structureP coreTypeP+ barConstructorDeclarationP' = barConstructorDeclarationP structureP coreTypeP
+ lib/Language/OCaml/Parser/CoreType.hs view
@@ -0,0 +1,18 @@+module Language.OCaml.Parser.CoreType+ ( coreTypeP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.CoreTypeNoAttr+import Language.OCaml.Parser.Utils.Types++coreTypeP :: Parser CoreType+coreTypeP = choice+ [ coreTypenoAttrP coreTypeP+ -- , do+ -- t <- coreType+ -- a <- attribute+ -- return $ attr t a+ ]
+ lib/Language/OCaml/Parser/CoreType2.hs view
@@ -0,0 +1,26 @@+module Language.OCaml.Parser.CoreType2+ ( coreType2P+ ) where++import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.SimpleCoreTypeOrTuple+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Combinators+import Language.OCaml.Parser.Utils.Types++coreType2P :: Parser CoreType -> Parser CoreType+coreType2P coreTypeP = leftRecursive+ [ simpleCoreTypeOrTupleP coreTypeP+ -- TODO+ ]+ [ do+ minusGreaterT+ t2 <- coreType2P'+ return $ \ t1 ->+ let param = extraRHSCoreType t1 (1 :: Int) in+ mktyp $ PtypArrow Nolabel param t2+ ]+ where+ coreType2P' = coreType2P coreTypeP
+ lib/Language/OCaml/Parser/CoreTypeCommaList.hs view
@@ -0,0 +1,12 @@+module Language.OCaml.Parser.CoreTypeCommaList+ ( coreTypeCommaListP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++coreTypeCommaListP :: Parser CoreType -> Parser [CoreType]+coreTypeCommaListP coreTypeP = sepBy coreTypeP commaT
+ lib/Language/OCaml/Parser/CoreTypeList.hs view
@@ -0,0 +1,21 @@+module Language.OCaml.Parser.CoreTypeList+ ( coreTypelistP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.SimpleCoreType+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Combinators+import Language.OCaml.Parser.Utils.Types++coreTypelistP :: Parser CoreType -> Parser [CoreType]+coreTypelistP coreTypeP = leftRecursive+ [ (: []) <$> simpleCoreTypeP coreTypeP+ ]+ [ do+ try $ starT+ t <- simpleCoreTypeP coreTypeP+ return $ (:) t+ ]
+ lib/Language/OCaml/Parser/CoreTypeNoAttr.hs view
@@ -0,0 +1,15 @@+module Language.OCaml.Parser.CoreTypeNoAttr+ ( coreTypenoAttrP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.CoreType2+import Language.OCaml.Parser.Utils.Types++coreTypenoAttrP :: Parser CoreType -> Parser CoreType+coreTypenoAttrP coreTypeP = choice+ [ coreType2P coreTypeP+ -- , TODO+ ]
+ lib/Language/OCaml/Parser/Expr.hs view
@@ -0,0 +1,99 @@+module Language.OCaml.Parser.Expr+ ( exprP+ ) where++import Text.Megaparsec hiding (token)++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.FunDef+import Language.OCaml.Parser.LabeledSimplePattern+import Language.OCaml.Parser.LetBindings+import Language.OCaml.Parser.MatchCases+import Language.OCaml.Parser.OptBar+import Language.OCaml.Parser.Pattern+import Language.OCaml.Parser.SimpleLabeledExprList+import Language.OCaml.Parser.SimpleExpr+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Combinators+import Language.OCaml.Parser.Utils.Types+import Language.OCaml.PrettyPrinter ()++exprP :: Parser Structure -> Parser Expression -> Parser Expression+exprP structureP seqExprP = choice+ [ try $ parser <* notFollowedBy commaT+ , mkexp . PexpTuple . reverse <$>+ chainl1' parser (commaT *> (return $ flip (:))) (: [])+ ]+ where+ parser = leftRecursive+ [ try $ do+ e <- simpleExprP'+ l <- simpleLabeledExprListP'+ return $ mkexp $ PexpApply e (reverse l)+ , do+ b <- try $ do+ b <- letBindingsP structureP seqExprP+ inT+ return b+ e <- seqExprP+ return $ exprOfLetBindings b e+ -- FUNCTION+ , do+ try $ functionT+ -- TODO: extAttributes+ optBarP+ l <- matchCasesP'+ return $ mkexpAttrs (PexpFunction $ reverse l) (Nothing, []) -- FIXME+ -- FUN+ , do+ try $ funT+ -- TODO: extAttributes+ (l, o, p) <- labeledSimplePatternP patternP+ d <- funDefP seqExprP+ return $ mkexpAttrs (PexpFun l o p d) (Nothing, []) -- FIXME+ -- MATCH+ , do+ try $ matchT+ -- TODO: extAttributes+ e <- seqExprP+ withT+ optBarP+ l <- matchCasesP'+ return $ mkexpAttrs (PexpMatch e $ reverse l) (Nothing, []) -- FIXME+ -- IF ... THEN ... ELSE ...+ , do+ try ifT+ -- TODO: extAttributes+ c <- seqExprP+ thenT+ t <- exprP'+ e <- choice+ [ do+ try elseT+ Just <$> exprP'+ , return Nothing+ ]+ return $ mkexpAttrs (PexpIfThenElse c t e) (Nothing, []) -- FIXME+ , simpleExprP'+ ]+ -- FIXME: deal with associativity?+ [ infixP equalT "="+ , infixP plusT "+"+ , infixP minusT "-"+ , infixP starT "*"+ , infixP caretT "^"+ , infixP greaterT ">"+ , infixP atT "@"+ ]++ infixP :: Parser () -> String -> Parser (Expression -> Expression)+ infixP token symbol = try $ do+ token+ e2 <- exprP'+ return $ \ e1 -> mkinfix e1 symbol e2++ exprP' = exprP structureP seqExprP+ simpleExprP' = simpleExprP seqExprP exprP'+ simpleLabeledExprListP' = simpleLabeledExprListP seqExprP exprP'+ matchCasesP' = matchCasesP seqExprP
+ lib/Language/OCaml/Parser/ExprSemiList.hs view
@@ -0,0 +1,18 @@+module Language.OCaml.Parser.ExprSemiList+ ( exprSemiListP+ ) where++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Combinators+import Language.OCaml.Parser.Utils.Types++exprSemiListP :: Parser Expression -> Parser [Expression]+exprSemiListP exprP = leftRecursive+ [ (: []) <$> exprP+ ]+ [ do+ semiT+ e2 <- exprP+ return $ \ e1 -> e2 : e1+ ]
+ lib/Language/OCaml/Parser/FunBinding.hs view
@@ -0,0 +1,22 @@+module Language.OCaml.Parser.FunBinding+ ( funBindingP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.TypeConstraint+import Language.OCaml.Parser.StrictBinding+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++funBindingP :: Parser Expression -> Parser Expression+funBindingP seqExprP = choice+ [ strictBindingP seqExprP (funBindingP seqExprP)+ , do+ c <- typeConstraintP+ equalT+ e <- seqExprP+ return $ mkexpConstraint e c+ ]
+ lib/Language/OCaml/Parser/FunDef.hs view
@@ -0,0 +1,27 @@+module Language.OCaml.Parser.FunDef+ ( funDefP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.LabeledSimplePattern+import Language.OCaml.Parser.Pattern+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types+import Language.OCaml.PrettyPrinter ()++funDefP :: Parser Expression -> Parser Expression+funDefP seqExprP = choice+ [ do+ minusGreaterT+ seqExprP+ -- TODO+ , do+ (l, o, p) <- labeledSimplePatternP patternP+ d <- funDefP'+ return $ ghexp $ PexpFun l o p d+ ]+ where+ funDefP' = funDefP seqExprP
+ lib/Language/OCaml/Parser/GeneralizedConstructorArguments.hs view
@@ -0,0 +1,17 @@+module Language.OCaml.Parser.GeneralizedConstructorArguments+ ( generalizedConstructorArgumentsP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.ConstructorArguments+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++generalizedConstructorArgumentsP :: Parser CoreType -> Parser (ConstructorArguments, Maybe a)+generalizedConstructorArgumentsP coreTypeP = choice+ [ flip (,) Nothing <$> (ofT *> constructorArgumentsP coreTypeP)+ -- TODO: colon+ , return (PcstrTuple [], Nothing)+ ]
+ lib/Language/OCaml/Parser/Generator/Lexer.x view
@@ -0,0 +1,653 @@+{++{-# OPTIONS_GHC -w #-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+-- {-# LANGUAGE TemplateHaskell #-}++module Language.OCaml.Parser.Generator.Lexer+ ( Alex(..)+ , IntermediateToken+ , Located(..)+ , ResultToken+ , SrcSpan(..)+ , Token(..)+ , alexError+ , alexScanTokens+ , lexWrap+ , runAlex+ ) where++import Control.Lens hiding (none)+import Control.Lens.TH+import Control.Monad.State+import qualified Data.Map.Strict as M+import GHC.Generics+import Text.Printf++import Language.OCaml.Definitions.Parsing.Location+import Language.OCaml.Utils++}++%wrapper "monadUserState"++-- Character set macros+$blank = [\ \t \f]+$identChar = [A-Z a-z _ '\'' 0-9]+$lowerCase = [a-z _]+$symbolChar = [!]-- '$' '%']-- '&' '*' '+' '-' '.' ] -- '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']+$upperCase = [A-Z]++-- Regular expression macros+@binLiteral = 0 [bB] [01] [01_]*+@decimalLiteral = [0-9] [0-9 _]*+@floatLiteral = [0-9] [0-9 _]* (\. [0-9 _]*)? ([eE] [\+\-]? [0-9] [0-9 _]*)?+@hexFloatLiteral = 0 [xX] [0-9 A-F a-f] [0-9 A-F a-f _]* (\. [0-9 A-F a-f _]*)? ([pP] [\+\-]? [0-9] [0-9 _]*)?+@hexLiteral = 0 [xX] [0-9 A-F a-f] [0-9 A-F a-f _]+@literalModifier = [G-Z g-z]+@newLine = \r* \n+@octLiteral = 0 [oO] [0-7] [0-7 _]*+-- must be defined in order, so these must go last+@intLiteral = @decimalLiteral | @hexLiteral | @octLiteral | @binLiteral++tokens :-+ -- TODO: \\ newline+ <0> @newLine;+ <0> $blank+;+ -- TODO: blank ++ <0> "_" { tok TokUnderscore }+ <0> "~" { tok TokTilde }+ <0> "~" lowerCase identChar* ":" { tokS $ TokLabel . getLabelName }+ <0> "?" { tok TokQuestion }+ <0> "?" lowerCase identChar* ":" { tokS $ TokOptLabel . getLabelName }+ <0> $lowerCase $identChar* { keywordLIdent }+ <0> $upperCase $identChar* { tokS TokUIdent }+ <0> @intLiteral { tokS $ \s -> TokInt (s, Nothing) }+ <0> @intLiteral @literalModifier { tokS $+ \ s ->+ let (lit, mod) = extractModifier s in+ TokInt (lit, (Just mod))+ }+ <0> @floatLiteral | @hexFloatLiteral { tokS $ \ s -> TokFloat (s, Nothing) }+ <0> (@floatLiteral | @hexFloatLiteral) @literalModifier { tokS $+ \ s ->+ let (lit, mod) = extractModifier s in+ TokFloat (lit, (Just mod))+ }+ <0> \" { beginString }+ <0> "(*" { beginCommentBuffer False "" }+ <0> "(**" { beginCommentBuffer True "*"}+ <0> "(**" "*"+ { \ alexInput lexemeLength ->+ let nbDropped = length "(**" in+ beginCommentBuffer False (drop nbDropped (getLexeme alexInput lexemeLength)) alexInput lexemeLength+ }+ <0> "(*" "*"* "*)" { \ alexInput lexemeLength -> do+ ss <- getLexemeSpan alexInput lexemeLength+ case getLexeme alexInput lexemeLength of+ "(**)" -> return $ Just $ Located ss $ TokDocstring "(**)"+ lexeme -> return $ Just $ Located ss $ TokComment lexeme+ }+ <0> "*)" { tokStarHack }++ <0> "#" { tok TokHash {- TODO: directives -} }+ <0> "&" { tok TokAmpersand }+ <0> "&&" { tok TokAmperAmper }+ <0> "`" { tok TokBackQuote }+ <0> "'" { tok TokQuote }+ <0> "(" { tok TokLParen }+ <0> ")" { tok TokRParen }+ <0> "*" { tok TokStar }+ <0> "," { tok TokComma }+ <0> "->" { tok TokMinusGreater }+ <0> "." { tok TokDot }+ <0> ".." { tok TokDotDot }+ -- TODO+ <0> ":" { tok TokColon }+ <0> "::" { tok TokColonColon }+ <0> ":=" { tok TokColonEqual }+ <0> ":>" { tok TokColonGreater }+ <0> ";" { tok TokSemi }+ <0> ";;" { tok TokSemiSemi }+ <0> "<" { tok TokLess }+ <0> "<-" { tok TokLessMinus }+ <0> "=" { tok TokEqual }+ <0> "[" { tok TokLBracket }+ <0> "[|" { tok TokLBracketBar }+ <0> "[<" { tok TokLBracketLess }+ <0> "[>" { tok TokLBracketGreater }+ <0> "]" { tok TokRBracket }+ <0> "{" { tok TokLBrace }+ <0> "{<" { tok TokLBraceLess }+ <0> "|" { tok TokBar }+ <0> "||" { tok TokBarBar }+ <0> "|]" { tok TokBarRBracket }+ <0> ">" { tok TokGreater }+ <0> ">]" { tok TokGreaterRBracket }+ <0> "}" { tok TokRBrace }+ <0> ">}" { tok TokGreaterRBrace }+ <0> "[@" { tok TokLBracketAt }+ <0> "[@@" { tok TokLBracketAtAt }+ <0> "[@@@" { tok TokLBracketAtAtAt }+ <0> "[%" { tok TokLBracketPercent }+ <0> "[%%" { tok TokLBracketPercentPercent }+ <0> "!" { tok TokBang }+ <0> "!=" { tok (TokInfixOp0 "!=") }+ <0> "+" { tok TokPlus }+ <0> "+." { tok TokPlusDot }+ <0> "+=" { tok TokPlusEq }+ <0> "-" { tok TokMinus }+ <0> "-." { tok TokMinusDot }+ <0> "!" $symbolChar+ { tokS TokPrefixOp }+ -- TODO+ <0> [= \< > \| & \$] $symbolChar* { tokS TokInfixOp0 }++ -- while inside a string+ <s> \" { endString }+ <s> . { appendString }+ <s> \\[nt\"] { escapeString }++ -- while inside a comment+ <c> "(*" { beginInnerComment False }+ <c> "*)" { endComment }+ <c> [.\n] { storeLexeme }++{++data Located a = Located SrcSpan a+ deriving (Generic, Show)++data Token+ = TokAmperAmper+ | TokAmpersand+ | TokAnd+ | TokAs+ | TokAssert+ | TokBackQuote+ | TokBang+ | TokBar+ | TokBarBar+ | TokBarRBracket+ | TokBegin+ | TokChar Char+ | TokClass+ | TokColon+ | TokColonColon+ | TokColonEqual+ | TokColonGreater+ | TokComma+ | TokComment String+ | TokConstraint+ | TokDo+ | TokDocstring String+ | TokDone+ | TokDot+ | TokDotDot+ | TokDotOp String+ | TokDownTo+ | TokElse+ | TokEnd+ | TokEOF+ | TokEqual+ | TokException+ | TokExternal+ | TokFalse+ | TokFloat (String, (Maybe Char))+ | TokFor+ | TokFun+ | TokFunction+ | TokFunctor+ | TokGreater+ | TokGreaterRBrace+ | TokGreaterRBracket+ | TokHash+ | TokHashOp String+ | TokIf+ | TokIn+ | TokInclude+ | TokInfixOp0 String+ | TokInfixOp1 String+ | TokInfixOp2 String+ | TokInfixOp3 String+ | TokInfixOp4 String+ | TokInherit+ | TokInitializer+ | TokInt (String, (Maybe Char))+ | TokLabel String+ | TokLazy+ | TokLBrace+ | TokLBraceLess+ | TokLBracket+ | TokLBracketAt+ | TokLBracketAtAt+ | TokLBracketAtAtAt+ | TokLBracketBar+ | TokLBracketGreater+ | TokLBracketLess+ | TokLBracketPercent+ | TokLBracketPercentPercent+ | TokLess+ | TokLessMinus+ | TokLet+ | TokLIdent String+ | TokLParen+ | TokMatch+ | TokMethod+ | TokMinus+ | TokMinusDot+ | TokMinusGreater+ | TokModule+ | TokMutable+ | TokNew+ | TokNonRec+ | TokObject+ | TokOf+ | TokOpen+ | TokOptLabel String+ | TokOr+ | TokPercent+ | TokPlus+ | TokPlusDot+ | TokPlusEq+ | TokPrefixOp String+ | TokPrivate+ | TokQuestion+ | TokQuote+ | TokRBrace+ | TokRBracket+ | TokRec+ | TokRParen+ | TokSemi+ | TokSemiSemi+ | TokSig+ | TokStar+ | TokString (String, Maybe String)+ | TokStruct+ | TokThen+ | TokTilde+ | TokTo+ | TokTrue+ | TokTry+ | TokType+ | TokUIdent String+ | TokUnderscore+ | TokVal+ | TokVirtual+ | TokWhen+ | TokWhile+ | TokWith+ deriving (Generic, Show)++data SrcSpan = SrcSpan+ { srcSpanStartLine :: !Int+ , srcSpanStartCol :: !Int+ , srcSpanEndLine :: !Int+ , srcSpanEndCol :: !Int+ }+ deriving (Generic, Eq, Ord)++instance Show SrcSpan where+ show SrcSpan {..} =+ printf "(%d,%d)-(%d,%d)" srcSpanStartLine srcSpanStartCol srcSpanEndLine srcSpanEndCol++type ResultToken = Located Token+type IntermediateToken = Maybe ResultToken+type MyAlexAction = AlexAction IntermediateToken++alexEOF :: Alex IntermediateToken+alexEOF = do+ (l, c) <- getPositionAfterLexeme+ let ss = SrcSpan l c l c+ return $ Just $ Located ss TokEOF++myAlexMonadScan :: Alex ResultToken+myAlexMonadScan = alexMonadScan >>= \case+ Nothing -> myAlexMonadScan+ Just t -> case t of+ -- TODO: instead of dropping comments, integrate them+ Located _ (TokComment _) -> myAlexMonadScan+ Located _ (TokDocstring _) -> myAlexMonadScan+ _ -> return t++lexWrap :: (ResultToken -> Alex a) -> Alex a+lexWrap cont = myAlexMonadScan >>= cont++alexScanTokens :: String -> Either String [ResultToken]+alexScanTokens input = runAlex input gather+ where+ gather :: Alex [ResultToken]+ gather = do+ myAlexMonadScan >>= \case+ t@(Located _ TokEOF) -> return [t]+ t -> return . (t :) =<< gather++alexPosnToMyPosition :: AlexPosn -> MyPosition+-- NOTE: OCaml starts at column 0, but Alex starts at column 1+alexPosnToMyPosition (AlexPn _ line col) = (adjustLine line, adjustCol col)++getPositionAfterLexeme :: Alex MyPosition+getPositionAfterLexeme = Alex $ \ s -> Right (s, alexPosnToMyPosition . alex_pos $ s)++keywordLIdent :: MyAlexAction+keywordLIdent = tokS (\ s -> M.findWithDefault (TokLIdent s) s keywordTable)++keywordTable :: M.Map String Token+keywordTable = M.fromList+ [ ("and", TokAnd)+ , ("as", TokAs)+ , ("assert", TokAssert)+ , ("begin", TokBegin)+ , ("class", TokClass)+ , ("constraint", TokConstraint)+ , ("do", TokDo)+ , ("done", TokDone)+ , ("downto", TokDownTo)+ , ("else", TokElse)+ , ("end", TokEnd)+ , ("exception", TokException)+ , ("external", TokExternal)+ , ("false", TokFalse)+ , ("for", TokFor)+ , ("fun", TokFun)+ , ("function", TokFunction)+ , ("functor", TokFunctor)+ , ("if", TokIf)+ , ("in", TokIn)+ , ("include", TokInclude)+ , ("inherit", TokInherit)+ , ("initializer", TokInitializer)+ , ("lazy", TokLazy)+ , ("let", TokLet)+ , ("match", TokMatch)+ , ("method", TokMethod)+ , ("module", TokModule)+ , ("mutable", TokMutable)+ , ("new", TokNew)+ , ("nonrec", TokNonRec)+ , ("object", TokObject)+ , ("of", TokOf)+ , ("open", TokOpen)+ , ("or", TokOr)+ , ("private", TokPrivate)+ , ("rec", TokRec)+ , ("sig", TokSig)+ , ("struct", TokStruct)+ , ("then", TokThen)+ , ("to", TokTo)+ , ("true", TokTrue)+ , ("try", TokTry)+ , ("type", TokType)+ , ("val", TokVal)+ , ("virtual", TokVirtual)+ , ("when", TokWhen)+ , ("while", TokWhile)+ , ("with", TokWith)+ ]++-- I like to use 'c' and 's' for the startCodes, but it's not very+-- documentation-friendly so here are some aliases++codeStartCode :: Int+codeStartCode = 0++commentStartCode :: Int+commentStartCode = c++stringStartCode :: Int+stringStartCode = s++getLexemeSpan :: AlexInput -> Int -> Alex SrcSpan+getLexemeSpan alexInput lexemeLength = do+ let (l, c) = getMyPosition alexInput+ return $ SrcSpan l c l (c + lexemeLength)++tok :: Token -> MyAlexAction+tok t alexInput lexemeLength = do+ ss <- getLexemeSpan alexInput lexemeLength+ return $ Just $ Located ss t++tokS :: (String -> Token) -> MyAlexAction+tokS t input@(_, _, _, str) len = tok (t $ take len str) input len++extractModifier :: String -> (String, Char)+extractModifier s = case reverse s of+ mod : lit -> (lit, mod)+ _ -> error "This should not happen"++getAlexState :: Alex AlexState+getAlexState = Alex $ \ s -> return (s, s)++getAlexUserState :: Alex AlexUserState+getAlexUserState = Alex $ \ s -> return (s, alex_ust s)++setAlexState :: AlexState -> Alex ()+setAlexState s = Alex $ const $ Right (s, ())++setAlexUserState :: AlexUserState -> Alex ()+setAlexUserState us = Alex $ \ s -> return (s { alex_ust = us }, ())++modifyUserState :: (AlexUserState -> AlexUserState) -> Alex ()+modifyUserState f = getAlexUserState >>= (setAlexUserState . f)++getCommentStartLoc :: Alex [MyPosition]+getCommentStartLoc = view commentStartLoc <$> getAlexUserState++setCommentStartLoc :: [MyPosition] -> Alex ()+setCommentStartLoc l = modifyUserState (over commentStartLoc $ const l)++modifyCommentStartLoc :: ([MyPosition] -> [MyPosition]) -> Alex ()+modifyCommentStartLoc f = getCommentStartLoc >>= (setCommentStartLoc . f)++pushCommentStartLoc :: MyPosition -> Alex ()+pushCommentStartLoc l = modifyCommentStartLoc ((:) l)++popCommentStartLoc :: Alex ()+popCommentStartLoc = modifyCommentStartLoc tail++getStringBuffer :: Alex String+getStringBuffer = view stringBuffer <$> getAlexUserState++setStringBuffer :: String -> Alex ()+setStringBuffer s = modifyUserState (over stringBuffer $ const s)++resetStringBuffer :: Alex ()+resetStringBuffer = setStringBuffer ""++modifyStringBuffer :: (String -> String) -> Alex ()+modifyStringBuffer f = getStringBuffer >>= (setStringBuffer . f)++appendToStringBuffer :: String -> Alex ()+appendToStringBuffer s = modifyStringBuffer (++ s)++getStringStartPosn :: Alex MyPosition+getStringStartPosn = view stringStartPosn <$> getAlexUserState++setStringStartPosn :: MyPosition -> Alex ()+setStringStartPosn p = modifyUserState (over stringStartPosn $ const p)++escapeString :: MyAlexAction+escapeString (_, _, _, (_ : c : _)) _ = do+ let unesc = case c of+ 'n' -> '\n'+ 't' -> '\t'+ '"' -> '"'+ modifyStringBuffer ((:) unesc)+ return Nothing++adjustLine :: Int -> Int+adjustLine l = l++-- OCaml counts from 0, but Alex counts from 1+adjustCol :: Int -> Int+adjustCol c = c++-- assumes lines and columns have been adjusted!+mkSpan :: MyPosition -> MyPosition -> SrcSpan+mkSpan (sL, sC) (eL, eC) = SrcSpan sL sC eL eC++alexGetPosn :: Alex AlexPosn+alexGetPosn = alex_pos <$> getAlexState++beginString :: MyAlexAction+beginString alexInput _ = do+ setStringStartPosn $ getMyPosition alexInput+ alexSetStartCode stringStartCode+ return Nothing++appendString :: MyAlexAction+appendString (_, _, _, (c : _)) _ = do+ modifyStringBuffer ((:) c)+ return Nothing++endString :: MyAlexAction+endString alexInput _ = do+ str <- getStringBuffer+ startPos <- getStringStartPosn+ let endPos = getMyPosition alexInput+ let span = mkSpan startPos endPos+ setAlexUserState alexInitUserState+ alexSetStartCode codeStartCode+ return $ Just $ Located span (TokString (reverse str, Nothing))++handleDocstrings :: Bool+handleDocstrings = True++beginCommentBuffer :: Bool -> String -> MyAlexAction+beginCommentBuffer isDocstring stringBuffer alexInput lexemeLength = do+ let lexeme = getLexeme alexInput lexemeLength+ setIsDocstringTo isDocstring+ setCommentStartLoc [getMyPosition alexInput]+ setStringBuffer stringBuffer+ alexSetStartCode commentStartCode+ return Nothing++beginInnerComment :: Bool -> MyAlexAction+beginInnerComment isDocstring alexInput _ = do+ pushCommentStartLoc $ getMyPosition alexInput+ return Nothing++endComment :: MyAlexAction+endComment alexInput lexemeLength = do+ l <- getCommentStartLoc+ case l of+ [] -> error "This should not happen"+ [(startLine, startCol)] -> do+ popCommentStartLoc+ commentString <- getStringBuffer+ let (endLine, endCol) = getMyPosition alexInput+ let ss = SrcSpan startLine startCol endLine endCol+ return $ Just $ Located ss $ TokComment commentString+ _ -> do+ popCommentStartLoc+ appendToStringBuffer $ getLexeme alexInput lexemeLength+ return Nothing++-- getInputAfterLexeme :: Alex String+-- getInputAfterLexeme = alex_inp <$> getAlexState++getPosition :: AlexInput -> AlexPosn+getPosition (pos, _, _, _) = pos++getMyPosition :: AlexInput -> MyPosition+getMyPosition = alexPosnToMyPosition . getPosition++getLexeme :: AlexInput -> Int -> String+getLexeme (_, _, _, str) len = take len str++storeLexeme :: MyAlexAction+storeLexeme inp len = do+ appendToStringBuffer $ getLexeme inp len+ return Nothing++type MyPosition = (Int, Int)++data AlexUserState = AlexUserState+ { _commentStartLoc :: ![MyPosition]+ , _isDocstring :: Bool+ , _stringBuffer :: String+ , _stringStartPosn :: !MyPosition+ }+ deriving (Show)++-- Unfortunately, makeLenses breaks alex at the moment, see:+-- https://github.com/simonmar/alex/issues/125+-- makeLenses ''AlexUserState+-- Writing lenses manually instead:+commentStartLoc :: Lens' AlexUserState [MyPosition]+commentStartLoc f s@(AlexUserState { _commentStartLoc }) =+ (\ l -> s { _commentStartLoc = l }) <$> f _commentStartLoc++isDocstring :: Lens' AlexUserState Bool+isDocstring f s@(AlexUserState { _isDocstring }) =+ (\ b -> s { _isDocstring = b }) <$> f _isDocstring++setIsDocstringTo :: Bool -> Alex ()+setIsDocstringTo b = modifyUserState $ over isDocstring $ const b++setDocstring :: Alex ()+setDocstring = setIsDocstringTo True++unsetDocstring :: Alex ()+unsetDocstring = setIsDocstringTo False++stringBuffer :: Lens' AlexUserState String+stringBuffer f s@(AlexUserState { _stringBuffer }) =+ (\ b -> s { _stringBuffer = b }) <$> f _stringBuffer++stringStartPosn :: Lens' AlexUserState MyPosition+stringStartPosn f s@(AlexUserState { _stringStartPosn }) =+ (\ p -> s { _stringStartPosn = p }) <$> f _stringStartPosn++alexInitUserState :: AlexUserState+alexInitUserState = AlexUserState+ { _commentStartLoc = []+ , _stringBuffer = ""+ , _stringStartPosn = (0, 0)+ }++getLabelName :: String -> String+getLabelName s =+ let name = slice 1 (- 2) s in+ if M.member name keywordTable+ then error $ "You cannot use this keyword as a label: " ++ name+ else name++-- inclusive on both ends+slice :: Int -> Int -> [a] -> [a]+slice from to l | from > 0 && to > 0 = slicePositive from to l+ | from > 0 && to < 0 = slicePositive from (length l - 1 - to) l+ | from < 0 && to > 0 = error "TODO"+ | otherwise = error "TODO"++slicePositive :: Int -> Int -> [a] -> [a]+slicePositive from to | from >= 0 && to >= 0 = take (to - from) . drop from+ | otherwise = error "slicePositive: negative indices"++{- OCaml parses input like "( *)" as a multiplication. The way it does it, is+that it treats the open parenthesis as LPAREN, then upon seeing "*)" in a+non-comment context, it outputs the token STAR after having rewound the lexer+state to before the closing parenthesis, so that the lexer then outputs a RPAREN+token too. Emulating this hack...+-}+tokStarHack :: MyAlexAction+tokStarHack alexInput _ = do+ s <- getAlexState+ setAlexState $ AlexState+ { alex_pos = rewind $ alex_pos s+ , alex_inp = ')' : alex_inp s+ , alex_chr = '*'+ , alex_bytes = []+ , alex_scd = alex_scd s+ }+ -- the lexeme length should be 2, but we just want the '*'+ ss <- getLexemeSpan alexInput 1+ return $ Just $ Located ss TokStar+ where+ -- rewinds a normal character (not \t or \n)+ rewind (AlexPn a l c) = AlexPn (a - 1) l (c - 1)++}
+ lib/Language/OCaml/Parser/Generator/Parser.y view
@@ -0,0 +1,1232 @@+{++{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}++module Language.OCaml.Parser.Generator.Parser+ ( Parser+ , parseExpr+ , parseExprCommaList+ , parseImplementation+ , parseModLongident+ , parseOpenStatement+ , parsePattern+ , parseSeqExpr+ , parseSimpleExpr+ , parseStructure+ , parseStructureItem+ , parseValIdent+ , parseValLongident+ ) where++import Data.Default+import Text.Printf++import Language.OCaml.Definitions.Parsing.ASTHelper.Exp as Exp+import Language.OCaml.Definitions.Parsing.ASTHelper.Mb as Mb+import Language.OCaml.Definitions.Parsing.ASTHelper.Mod as Mod+import Language.OCaml.Definitions.Parsing.ASTHelper.Mtd as Mtd+import Language.OCaml.Definitions.Parsing.ASTHelper.Mty as Mty+import Language.OCaml.Definitions.Parsing.ASTHelper.Opn as Opn+import Language.OCaml.Definitions.Parsing.ASTHelper.Pat as Pat+import Language.OCaml.Definitions.Parsing.ASTHelper.Str as Str+import Language.OCaml.Definitions.Parsing.ASTHelper.Te as Te+import Language.OCaml.Definitions.Parsing.ASTHelper.Typ as Typ+import Language.OCaml.Definitions.Parsing.ASTHelper.Type as Type+import Language.OCaml.Definitions.Parsing.ASTHelper.Val as Val+import Language.OCaml.Definitions.Parsing.ASTHelper.Vb as Vb+import Language.OCaml.Definitions.Parsing.Docstrings+import Language.OCaml.Definitions.Parsing.Location+import Language.OCaml.Definitions.Parsing.Parser.LetBinding+import Language.OCaml.Definitions.Parsing.Parser.LetBindings+import Language.OCaml.Definitions.Parsing.ASTTypes as ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree as ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.Generator.Lexer++}++%name rawParseExpr Expr+%name rawParseExprCommaList ExprCommaList+%name rawParseImplementation Implementation+%name rawParseModLongident ModLongident+%name rawParseOpenStatement OpenStatement+%name rawParsePattern Pattern+%name rawParseSeqExpr SeqExpr+%name rawParseSimpleExpr SimpleExpr+%name rawParseStructureItem StructureItem+%name rawParseStructure Structure+%name rawParseValIdent ValIdent+%name rawParseValLongident ValLongident++%tokentype { ResultToken }+%lexer { lexWrap } { Located _ TokEOF }+%monad { Alex }+%error { parseError }++%token+ "&&" { Located _ TokAmperAmper }+ "&" { Located _ TokAmpersand }+ and { Located _ TokAnd }+ as { Located _ TokAs }+ assert { Located _ TokAssert }+ "`" { Located _ TokBackQuote }+ "!" { Located _ TokBang }+ "|" { Located _ TokBar }+ "||" { Located _ TokBarBar }+ "|]" { Located _ TokBarRBracket }+ begin { Located _ TokBegin }+ CHAR { Located _ (TokChar $$) }+ class { Located _ TokClass }+ ":" { Located _ TokColon }+ "::" { Located _ TokColonColon }+ ":=" { Located _ TokColonEqual }+ ":>" { Located _ TokColonGreater }+ "," { Located _ TokComma }+ constraint { Located _ TokConstraint }+ do { Located _ TokDo }+ done { Located _ TokDone }+ "." { Located _ TokDot }+ ".." { Located _ TokDotDot }+ DOTOP { Located _ (TokDotOp $$) }+ downto { Located _ TokDownTo }+ else { Located _ TokElse }+ end { Located _ TokEnd }+ EOF { Located _ TokEOF }+ "=" { Located _ TokEqual }+ exception { Located _ TokException }+ external { Located _ TokExternal }+ false { Located _ TokFalse }+ FLOAT { Located _ (TokFloat $$) }+ for { Located _ TokFor }+ fun { Located _ TokFun }+ function { Located _ TokFunction }+ functor { Located _ TokFunctor }+ ">" { Located _ TokGreater }+ ">}" { Located _ TokGreaterRBrace }+ ">]" { Located _ TokGreaterRBracket }+ "#" { Located _ TokHash }+ HASHOP { Located _ (TokHashOp $$) }+ if { Located _ TokIf }+ in { Located _ TokIn }+ include { Located _ TokInclude }+ inherit { Located _ TokInherit }+ initialier { Located _ TokInitializer }+ INFIXOP0 { Located _ (TokInfixOp0 $$) }+ INFIXOP1 { Located _ (TokInfixOp1 $$) }+ INFIXOP2 { Located _ (TokInfixOp2 $$) }+ INFIXOP3 { Located _ (TokInfixOp3 $$) }+ INFIXOP4 { Located _ (TokInfixOp4 $$) }+ INT { Located _ (TokInt $$) }+ LABEL { Located _ (TokLabel $$) }+ lazy { Located _ TokLazy }+ "{" { Located _ TokLBrace }+ "{<" { Located _ TokLBraceLess }+ "[" { Located _ TokLBracket }+ "[@" { Located _ TokLBracketAt }+ "[@@" { Located _ TokLBracketAtAt }+ "[@@@" { Located _ TokLBracketAtAtAt }+ "[|" { Located _ TokLBracketBar }+ "[>" { Located _ TokLBracketGreater }+ "[<" { Located _ TokLBracketLess }+ "[%" { Located _ TokLBracketPercent }+ "[%%" { Located _ TokLBracketPercentPercent }+ "<" { Located _ TokLess }+ "<-" { Located _ TokLessMinus }+ let { Located _ TokLet }+ LIDENT { Located _ (TokLIdent $$) }+ "(" { Located _ TokLParen }+ match { Located _ TokMatch }+ method { Located _ TokMethod }+ "-" { Located _ TokMinus }+ "-." { Located _ TokMinusDot }+ "->" { Located _ TokMinusGreater }+ module { Located _ TokModule }+ mutable { Located _ TokMutable }+ new { Located _ TokNew }+ nonrec { Located _ TokNonRec }+ object { Located _ TokObject }+ of { Located _ TokOf }+ open { Located _ TokOpen }+ OPTLABEL { Located _ (TokOptLabel $$) }+ or { Located _ TokOr }+ "%" { Located _ TokPercent }+ "+" { Located _ TokPlus }+ "+." { Located _ TokPlusDot }+ "+=" { Located _ TokPlusEq }+ PREFIXOP { Located _ (TokPrefixOp $$) }+ private { Located _ TokPrivate }+ "?" { Located _ TokQuestion }+ "'" { Located _ TokQuote }+ "}" { Located _ TokRBrace }+ "]" { Located _ TokRBracket }+ rec { Located _ TokRec }+ ")" { Located _ TokRParen }+ ";" { Located _ TokSemi }+ ";;" { Located _ TokSemiSemi }+ sig { Located _ TokSig }+ "*" { Located _ TokStar }+ STRING { Located _ (TokString $$) }+ struct { Located _ TokStruct }+ then { Located _ TokThen }+ "~" { Located _ TokTilde }+ to { Located _ TokTo }+ true { Located _ TokTrue }+ try { Located _ TokTry }+ type { Located _ TokType }+ UIDENT { Located _ (TokUIdent $$) }+ "_" { Located _ TokUnderscore }+ val { Located _ TokVal }+ virtual { Located _ TokVirtual }+ when { Located _ TokWhen }+ while { Located _ TokWhile }+ with { Located _ TokWith }++%nonassoc in+%nonassoc belowSemi+%nonassoc ";"+%nonassoc let+%nonassoc belowWith+%nonassoc function with+%nonassoc and+%nonassoc then+%nonassoc else+%nonassoc "<-"+%right ":="+%nonassoc as+%left "|"+%nonassoc belowComma+%left ","+%right "->"+%right or "||"+%right "&" "&&"+%nonassoc belowEqual+%left INFIXOP0 "=" "<" ">"+%right INFIXOP1+%nonassoc belowLBracketAtAt+%nonassoc "[@"+%nonassoc "[@@"+%right "::"+%left INFIXOP2 "+" "+." "-" "-." "+="+%left "%" INFIXOP3 "*"+%right INFIXOP4+%nonassoc precUnaryMinus precUnaryPlus+%nonassoc precConstantConstructor+%nonassoc precConstrAppl+%nonassoc belowHash+%nonassoc "#"+%left HASHOP+%nonassoc belowDot+%nonassoc "." DOTOP+%nonassoc "`" "!" begin CHAR false float int+ "{" "{<" "[" "[|" LIDENT "("+ new PREFIXOP STRING true UIDENT+ "[%" "[%%"++%%++AmperTypeList :: { [CoreType] }+ : CoreTypeNoAttr { [$1] }+ | AmperTypeList "&" CoreTypeNoAttr { $3 : $1 }++AndLetBinding :: { LetBinding }+ : and Attributes LetBindingBody PostItemAttributes { mklb False $3 ($2 ++ $4) }++AndTypeDeclaration :: { TypeDeclaration }+ : and Attributes OptionalTypeParameters LIDENT TypeKind Constraints PostItemAttributes+ { let (kind, priv, manifest) = $5 in+ Type.mk (def { params = $3+ , cstrs = reverse $6+ , kind+ , priv+ , attrs = $2 ++ $7+ , loc = symbolRLoc ()+ , Type.text = symbolText ()+ , docs = symbolDocs ()+ })+ manifest (mkRHS $4 4)+ }++Attribute :: { Attribute }+ : "[@@" AttrId Payload "]" { ($2, $3) }++Attributes :: { [Attribute] }+ : {- empty -} { [] }+ | Attribute Attributes { $1 : $2 }++AttrId :: { Loc String }+ : SingleAttrId { mkLoc $1 (symbolRLoc ()) }+ | SingleAttrId "." AttrId { mkLoc ($1 ++ "." ++ txt $3) (symbolRLoc ()) }++BarConstructorDeclaration :: { ConstructorDeclaration }+ : "|" ConstrIdent GeneralizedConstructorArguments Attributes+ { let (args, res) = $3 in+ Type.constructor (def { args+ , attrs = $4+ , loc = symbolRLoc ()+ , info = symbolInfo ()+ })+ res (mkRHS $2 2)+ }++ClassLongident :: { Longident }+ : LIDENT { Lident $1 }+ | ModLongident "." LIDENT { Ldot $1 $3 }++Constant :: { ParseTree.Constant }+ : INT { uncurry PconstInteger $1 }+ | CHAR { PconstChar $1 }+ | STRING { uncurry PconstString $1 }+ | FLOAT { uncurry PconstFloat $1 }++Constrain :: { (CoreType, CoreType, Location) }+ : CoreType "=" CoreType { ($1, $3, symbolRLoc ()) }++Constraints :: { [(CoreType, CoreType, Location)] }+ : Constraints constraint Constrain { $3 : $1 }+ | {- empty-} { [] }++ConstrIdent :: { String }+ : UIDENT { $1 }+ | "[" "]" { "[]" }+ | "(" ")" { "()" }+ | "(" "::" ")" { "::" }+ | false { "false" }+ | true { "true" }++ConstrLongident :: { Longident }+ : ModLongident %prec belowDot { $1 }+ | ModLongident "." "(" "::" ")" { Ldot $1 "::" }+ | "[" "]" { Lident "[]" }+ | "(" ")" { Lident "()" }+ | "(" "::" ")" { Lident "::" }+ | false { Lident "false" }+ | true { Lident "true" }++ConstructorArguments :: { ConstructorArguments }+ : CoreTypeList { PcstrTuple (reverse $1) }+ | "{" LabelDeclarations "}" { PcstrRecord $2 }++ConstructorDeclaration :: { ConstructorDeclaration }+ : ConstrIdent GeneralizedConstructorArguments Attributes+ { let (args, res) = $2 in+ Type.constructor (def { args+ , attrs = $3+ , loc = symbolRLoc ()+ , info = symbolInfo ()+ })+ res (mkRHS $1 1)+ }++ConstructorDeclarations :: { [ConstructorDeclaration] }+ : "|" { [] }+ | ConstructorDeclaration { [$1] }+ | BarConstructorDeclaration { [$1] }+ | ConstructorDeclarations BarConstructorDeclaration { $2 : $1 }++CoreType :: { CoreType }+ : CoreTypeNoAttr { $1 }+ -- | CoreType Attribute { attrTyp $1 $2 }++CoreType2 :: { CoreType }+ : SimpleCoreTypeOrTuple { $1 }+-- | "?" LIDENT ":" CoreType2 "->" CoreType2 { let param = extraRHSCoreType (def { pos = 4 }) $4 in+-- mktyp $ PtypArrow (Optional $2) param $6+-- }+ -- TODO++CoreTypeCommaList :: { [CoreType] }+ : CoreType { [$1] }+ | CoreTypeCommaList "," CoreType { $3 : $1 }++CoreTypeList :: { [CoreType] }+ : CoreType { [$1] }+ | CoreTypeList "*" CoreType { $3 : $1 }++CoreTypeNoAttr :: { CoreType }+ : CoreType2 %prec "->" { $1 }+ | CoreType2 as "'" Ident { mktyp $ PtypAlias $1 $4 }++DirectionFlag :: { DirectionFlag }+ : to { UpTo }+ | downto { DownTo }++Expr :: { Expression }+ : SimpleExpr %prec belowHash { $1 }+ | SimpleExpr SimpleLabeledExprList { mkexp $ PexpApply $1 (reverse $2) }+ | LetBindings in SeqExpr { exprOfLetBindings $1 $3 }+ | let module ExtAttributes UIDENT ModuleBindingBody in SeqExpr { mkexpAttrs (PexpLetModule (mkRHS $4 4) $5 $7) $3 }+ | let exception ExtAttributes LetExceptionDeclaration in SeqExpr { mkexpAttrs (PexpLetException $4 $6) $3 }+ | let open OverrideFlag ExtAttributes ModLongident in SeqExpr { mkexpAttrs (PexpOpen $3 (mkRHS $5 5) $7) $4 }+ | function ExtAttributes OptBar MatchCases { mkexpAttrs (PexpFunction (reverse $4)) $2 }+ | fun ExtAttributes LabeledSimplePattern FunDef { let (l, o, p) = $3 in+ mkexpAttrs (PexpFun l o p $4) $2+ }+ | fun ExtAttributes "(" type LidentList ")" FunDef { mkexpAttrs (pexpDesc $ mkNewTypes $5 $7) $2 }+ | match ExtAttributes SeqExpr with OptBar MatchCases { mkexpAttrs (PexpMatch $3 (reverse $6)) $2 }+ | try ExtAttributes SeqExpr with OptBar MatchCases { mkexpAttrs (PexpTry $3 (reverse $6)) $2 }+ | try ExtAttributes SeqExpr with error {% alexError "try ExtAttributes SeqExpr with <ERROR>" }+ | ExprCommaList %prec belowComma { mkexp $ PexpTuple (reverse $1) }+ | ConstrLongident SimpleExpr %prec belowHash { mkexp $ PexpConstruct (mkRHS $1 1) (Just $2) }+ | NameTag SimpleExpr %prec belowHash { mkexp $ PexpVariant $1 (Just $2) }+ | if ExtAttributes SeqExpr then Expr else Expr { mkexpAttrs (PexpIfThenElse $3 $5 (Just $7)) $2 }+ | if ExtAttributes SeqExpr then Expr { mkexpAttrs (PexpIfThenElse $3 $5 Nothing) $2 }+ | while ExtAttributes SeqExpr do SeqExpr done { mkexpAttrs (PexpWhile $3 $5) $2 }+ | for ExtAttributes Pattern+ "=" SeqExpr DirectionFlag SeqExpr+ do SeqExpr done { mkexpAttrs (PexpFor $3 $5 $7 $6 $9) $2 }+ | Expr "::" Expr { mkexpCons (rhsLoc 2) (ghexp $ PexpTuple [$1, $3]) (symbolRLoc ()) }+ -- TODO: infixops+ | Expr "+" Expr { mkinfix $1 "+" $3 }+ | Expr "+." Expr { mkinfix $1 "+." $3 }+ | Expr "+=" Expr { mkinfix $1 "+=" $3 }+ | Expr "-" Expr { mkinfix $1 "-" $3 }+ | Expr "-." Expr { mkinfix $1 "-." $3 }+ | Expr "*" Expr { mkinfix $1 "*" $3 }+ | Expr "%" Expr { mkinfix $1 "%" $3 }+ | Expr "=" Expr { mkinfix $1 "=" $3 }+ | Expr "<" Expr { mkinfix $1 "<" $3 }+ | Expr ">" Expr { mkinfix $1 ">" $3 }+ | Expr or Expr { mkinfix $1 "or" $3 }+ | Expr "||" Expr { mkinfix $1 "||" $3 }+ | Expr "&" Expr { mkinfix $1 "&" $3 }+ | Expr "&&" Expr { mkinfix $1 "&&" $3 }+ | Expr ":=" Expr { mkinfix $1 ":=" $3 }+ -- TODO+ | SimpleExpr "." LabelLongident "<-" Expr { mkexp $ PexpSetField $1 (mkRHS $3 3) $5 }+ -- TODO+ -- | Expr Attribute { attrExp $1 $2 }+ | "_" {% alexError "Wildcard not expected" }++ExprCommaList :: { [Expression] }+ : Expr "," Expr { [$3, $1] }+ | ExprCommaList "," Expr { $3 : $1 }++ExprSemiList :: { [Expression] }+ : Expr { [$1] }+ | ExprSemiList ";" Expr { $3 : $1 }++ExtAttributes :: { (Maybe (Loc String), [(Loc String, Payload)]) }+ : {- empty -} { (Nothing, []) }+ | Attribute Attributes { (Nothing, $1 : $2) }+ | "%" AttrId Attributes { (Just $2, $3) }++Extension :: { (Loc String, Payload) }+ : "[%" AttrId Payload "]" { ($2, $3) }++FieldExpr :: { (Loc String, Expression) }+ : Label "=" Expr { (mkRHS $1 1, $3) }+ | Label { (mkRHS $1 1, expOfLabel (Lident $1) 1) }++FieldExprList :: { [(Loc String, Expression)] }+ : FieldExpr OptSemi { [$1] }+ | FieldExpr ";" FieldExprList { $1 : $3 }++FieldSemi :: { ObjectField }+ : Label ":" PolyTypeNoAttr Attributes ";" Attributes+ { let info = case rhsInfo 4 of+ -- Somehow the next line needs to be indented real right for the generater .hs file to parse correctly+ infoBeforeSemi@(Just _) -> infoBeforeSemi+ Nothing -> symbolInfo ()+ in+ Otag (mkRHS $1 1) (addInfoAttrs info ($4 ++ $6)) $3+ }++FunBinding :: { Expression }+ : StrictBinding { $1 }+ -- | TypeConstraint "=" SeqExpr { mkexpConstraint $3 $1 }++FunDef :: { Expression }+ : "->" SeqExpr { $2 }+ | ":" SimpleCoreType "->" SeqExpr { Exp.mk def $ PexpConstraint $4 $2 }+ | LabeledSimplePattern FunDef { let (l, o, p) = $1 in+ ghexp $ PexpFun l o p $2+ }++GeneralizedConstructorArguments :: { (ConstructorArguments, Maybe CoreType) }+ : {- empty -} { (PcstrTuple [], Nothing) }+ | of ConstructorArguments { ($2, Nothing) }+ | ":" ConstructorArguments "->" SimpleCoreType { ($2, Just $4) }+ | ":" SimpleCoreType { (PcstrTuple [], Just $2) }++Ident :: { String }+ : UIDENT { $1 }+ | LIDENT { $1 }++Implementation :: { [StructureItem] }+ : Structure { extraStr 1 $1 }+ -- : Structure EOF { extraStr 1 $1 } -- FIXME++Label :: { String }+ : LIDENT { $1 }++LabelDeclaration :: { LabelDeclaration }+ : MutableFlag Label ":" PolyTypeNoAttr Attributes+ { Type.field (def { mut = $1+ , attrs = $5+ , loc = symbolRLoc ()+ , info = symbolInfo ()+ }+ )+ (mkRHS $2 2) $4+ }++LabelDeclarations :: { [LabelDeclaration] }+ : LabelDeclaration { [$1] }+ | LabelDeclarationSemi { [$1] }+ | LabelDeclarationSemi LabelDeclarations { $1 : $2 }++LabelDeclarationSemi :: { LabelDeclaration }+ : MutableFlag Label ":" PolyTypeNoAttr Attributes ";" Attributes+ { let info = symbolInfo ()+ -- case rhsInfo 5 of+ -- infoBeforeSemi@(Just _) -> infoBeforeSemi+ -- Nothing -> symbolInfo ()+ in+ Type.field (def { mut = $1+ , attrs = $5 ++ $7+ , loc = symbolRLoc ()+ , info+ }+ )+ (mkRHS $2 2) $4+ }++LabelLetPattern :: { (String, Pattern) }+ : LabelVar { $1 }+ | LabelVar ":" CoreType { let (lab, pat) = $1 in+ (lab, mkpat $ PpatConstraint pat $3)+ }++LabelLongident :: { Longident }+ : LIDENT { Lident $1 }+ | ModLongident "." LIDENT { Ldot $1 $3 }++LabeledSimpleExpr :: { (ArgLabel, Expression) }+ : SimpleExpr %prec belowHash { (Nolabel, $1) }+ -- | LabelExpr { $1 }++LabeledSimplePattern :: { (ArgLabel, Maybe Expression, Pattern) }+ : "?" "(" LabelLetPattern OptDefault ")" { (Optional (fst $3), $4, snd $3) }+ | "?" LabelVar { (Optional (fst $2), Nothing, snd $2) }+ | OPTLABEL "(" LetPattern OptDefault ")" { (Optional $1, $4, $3) }+ | OPTLABEL PatternVar { (Optional $1, Nothing, $2) }+ | "~" "(" LabelLetPattern ")" { (Labelled (fst $3), Nothing, snd $3) }+ | "~" LabelVar { (Labelled (fst $2), Nothing, snd $2) }+ | LABEL SimplePattern { (Labelled $1, Nothing, $2) }+ | SimplePattern { (Nolabel, Nothing, $1) }++LabelVar :: { (String, Pattern) }+ : LIDENT { ($1, mkpat $ PpatVar (mkRHS $1 1)) }++LblExpr :: { (Loc Longident, Expression) }+ : LabelLongident OptTypeConstraint "=" Expr { (mkRHS $1 1, mkexpOptConstraint $4 $2) }+ | LabelLongident OptTypeConstraint { (mkRHS $1 1, mkexpOptConstraint (expOfLabel $1 1) $2) }++LblExprList :: { [(Loc Longident, Expression)] }+ : LblExpr { [$1] }+ | LblExpr ";" LblExprList { $1 : $3 }+ | LblExpr ";" { [$1] }++LblPattern :: { (Loc Longident, Pattern) }+ : LabelLongident OptPatternTypeConstraint "=" Pattern { (mkRHS $1 1, mkpatOptConstraint $4 $2) }+ | LabelLongident OptPatternTypeConstraint { (mkRHS $1 1, mkpatOptConstraint (patOfLabel $1 1) $2) }++LblPatternList :: { ([(Loc Longident, Pattern)], ClosedFlag) }+ : LblPattern { ([$1], Closed) }+ | LblPattern ";" { ([$1], Closed) }+ | LblPattern ";" "_" OptSemi { ([$1], Open) }+ | LblPattern ";" LblPatternList { let (fields, closed) = $3 in ($1 : fields, closed) }++LetBinding :: { LetBindings }+ : let ExtAttributes RecFlag LetBindingBody PostItemAttributes { let (ext, attr) = $2 in+ mklbs ext $3 (mklb True $4 (attr ++ $5))+ }++LetBindingBody :: { (Pattern, Expression) }+ : ValIdent StrictBinding { (mkpatvar $1 1, $2) }+ | ValIdent TypeConstraint "=" SeqExpr { let v = mkpatvar $1 1 in+ let t = case $2 of+ (Just t, Nothing) -> t+ (_, Just t) -> t+ (_, _) -> error "This should not happen"+ in+ ( ghpat $ PpatConstraint v (ghtyp $ PtypPoly [] t)+ , mkexpConstraint $4 $2+ )+ }+ | ValIdent ":" TypeVarList "." CoreType "=" SeqExpr { ( ghpat $ PpatConstraint (mkpatvar $1 1) (ghtyp $ PtypPoly (reverse $3) $5)+ , $7+ )+ }+ | ValIdent ":" type LidentList "." CoreType "=" SeqExpr { let (exp, poly) = wrapTypeAnnotation $4 $6 $8 in+ ( ghpat $ PpatConstraint (mkpatvar $1 1) poly+ , exp+ )+ }+ | PatternNoExn "=" SeqExpr { ($1, $3) }+ | SimplePatternNotIdent ":" CoreType "=" SeqExpr { (ghpat $ PpatConstraint $1 $3, $5) }++LetBindings :: { LetBindings }+ : LetBinding { $1 }+ | LetBindings AndLetBinding { addlb $1 $2 }++LetExceptionDeclaration :: { ExtensionConstructor }+ : ConstrIdent GeneralizedConstructorArguments Attributes+ { let (args, res) = $2 in+ Te.decl (def { args+ , attrs = $3+ , loc = symbolRLoc ()+ }+ )+ res (mkRHS $1 1)+ }++LetPattern :: { Pattern }+ : Pattern { $1 }+ | Pattern ":" CoreType { mkpat $ PpatConstraint $1 $3 }++LidentList :: { [Loc String] }+ : LIDENT { [mkRHS $1 1] }+ | LIDENT LidentList { mkRHS $1 1 : $2 }++MatchCase :: { Case }+ : Pattern "->" SeqExpr { Exp.case' def $1 $3 }+ | Pattern when SeqExpr "->" SeqExpr { Exp.case' (def { guard = Just $3 }) $1 $5 }+ | Pattern "->" "." { Exp.case' def $1 (Exp.unreachable (def { loc = rhsLoc 3 }) ()) }++MatchCases :: { [Case] }+ : MatchCase { [$1] }+ | MatchCases "|" MatchCase { $3 : $1 }++MethList :: { ([ObjectField], ClosedFlag) }+ : FieldSemi MethList { let (f, c) = $2 in ($1 : f, c) }+ -- TODO+ | ".." { ([], Open) }++ModExtLongident :: { Longident }+ : UIDENT { Lident $1 }+ | ModExtLongident "." UIDENT { Ldot $1 $3 }+ -- | ModExtLongident "(" ModExtLongident ")" { lapply $1 $3 }++ModLongident :: { Longident }+ : UIDENT { Lident $1 }+ | ModLongident "." UIDENT { Ldot $1 $3 }++ModuleBinding :: { (ModuleBinding, Maybe (Loc String)) }+ : module ExtAttributes UIDENT ModuleBindingBody PostItemAttributes+ { let (ext, attrs) = $2 in+ ( Mb.mk (def { attrs = attrs ++ $5+ , loc = symbolRLoc ()+ , docs = symbolDocs ()+ }+ )+ (mkRHS $3 3) $4+ , ext+ )+ }++ModuleBindingBody :: { ModuleExpr }+ : "=" ModuleExpr { $2 }+ | ":" ModuleType "=" ModuleExpr { mkmod def $ PmodConstraint $4 $2 }+ -- | FunctorArg ModuleBindingBody { mkmod def $ PmodFunctor (fst $1) (snd $1) $2 }++ModuleExpr :: { ModuleExpr }+ : ModLongident { mkmod def $ PmodIdent (mkRHS $1 1) }+ | struct Attributes Structure end { mkmod (Just $2) $ PmodStructure (extraStr 3 $3) }+ | struct Attributes Structure error {% alexError "struct Attributes Structure <ERROR>" }+-- | functor Attributes FunctorArg "->" ModuleExpr { let modExp = foldl (\ acc (n, t) -> mkmod def $ PmodFunctor n t acc) $5 $3+-- in wrapModAttrs modExp $2+-- }+ | ModuleExpr ParenModuleExpr { mkmod def $ PmodApply $1 $2 }+ | ModuleExpr "(" ")" { mkmod def $ PmodApply $1 (mkmod def $ PmodStructure []) }+ | ParenModuleExpr { $1 }+ | ModuleExpr Attribute { Mod.attr $1 $2 }+ | Extension { mkmod def $ PmodExtension $1 }++ModuleType :: { ModuleType }+ : MtyLongident { mkmty def $ PmtyIdent (mkRHS $1 1) }+ -- TODO++ModuleTypeDeclaration :: { (ModuleTypeDeclaration, Maybe (Loc String)) }+ : module type ExtAttributes Ident ModuleTypeDeclarationBody PostItemAttributes+ { let (ext, attrs) = $3 in+ ( Mtd.mk (def { attrs = attrs ++ $6+ , loc = symbolRLoc ()+ , docs = symbolDocs ()+ }+ ) $5 (mkRHS $4 4)+ , ext+ )+ }++ModuleTypeDeclarationBody :: { Maybe ModuleType }+ : {- empty -} { Nothing }+ | "=" ModuleType { Just $2 }++MutableFlag :: { MutableFlag }+ : {- empty-} { Immutable }+ | mutable { Mutable }++MtyLongident :: { Longident }+ : Ident { Lident $1 }+ | ModExtLongident "." Ident { Ldot $1 $3 }++NameTag :: { String }+ : "`" Ident { $2 }++NonRecFlag :: { RecFlag }+ : {- empty -} { Recursive }+ | nonrec { NonRecursive }++OpenStatement :: { (OpenDescription, Maybe (Loc String)) }+ : open OverrideFlag ExtAttributes ModLongident PostItemAttributes+ { let (ext, attrs) = $3 in+ (Opn.mk (def { Opn.override = $2+ , attrs = attrs ++ $5+ , loc = symbolRLoc ()+ , docs = symbolDocs ()+ })+ (mkRHS $4 4)+ , ext+ )+ }++Operator :: { String }+ : PREFIXOP { $1 }+ | INFIXOP0 { $1 }+ | INFIXOP1 { $1 }+ | INFIXOP2 { $1 }+ | INFIXOP3 { $1 }+ | INFIXOP4 { $1 }+ | DOTOP "(" ")" { "." ++ $1 ++ "()" }+ | DOTOP "(" ")" "<-" { "." ++ $1 ++ "()<-" }+ | DOTOP "[" "]" { "." ++ $1 ++ "[]" }+ | DOTOP "[" "]" "<-" { "." ++ $1 ++ "[]<-" }+ | DOTOP "{" "}" { "." ++ $1 ++ "{}" }+ | DOTOP "{" "}" "<-" { "." ++ $1 ++ "{}<-" }+ | HASHOP { $1 }+ | "!" { "!" }+ | "+" { "+" }+ | "+." { "+." }+ | "-" { "-" }+ | "-." { "-." }+ | "*" { "*" }+ | "=" { "=" }+ | "<" { "<" }+ | ">" { ">" }+ | or { "or" }+ | "||" { "||" }+ | "&" { "&" }+ | "&&" { "&&" }+ | ":=" { ":=" }+ | "+=" { "+=" }+ | "%" { "%" }++OptAmpersand :: { Bool }+ : "&" { True }+ | {- empty -} { False }++OptBar :: { () }+ : {- empty -} { () }+ | "|" { () }++OptDefault :: { Maybe Expression }+ : {- empty-} { Nothing }+ | "=" SeqExpr { Just $2 }++OptionalTypeParameter :: { (CoreType, Variance) }+ : TypeVariance OptionalTypeVariable { ($2, $1) }++OptionalTypeParameterList :: { [(CoreType, Variance)] }+ : OptionalTypeParameter { [$1] }+ | OptionalTypeParameterList "," OptionalTypeParameter { $3 : $1 }++OptionalTypeParameters :: { [(CoreType, Variance)] }+ : {- empty -} { [] }+ | OptionalTypeParameter { [$1] }+ | "(" OptionalTypeParameterList ")" { reverse $2 }++OptionalTypeVariable :: { CoreType }+ : "'" Ident { mktyp $ PtypVar $2 }+ | "_" { mktyp $ PtypAny }++OptPatternTypeConstraint :: { Maybe CoreType }+ : ":" CoreType { Just $2 }+ | {- empty -} { Nothing }++OptSemi :: { () }+ : {- empty -} { () }+ | ";" { () }++OptTypeConstraint :: { Maybe (Maybe CoreType, Maybe CoreType) }+ : TypeConstraint { Just $1 }+ | {- empty -} { Nothing }++OverrideFlag :: { OverrideFlag }+ : {- empty -} { Fresh }+ | "!" { Override }++PackageType :: { PackageType }+ : ModuleType { packageTypeOfModuleType $1 }++ParenModuleExpr :: { ModuleExpr }+ : "(" ModuleExpr ":" ModuleType ")" { mkmod def $ PmodConstraint $2 $4 }+ | "(" ModuleExpr ":" ModuleType error {% alexError "( ModuleExpr : ModuleType <ERROR>" }+ -- TODO++Pattern :: { Pattern }+ : Pattern as ValIdent { mkpat $ PpatAlias $1 (mkRHS $3 3) }+ | Pattern as error {% alexError "Pattern as <ERROR>" }+ | PatternCommaList %prec belowComma { mkpat $ PpatTuple (reverse $1) }+ | Pattern "::" Pattern { mkpatCons (rhsLoc 2) (ghpat $ PpatTuple [$1, $3]) (symbolRLoc ()) }+ | Pattern "::" error {% alexError "Pattern :: <ERROR>" }+ | Pattern "|" Pattern { mkpat $ PpatOr $1 $3 }+ | Pattern "|" error {% alexError "Pattern | <ERROR>" }+ -- | exception ExtAttributes Pattern %prec precConstrAppl { mkpatAttrs (PpatException $3) $2 }+ -- | Pattern Attribute { attrPat $1 $2 }+ | PatternGen { $1 }++PatternCommaList :: { [Pattern] }+ : PatternCommaList "," Pattern { $3 : $1 }+ | Pattern "," Pattern { [$3, $1] }+ | Pattern "," error {% alexError "Pattern , <ERROR>" }++PatternGen :: { Pattern }+ : SimplePattern { $1 }+ | ConstrLongident Pattern %prec precConstrAppl { mkpat $ PpatConstruct (mkRHS $1 1) (Just $2) }+ | NameTag Pattern %prec precConstrAppl { mkpat $ PpatVariant $1 (Just $2) }+ | lazy ExtAttributes SimplePattern { mkpatAttrs (PpatLazy $3) $2 }++PatternNoExn :: { Pattern }+ : PatternNoExn as ValIdent { mkpat $ PpatAlias $1 (mkRHS $3 3) }+ | PatternNoExn as error {% alexError "PatternNoExn as <ERROR>" }+ | PatternNoExnCommaList %prec belowComma { mkpat $ PpatTuple (reverse $1) }+ | PatternNoExn "::" Pattern { mkpatCons (rhsLoc 2) (ghpat $ PpatTuple [$1, $3]) (symbolRLoc ()) }+ | PatternNoExn "::" error {% alexError "PatternNoExn :: <ERROR>" }+ | PatternNoExn "|" Pattern { mkpat $ PpatOr $1 $3 }+ | PatternNoExn "|" error {% alexError "PatternNoExn | <ERROR>" }+ | PatternNoExn Attribute { Pat.attr $1 $2 }+ | PatternGen { $1 }++PatternNoExnCommaList :: { [Pattern] }+ : PatternNoExnCommaList "," Pattern { $3 : $1 }+ | PatternNoExn "," Pattern { [$3, $1] }+ | PatternNoExn "," error {% alexError "PatternNoExn , <ERROR>" }++PatternSemiList :: { [Pattern] }+ : Pattern { [$1] }+ | PatternSemiList ";" Pattern { $3 : $1 }++PatternVar :: { Pattern }+ : LIDENT { mkpat $ PpatVar (mkRHS $1 1) }+ | "_" { mkpat $ PpatAny }++Payload :: { Payload }+ : Structure { PStr $1 }+ -- | ":" Signature { PSig $2 }+ -- TODO++PolyType :: { CoreType }+ : CoreType { $1 }+ | TypeVarList "." CoreType { mktyp $ PtypPoly (reverse $1) $3 }++PolyTypeNoAttr :: { CoreType }+ : CoreTypeNoAttr { $1 }+ | TypeVarList "." CoreTypeNoAttr { mktyp $ PtypPoly (reverse $1) $3 }++PostItemAttribute :: { (Loc String, Payload) }+ : "[@@" AttrId Payload "]" { ($2, $3) }++PostItemAttributes :: { Attributes }+ : {- empty -} { [] }+ | PostItemAttribute PostItemAttributes { $1 : $2 }++PrimitiveDeclaration :: { (ValueDescription, Maybe (Loc String)) }+ : external ExtAttributes ValIdent ":" CoreType "=" PrimitiveDeclarationBody PostItemAttributes+ { let (ext, attrs) = $2 in+ ( Val.mk (def { prim = $7+ , attrs = attrs ++ $8+ , loc = symbolRLoc ()+ , docs = symbolDocs ()+ }+ )+ (mkRHS $3 3) $5+ , ext+ )+ }++PrimitiveDeclarationBody :: { [String] }+ : STRING { [fst $1] }+ | STRING PrimitiveDeclarationBody { fst $1 : $2 }++PrivateFlag :: { PrivateFlag }+ : {- empty -} { Public }+ | private { Private }++RecFlag :: { RecFlag }+ : {- empty -} { NonRecursive }+ | rec { Recursive }++RecordExpr :: { (Maybe Expression, [(Loc Longident, Expression)]) }+ : SimpleExpr with LblExprList { (Just $1, $3) }+ | LblExprList { (Nothing, $1) }++SeqExpr :: { Expression }+ : Expr %prec belowSemi { $1 }+ | Expr ";" { $1 }+ | Expr ";" SeqExpr { mkexp $ PexpSequence $1 $3 }+ | Expr ";" "%" AttrId SeqExpr { let seq = mkexp $ PexpSequence $1 $5 in+ let payload = PStr [mkstrexp seq []] in+ mkexp $ PexpExtension ($4, payload)+ }++SigExceptionDeclaration :: { (ExtensionConstructor, Maybe (Loc String)) }+ : exception ExtAttributes ConstrIdent GeneralizedConstructorArguments Attributes PostItemAttributes+ { let (args, res) = $4 in+ let (ext, attrs) = $2 in+ ( Te.decl (def { args+ , attrs = attrs ++ $5 ++ $6+ , loc = symbolRLoc ()+ , docs = symbolDocs ()+ }+ )+ res (mkRHS $3 3)+ , ext+ )+ }++-- Signature :: { [SignatureItem] }+-- : {- empty-} { [] }+-- | ";;" Signature { textSig 1 ++ $2 }+-- | SignatureItem Signature { textSig 1 ++ $1 : $2 }+--+-- SignatureItem :: { SignatureItem }+-- : ValueDescription { let (body, ext) = $1 in mksigExt (PsigValue body) ext }+-- -- TODO++SignedConstant :: { ParseTree.Constant }+ : Constant { $1 }+ | "-" INT { let (n, m) = $2 in PconstInteger ("-" ++ n) m }+ | "-" FLOAT { let (f, m) = $2 in PconstFloat ("-" ++ f) m }+ | "+" INT { let (n, m) = $2 in PconstInteger n m }+ | "+" FLOAT { let (f, m) = $2 in PconstFloat f m }++SimpleCoreType :: { CoreType }+ : SimpleCoreType2 %prec belowHash { $1 }+ | "(" CoreTypeCommaList ")" %prec belowHash {% case $2 of+ [sty] -> return sty+ _ -> alexError "( CoreTypeCommaList ) [expected length 1]"+ }++SimpleCoreType2 :: { CoreType }+ : "'" Ident { mktyp $ PtypVar $2 }+ | "_" { mktyp $ PtypAny }+ | TypeLongident { mktyp $ PtypConstr (mkRHS $1 1) [] }+ | SimpleCoreType2 TypeLongident { mktyp $ PtypConstr (mkRHS $2 2) [$1] }+ | "(" CoreTypeCommaList ")" TypeLongident { mktyp $ PtypConstr (mkRHS $4 4) (reverse $2) }+ | "<" MethList ">" { let (f, c) = $2 in+ mktyp $ PtypObject f c+ }+ | "<" ">" { mktyp $ PtypObject [] Closed }+ | "#" ClassLongident { mktyp $ PtypClass (mkRHS $2 2) [] }+ | "(" CoreTypeCommaList ")" "#" ClassLongident { mktyp $ PtypClass (mkRHS $5 5) (reverse $2) }+ | "[" TagField "]" { mktyp $ PtypVariant [$2] Closed Nothing }+ -- TODO+ | "[>" "]" { mktyp $ PtypVariant [] Open Nothing }++SimpleCoreTypeOrTuple :: { CoreType }+ : SimpleCoreType { $1 }+ | SimpleCoreType "*" CoreTypeList { mktyp $ PtypTuple ($1 : reverse $3) }++SimpleDelimitedPattern :: { Pattern }+ : "{" LblPatternList "}" { let (fields, closed) = $2 in mkpat $ PpatRecord fields closed }+ | "{" LblPatternList error {% alexError "{ LblPatternList <ERROR>" }+ | "[" PatternSemiList OptSemi "]" { relocPat $ mktailpat (rhsLoc 4) (reverse $2) }+ | "[" PatternSemiList OptSemi error {% alexError "[ PatternSemiList OptSemi <ERROR>" }+ | "[|" PatternSemiList OptSemi "|]" { mkpat $ PpatArray (reverse $2) }+ | "[|" "|]" { mkpat $ PpatArray [] }+ | "[|" PatternSemiList OptSemi error {% alexError "[| PatternSemiList OptSemi <ERROR>" }++SimpleExpr :: { Expression }+ : ValLongident { mkexp $ PexpIdent (mkRHS $1 1) }+ | Constant { mkexp $ PexpConstant $1 }+ | ConstrLongident %prec precConstantConstructor { mkexp $ PexpConstruct (mkRHS $1 1) Nothing }+ | NameTag %prec precConstantConstructor { mkexp $ PexpVariant $1 Nothing }+ | "(" SeqExpr ")" { relocExp $2 }+ | "(" SeqExpr error {% alexError "( SeqExpr <ERROR>" }+ | begin ExtAttributes SeqExpr end { wrapExpAttrs (relocExp $3) $2 }+ | begin ExtAttributes end { mkexpAttrs (PexpConstruct (mkLoc (Lident "()") (symbolRLoc ())) Nothing) $2 }+ | begin ExtAttributes error {% alexError "begin ExtAttributes <ERROR>" }+ | "(" SeqExpr TypeConstraint ")" { mkexpConstraint $2 $3 }+ | SimpleExpr "." LabelLongident { mkexp $ PexpField $1 (mkRHS $3 3) }+ | ModLongident "." "(" SeqExpr ")" { mkexp $ PexpOpen Fresh (mkRHS $1 1) $4 }+ | ModLongident "." "(" ")" { mkexp $ PexpOpen Fresh (mkRHS $1 1) (mkexp $ PexpConstruct (mkRHS (Lident "()") 1) Nothing) }+ | ModLongident "." "(" SeqExpr error {% alexError "TODO" }+ | SimpleExpr "." "(" SeqExpr ")" { error "TODO 1" }+ | SimpleExpr "." "(" SeqExpr { error "TODO 2" }+ | SimpleExpr "." "[" SeqExpr "]" { error "TODO 3" }+ | SimpleExpr "." "[" SeqExpr { error "TODO 4" }+ | SimpleExpr DOTOP "[" SeqExpr "]" { error "TODO 5" }+ | SimpleExpr DOTOP "[" SeqExpr { error "TODO 6" }+ | SimpleExpr DOTOP "(" Expr ")" { error "TODO 7" }+ | SimpleExpr DOTOP "(" Expr { error "TODO 8" }+ | SimpleExpr DOTOP "{" Expr "}" { error "TODO 9" }+ | SimpleExpr DOTOP "{" Expr { error "TODO 11" }+ | SimpleExpr "." ModLongident DOTOP "[" Expr "]" { error "TODO 12" }+ | SimpleExpr "." ModLongident DOTOP "[" Expr { error "TODO 13" }+ | SimpleExpr "." ModLongident DOTOP "(" Expr ")" { error "TODO 14" }+ | SimpleExpr "." ModLongident DOTOP "(" Expr { error "TODO 15" }+ | SimpleExpr "." ModLongident DOTOP "{" Expr "}" { error "TODO 16" }+ | SimpleExpr "." ModLongident DOTOP "{" Expr { error "TODO 17" }+ | SimpleExpr "." "{" Expr "}" { error "TODO 18" }+ | SimpleExpr "." "{" ExprCommaList { error "TODO 19" }+ | "{" RecordExpr "}" { error "TODO 20" }+ | "{" RecordExpr { error "TODO 21" }+ | ModLongident "." "{" RecordExpr "}" { error "TODO 22" }+ | ModLongident "." "{" RecordExpr { error "TODO 23" }+ | "[|" ExprSemiList OptSemi "|]" { error "TODO 24" }+ | "[|" ExprSemiList OptSemi { error "TODO 25" }+ | "[|" "|]" { error "TODO 26" }+ | ModLongident "." "[|" ExprSemiList OptSemi "|]" { error "TODO 27" }+ | ModLongident "." "[|" "|]" { error "TODO 28" }+ | ModLongident "." "[|" ExprSemiList OptSemi { error "TODO 29" }+ | "[" ExprSemiList OptSemi "]" { relocExp $ mktailexp (rhsLoc 4) (reverse $2) }+ | "[" ExprSemiList OptSemi error {% alexError "TODO" }+ | ModLongident "." "[" ExprSemiList OptSemi "]" { error "TODO 30" }+ | ModLongident "." "[" "]" { error "TODO 31" }+ | ModLongident "." "[" ExprSemiList OptSemi { error "TODO 32" }+ | PREFIXOP SimpleExpr { error "TODO 33" }+ | "!" SimpleExpr { mkexp $ PexpApply (mkOperator "!" 1) [(Nolabel, $2)] }+ | new ExtAttributes ClassLongident { mkexpAttrs (PexpNew (mkRHS $3 3)) $2 }+ | "{<" FieldExprList ">}" { mkexp $ PexpOverride $2 }+ | "{<" FieldExprList error {% alexError "TODO" }+ | "{<" ">}" { mkexp $ PexpOverride [] }+ | ModLongident "." "{<" FieldExprList ">}" { mkexp $ PexpOpen Fresh (mkRHS $1 1) (mkexp $ PexpOverride $4) }+ -- TODO++SimpleLabeledExprList :: { [(ArgLabel, Expression)] }+ : LabeledSimpleExpr { [$1] }+ | SimpleLabeledExprList LabeledSimpleExpr { $2 : $1 }++SimplePattern :: { Pattern }+ : ValIdent %prec belowEqual { mkpat $ PpatVar (mkRHS $1 1) }+ | SimplePatternNotIdent { $1 }++SimplePatternNotIdent :: { Pattern }+ : "_" { mkpat $ PpatAny }+ | SignedConstant { mkpat $ PpatConstant $1 }+ | SignedConstant ".." SignedConstant { mkpat $ PpatInterval $1 $3 }+ | ConstrLongident { mkpat $ PpatConstruct (mkRHS $1 1) Nothing }+ | NameTag { mkpat $ PpatVariant $1 Nothing }+ | "#" TypeLongident { mkpat $ PpatType (mkRHS $2 2) }+ | SimpleDelimitedPattern { $1 }+ | ModLongident "." SimpleDelimitedPattern { mkpat $ PpatOpen (mkRHS $1 1) $3 }+ | ModLongident "." "{" "}" { mkpat $ PpatOpen (mkRHS $1 1) (mkpat $ PpatConstruct (mkRHS (Lident "[]") 4) Nothing) }+ | ModLongident "." "(" ")" { mkpat $ PpatOpen (mkRHS $1 1) (mkpat $ PpatConstruct (mkRHS (Lident "()") 4) Nothing) }+ | ModLongident "." "(" Pattern ")" { mkpat $ PpatOpen (mkRHS $1 1) $4 }+ | ModLongident "." "(" error {% alexError "ModLongident . ( <ERROR>" }+ | "(" Pattern ")" { relocPat $2 }+ | "(" Pattern error {% alexError "( Pattern <ERROR>" }+ | "(" Pattern ":" CoreType ")" { mkpat $ PpatConstraint $2 $4 }+ | "(" Pattern ":" CoreType error {% alexError "( Pattern : CoreType <ERROR>" }+ | "(" Pattern ":" error {% alexError "( Pattern : <ERROR>" }+ | "(" module ExtAttributes UIDENT ")" { mkpatAttrs (PpatUnpack (mkRHS $4 4)) $3 }+ | "(" module ExtAttributes UIDENT ":" PackageType ")" { mkpatAttrs (PpatConstraint (mkpat $ PpatUnpack (mkRHS $4 4)) (ghtyp $ PtypPackage $6)) $3 }+ | "(" module ExtAttributes UIDENT ":" PackageType error {% alexError "( module ExtAttributes UIDENT : PackageType <ERROR>" }+ | Extension { mkpat $ PpatExtension $1 }++SingleAttrId :: { String }+ : LIDENT { $1 }+ | UIDENT { $1 }+ -- | and { "and" }+ -- | as { "as" }+ -- | assert { "assert" }+ -- | begin { "begin" }+ -- | class { "class" }+ -- TODO++StrExceptionDeclaration :: { (ExtensionConstructor, Maybe (Loc String)) }+ : SigExceptionDeclaration { $1 }+ | exception ExtAttributes ConstrIdent+ "=" ConstrLongident Attributes PostItemAttributes { let (ext, attrs) = $2 in+ ( Te.rebind (def { attrs = attrs ++ $6 ++ $7+ , loc = symbolRLoc ()+ , docs = symbolDocs ()+ })+ (mkRHS $3 3) (mkRHS $5 5)+ , ext+ )+ }++StrictBinding :: { Expression }+ : "=" SeqExpr { $2 }+ | LabeledSimplePattern FunBinding { let (l, o, p) = $1 in+ ghexp $ PexpFun l o p $2+ }+ -- | "(" LidentList ")" FunBinding { mk_newtypes $3 $5 }++Structure :: { Structure }+ : SeqExpr PostItemAttributes StructureTail { do+ -- TODO: mark_rhsDocs 1 2+ (textStr 1) ++ mkstrexp $1 $2 : $3+ }+ | StructureTail { $1 }++StructureItem :: { StructureItem }+ : LetBindings { valOfLetBindings $1 }+ | PrimitiveDeclaration { let (body, ext) = $1 in mkstrExt (PstrPrimitive body) ext }+ | ValueDescription { let (body, ext) = $1 in mkstrExt (PstrPrimitive body) ext }+ | TypeDeclarations { let (nr, l, ext) = $1 in mkstrExt (PstrType nr (reverse l)) ext }+ -- | StrTypeExtension { let (l, ext) = $1 in mkstrExt (PstrTypExt l) ext }+ | StrExceptionDeclaration { let (l, ext) = $1 in mkstrExt (PstrException l) ext }+ | ModuleBinding { let (body, ext) = $1 in mkstrExt (PstrModule body) ext }+ -- TODO: RecModuleBindings+ | ModuleTypeDeclaration { let (body, ext) = $1 in mkstrExt (PstrModType body) ext }+ | OpenStatement { let (body, ext) = $1 in mkstrExt (PstrOpen body) ext }+ -- TODO: ClassDeclarations+ -- TODO: ClassTypeDeclarations+ -- TODO: StrIncludeStatement+ -- TODO: ItemExtension PostItemAttributes+ -- TODO: FloatingAttribute++StructureTail :: { Structure }+ : {- empty -} { [] }+ | "::" Structure { (textStr 1) ++ $2 }+ | StructureItem StructureTail { (textStr 1) ++ $1 : $2 }++TagField :: { RowField }+ : NameTag of OptAmpersand AmperTypeList Attributes { Rtag (mkRHS $1 1) (addInfoAttrs (symbolInfo ()) $5) $3 (reverse $4) }+ -- TODO++TypeConstraint :: { (Maybe CoreType, Maybe CoreType) }+ : ":" CoreType { (Just $2, Nothing) }+ | ":" CoreType ":>" CoreType { (Just $2, Just $4) }+ | ":>" CoreType { (Nothing, Just $2) }+ | ":" error {% alexError ": <ERROR>" }+ | ":>" error {% alexError ":> <ERROR>" }++TypeDeclaration :: { (RecFlag, TypeDeclaration, Maybe (Loc String)) }+ : type ExtAttributes RecFlag OptionalTypeParameters LIDENT+ TypeKind Constraints PostItemAttributes+ { let (kind, priv, manifest) = $6 in+ let (ext, attrs) = $2 in+ let ty = Type.mk (def { params = $4+ , cstrs = reverse $7+ , kind+ , priv+ , attrs = attrs ++ $8+ , loc = symbolRLoc ()+ , docs = symbolDocs ()+ }+ )+ manifest (mkRHS $5 5)+ in ($3, ty, ext)+ }++TypeDeclarations :: { (RecFlag, [TypeDeclaration], Maybe (Loc String)) }+ : TypeDeclaration { let (nonRecFlag, ty, ext) = $1 in+ (nonRecFlag, [ty], ext)+ }+ | TypeDeclarations AndTypeDeclaration { let (nonRecFlag, tys, ext) = $1 in+ (nonRecFlag, $2 : tys, ext)+ }++TypeKind :: { (TypeKind, PrivateFlag, Maybe CoreType) }+ : {- empty-} { (PtypeAbstract, Public, Nothing) }+ | "=" CoreType { (PtypeAbstract, Public, Just $2) }+ | "=" private CoreType { (PtypeAbstract, Private, Just $3) }+ | "=" ConstructorDeclarations { (PtypeVariant (reverse $2), Public, Nothing) }+ | "=" private ConstructorDeclarations { (PtypeVariant (reverse $3), Private, Nothing) }+ | "=" ".." { (PtypeOpen, Public, Nothing) }+ | "=" private ".." { (PtypeOpen, Private, Nothing) }+ | "=" PrivateFlag "{" LabelDeclarations "}" { (PtypeRecord $4, $2, Nothing) }+ | "=" CoreType "=" PrivateFlag ConstructorDeclarations { (PtypeVariant (reverse $5), $4, Just $2) }+ | "=" CoreType "=" PrivateFlag ".." { (PtypeOpen, $4, Just $2) }+ | "=" CoreType "=" PrivateFlag "{" LabelDeclarations "}" { (PtypeRecord $6, $4, Just $2) }++TypeLongident :: { Longident }+ : LIDENT { Lident $1 }+ | ModExtLongident "." LIDENT { Ldot $1 $3 }++TypeVariance :: { Variance }+ : {- empty-} { Invariant }+ | "+" { Covariant }+ | "-" { Contravariant }++TypeVarList :: { [Loc String] }+ : "'" Ident { [mkRHS $2 2] }+ | TypeVarList "'" Ident { mkRHS $3 3 : $1 }++ValIdent :: { String }+ : LIDENT { $1 }+ | "(" Operator ")" { error "TODO ValIdent" }+ -- TODO++ValLongident :: { Longident }+ : ValIdent { Lident $1 }+ | ModLongident "." ValIdent { Ldot $1 $3 }++ValueDescription :: { (ValueDescription, Maybe (Loc String)) }+ : val ExtAttributes ValIdent ":" CoreType PostItemAttributes+ { let (ext, attrs) = $2 in+ ( Val.mk (def { attrs = attrs ++ $6+ , loc = symbolRLoc ()+ , docs = symbolDocs ()+ })+ (mkRHS $3 3) $5+ , ext+ )+ }++{++parseError :: ResultToken -> Alex a+parseError (Located (SrcSpan {..}) tok) = do+ alexError $ printf "unexpected token %s at line %s, column %s"+ (show tok) (show srcSpanStartLine) (show srcSpanStartCol)++type Parser a = String -> Either String a++parseExpr :: Parser Expression+parseExpr = myParse rawParseExpr++parseExprCommaList :: Parser [Expression]+parseExprCommaList = myParse rawParseExprCommaList++parseImplementation :: Parser [StructureItem]+parseImplementation = myParse rawParseImplementation++parseModLongident :: Parser Longident+parseModLongident = myParse rawParseModLongident++parseOpenStatement :: Parser (OpenDescription, Maybe (Loc String))+parseOpenStatement = myParse rawParseOpenStatement++parsePattern :: Parser Pattern+parsePattern = myParse rawParsePattern++parseSeqExpr :: Parser Expression+parseSeqExpr = myParse rawParseSeqExpr++parseSimpleExpr :: Parser Expression+parseSimpleExpr = myParse rawParseSimpleExpr++parseStructure :: Parser Structure+parseStructure = myParse rawParseStructure++parseStructureItem :: Parser StructureItem+parseStructureItem = myParse rawParseStructureItem++parseValIdent :: Parser String+parseValIdent = myParse rawParseValIdent++parseValLongident :: Parser Longident+parseValLongident = myParse rawParseValLongident++myParse :: Alex a -> String -> Either String a+myParse = flip runAlex++}
+ lib/Language/OCaml/Parser/Implementation.hs view
@@ -0,0 +1,13 @@+module Language.OCaml.Parser.Implementation+ ( implementationP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Structure+import Language.OCaml.Parser.Utils.Utils+import Language.OCaml.Parser.Utils.Types++implementationP :: Parser Structure+implementationP = ocamlSpace *> structureP <* eof
+ lib/Language/OCaml/Parser/Internal.hs view
@@ -0,0 +1,200 @@+module Language.OCaml.Parser.Internal+ ( module Language.OCaml.Parser.Tokens+ , Parser+ , attributeP+ , attributesP+ , barConstructorDeclarationP+ , constantP+ , constrIdentP+ , constrLongidentP+ , constructorArgumentsP+ , constructorDeclarationP+ , constructorDeclarationsP+ , coreTypeP+ , coreType2P+ , coreTypeCommaListP+ , coreTypelistP+ , exprP+ , generalizedConstructorArgumentsP+ , identP+ , implementationP+ , labeledSimpleExprP+ , lblExprP+ , lblExprListP+ , letBindingP+ , letBindingBodyP+ , matchCaseP+ , modLongidentP+ , openStatementP+ , patternP+ , patternNoExnP+ , postItemAttributesP+ , recordExprP+ , seqExprP+ , simpleCoreTypeP+ , simpleCoreType2P+ , simpleCoreTypeOrTupleP+ , simpleExprP+ , simpleLabeledExprListP+ , simplePatternP+ , structureP+ , structureItemP+ , typeDeclarationP+ , typeDeclarationsP+ , typeKindP+ , valIdentP+ , valLongidentP+ ) where++import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.Parser.LetBindings+import Language.OCaml.Definitions.Parsing.ParseTree+import qualified Language.OCaml.Parser.Attribute+import qualified Language.OCaml.Parser.Attributes+import qualified Language.OCaml.Parser.BarConstructorDeclaration+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.Constant+import Language.OCaml.Parser.ConstrIdent+import Language.OCaml.Parser.ConstrLongident+import qualified Language.OCaml.Parser.ConstructorArguments+import qualified Language.OCaml.Parser.ConstructorDeclaration+import qualified Language.OCaml.Parser.ConstructorDeclarations+import Language.OCaml.Parser.CoreType+import qualified Language.OCaml.Parser.CoreType2+import qualified Language.OCaml.Parser.CoreTypeCommaList+import qualified Language.OCaml.Parser.CoreTypeList+import qualified Language.OCaml.Parser.Expr+import qualified Language.OCaml.Parser.GeneralizedConstructorArguments+import Language.OCaml.Parser.Implementation+import qualified Language.OCaml.Parser.LabeledSimpleExpr+import qualified Language.OCaml.Parser.LblExpr+import qualified Language.OCaml.Parser.LblExprList+import qualified Language.OCaml.Parser.LetBinding+import qualified Language.OCaml.Parser.LetBindingBody+import qualified Language.OCaml.Parser.MatchCase+import Language.OCaml.Parser.ModLongident+import Language.OCaml.Parser.OpenStatement+import Language.OCaml.Parser.Pattern+import Language.OCaml.Parser.PatternNoExn+import qualified Language.OCaml.Parser.PostItemAttributes+import qualified Language.OCaml.Parser.RecordExpr+import qualified Language.OCaml.Parser.SeqExpr+import qualified Language.OCaml.Parser.SimpleCoreType+import qualified Language.OCaml.Parser.SimpleCoreType2+import qualified Language.OCaml.Parser.SimpleCoreTypeOrTuple+import qualified Language.OCaml.Parser.SimpleExpr+import qualified Language.OCaml.Parser.SimpleLabeledExprList+import qualified Language.OCaml.Parser.SimplePattern+import Language.OCaml.Parser.Structure+import qualified Language.OCaml.Parser.StructureItem+import Language.OCaml.Parser.Tokens+import qualified Language.OCaml.Parser.TypeDeclaration+import qualified Language.OCaml.Parser.TypeDeclarations+import qualified Language.OCaml.Parser.TypeKind+import Language.OCaml.Parser.ValIdent+import Language.OCaml.Parser.ValLongident+import Language.OCaml.Parser.Utils.Types++-- Tying the knots for our clients!++attributeP :: Parser (Loc String, Payload)+attributeP = Language.OCaml.Parser.Attribute.attributeP structureP++attributesP :: Parser [(Loc String, Payload)]+attributesP = Language.OCaml.Parser.Attributes.attributesP structureP++barConstructorDeclarationP :: Parser ConstructorDeclaration+barConstructorDeclarationP =+ Language.OCaml.Parser.BarConstructorDeclaration.barConstructorDeclarationP structureP coreTypeP++constructorArgumentsP :: Parser ConstructorArguments+constructorArgumentsP =+ Language.OCaml.Parser.ConstructorArguments.constructorArgumentsP coreTypeP++constructorDeclarationP :: Parser ConstructorDeclaration+constructorDeclarationP =+ Language.OCaml.Parser.ConstructorDeclaration.constructorDeclarationP structureP coreTypeP++constructorDeclarationsP :: Parser [ConstructorDeclaration]+constructorDeclarationsP =+ Language.OCaml.Parser.ConstructorDeclarations.constructorDeclarationsP structureP coreTypeP++coreType2P :: Parser CoreType+coreType2P = Language.OCaml.Parser.CoreType2.coreType2P coreTypeP++coreTypeCommaListP :: Parser [CoreType]+coreTypeCommaListP =+ Language.OCaml.Parser.CoreTypeCommaList.coreTypeCommaListP coreTypeP++coreTypelistP :: Parser [CoreType]+coreTypelistP = Language.OCaml.Parser.CoreTypeList.coreTypelistP coreTypeP++exprP :: Parser Expression+exprP = Language.OCaml.Parser.Expr.exprP structureP seqExprP++generalizedConstructorArgumentsP :: Parser (ConstructorArguments, Maybe a)+generalizedConstructorArgumentsP =+ Language.OCaml.Parser.GeneralizedConstructorArguments.generalizedConstructorArgumentsP+ coreTypeP++lblExprP :: Parser (Loc Longident, Expression)+lblExprP = Language.OCaml.Parser.LblExpr.lblExprP exprP++lblExprListP :: Parser [(Loc Longident, Expression)]+lblExprListP = Language.OCaml.Parser.LblExprList.lblExprListP exprP++labeledSimpleExprP :: Parser (ArgLabel, Expression)+labeledSimpleExprP =+ Language.OCaml.Parser.LabeledSimpleExpr.labeledSimpleExprP seqExprP exprP++letBindingP :: Parser LetBindings+letBindingP =+ Language.OCaml.Parser.LetBinding.letBindingP structureP seqExprP++letBindingBodyP :: Parser (Pattern, Expression)+letBindingBodyP =+ Language.OCaml.Parser.LetBindingBody.letBindingBodyP seqExprP++matchCaseP :: Parser Case+matchCaseP = Language.OCaml.Parser.MatchCase.matchCaseP seqExprP++postItemAttributesP :: Parser [(Loc String, Payload)]+postItemAttributesP = Language.OCaml.Parser.PostItemAttributes.postItemAttributesP structureP++recordExprP :: Parser (Maybe Expression, [(Loc Longident, Expression)])+recordExprP = Language.OCaml.Parser.RecordExpr.recordExprP exprP simpleExprP++seqExprP :: Parser Expression+seqExprP = Language.OCaml.Parser.SeqExpr.seqExprP structureP++simpleCoreTypeP :: Parser CoreType+simpleCoreTypeP = Language.OCaml.Parser.SimpleCoreType.simpleCoreTypeP coreTypeP++simpleCoreType2P :: Parser CoreType+simpleCoreType2P = Language.OCaml.Parser.SimpleCoreType2.simpleCoreType2P coreTypeP++simpleCoreTypeOrTupleP :: Parser CoreType+simpleCoreTypeOrTupleP =+ Language.OCaml.Parser.SimpleCoreTypeOrTuple.simpleCoreTypeOrTupleP coreTypeP++simpleExprP :: Parser Expression+simpleExprP = Language.OCaml.Parser.SimpleExpr.simpleExprP seqExprP exprP++simpleLabeledExprListP :: Parser [(ArgLabel, Expression)]+simpleLabeledExprListP =+ Language.OCaml.Parser.SimpleLabeledExprList.simpleLabeledExprListP seqExprP exprP++simplePatternP :: Parser Pattern+simplePatternP = Language.OCaml.Parser.SimplePattern.simplePatternP patternP++structureItemP :: Parser StructureItem+structureItemP = Language.OCaml.Parser.StructureItem.structureItemP structureP++typeDeclarationP :: Parser (RecFlag, TypeDeclaration)+typeDeclarationP = Language.OCaml.Parser.TypeDeclaration.typeDeclarationP structureP++typeDeclarationsP :: Parser (RecFlag, [TypeDeclaration])+typeDeclarationsP = Language.OCaml.Parser.TypeDeclarations.typeDeclarationsP structureP++typeKindP :: Parser (TypeKind, PrivateFlag, Maybe CoreType)+typeKindP = Language.OCaml.Parser.TypeKind.typeKindP structureP
+ lib/Language/OCaml/Parser/Label.hs view
@@ -0,0 +1,9 @@+module Language.OCaml.Parser.Label+ ( labelP+ ) where++import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++labelP :: Parser String+labelP = lIdentT
+ lib/Language/OCaml/Parser/LabelDeclaration.hs view
@@ -0,0 +1,24 @@+module Language.OCaml.Parser.LabelDeclaration+ ( labelDeclarationP+ ) where++import Data.Default+import Text.Megaparsec hiding (label)++import Language.OCaml.Definitions.Parsing.ASTHelper.Type as Type+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.Label+import Language.OCaml.Parser.MutableFlag+import Language.OCaml.Parser.PolyTypeNoAttr+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++labelDeclarationP :: Parser LabelDeclaration+labelDeclarationP = try $ do+ _mut <- mutableFlagP+ label <- labelP+ colonT+ t <- polyTypeNoAttrP+ -- TODO: attributes+ return $ field def (mkRHS label 2) t -- FIXME: def
+ lib/Language/OCaml/Parser/LabelDeclarationSemi.hs view
@@ -0,0 +1,26 @@+module Language.OCaml.Parser.LabelDeclarationSemi+ ( labelDeclarationSemiP+ ) where++import Data.Default+import Text.Megaparsec hiding (label)++import Language.OCaml.Definitions.Parsing.ASTHelper.Type as Type+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.Label+import Language.OCaml.Parser.MutableFlag+import Language.OCaml.Parser.PolyTypeNoAttr+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++labelDeclarationSemiP :: Parser LabelDeclaration+labelDeclarationSemiP = try $ do+ _mut <- mutableFlagP+ label <- labelP+ colonT+ t <- polyTypeNoAttrP+ -- TODO: attributes+ semiT+ -- TODO: attributes+ return $ Type.field def (mkRHS label 2) t -- FIXME: def
+ lib/Language/OCaml/Parser/LabelDeclarations.hs view
@@ -0,0 +1,20 @@+module Language.OCaml.Parser.LabelDeclarations+ ( labelDeclarationsP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.LabelDeclaration+import Language.OCaml.Parser.LabelDeclarationSemi+import Language.OCaml.Parser.Utils.Types++labelDeclarationsP :: Parser [LabelDeclaration]+labelDeclarationsP = choice+ [ do+ h <- labelDeclarationSemiP+ t <- labelDeclarationsP+ return $ h : t+ , (: []) <$> labelDeclarationSemiP+ , (: []) <$> labelDeclarationP+ ]
+ lib/Language/OCaml/Parser/LabelLongident.hs view
@@ -0,0 +1,20 @@+module Language.OCaml.Parser.LabelLongident+ ( labelLongidentP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.ModLongident+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++labelLongidentP :: Parser Longident+labelLongidentP = choice+ [ Lident <$> lIdentT+ , do+ m <- modLongidentP+ dotT+ i <- lIdentT+ return $ Ldot m i+ ]
+ lib/Language/OCaml/Parser/LabeledSimpleExpr.hs view
@@ -0,0 +1,18 @@+module Language.OCaml.Parser.LabeledSimpleExpr+ ( labeledSimpleExprP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.SimpleExpr+import Language.OCaml.Parser.Utils.Types++labeledSimpleExprP :: Parser Expression -> Parser Expression -> Parser (ArgLabel, Expression)+labeledSimpleExprP seqExprP exprP = choice+ [ do+ e <- simpleExprP seqExprP exprP+ return (Nolabel, e)+ -- TODO: labelExpr+ ]
+ lib/Language/OCaml/Parser/LabeledSimplePattern.hs view
@@ -0,0 +1,18 @@+module Language.OCaml.Parser.LabeledSimplePattern+ ( labeledSimplePatternP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.SimplePattern+import Language.OCaml.Parser.Utils.Types++labeledSimplePatternP :: Parser Pattern -> Parser (ArgLabel, Maybe a, Pattern)+labeledSimplePatternP patternP = choice+ [ -- TODO: lots of things+ do+ p <- simplePatternP patternP+ return (Nolabel, Nothing, p)+ ]
+ lib/Language/OCaml/Parser/LblExpr.hs view
@@ -0,0 +1,23 @@+module Language.OCaml.Parser.LblExpr+ ( lblExprP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.LabelLongident+import Language.OCaml.Parser.OptTypeConstraint+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++lblExprP :: Parser Expression -> Parser (Loc Longident, Expression)+lblExprP exprP = choice+ [ do+ i <- labelLongidentP+ c <- optTypeConstraintP+ equalT+ e <- exprP+ return (mkRHS i 1, mkexpOptConstraint e c)+ ]
+ lib/Language/OCaml/Parser/LblExprList.hs view
@@ -0,0 +1,31 @@+module Language.OCaml.Parser.LblExprList+ ( lblExprListP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.LblExpr+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++-- FIXME: Right now, this is made to look like the OCaml parser, but we could+-- optimize everything by factoring out the left parsers that are the same.++lblExprListP :: Parser Expression -> Parser [(Loc Longident, Expression)]+lblExprListP exprP = choice+ [ try $ do+ e <- lblExprP'+ semiT+ l <- lblExprListP'+ return $ e : l+ , try $ do+ e <- lblExprP'+ semiT+ return [e]+ , (: []) <$> lblExprP'+ ]+ where+ lblExprP' = lblExprP exprP+ lblExprListP' = lblExprListP exprP
+ lib/Language/OCaml/Parser/LblPattern.hs view
@@ -0,0 +1,29 @@+module Language.OCaml.Parser.LblPattern+ ( lblPatternP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.LabelLongident+import Language.OCaml.Parser.OptPatternTypeConstraint+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++lblPatternP :: Parser Pattern -> Parser (Loc Longident, Pattern)+lblPatternP patternP = choice+ [ do+ (i, c) <- try $ do+ i <- labelLongidentP+ c <- optPatternTypeConstraintP+ equalT+ return (i, c)+ p <- patternP+ return (mkRHS i 1, mkpatOptConstraint p c)+ , do+ i <- labelLongidentP+ c <- optPatternTypeConstraintP+ return (mkRHS i 1, mkpatOptConstraint (patOfLabel i 1) c)+ ]
+ lib/Language/OCaml/Parser/LblPatternList.hs view
@@ -0,0 +1,40 @@+module Language.OCaml.Parser.LblPatternList+ ( lblPatternListP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.LblPattern+import Language.OCaml.Parser.OptSemi+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++-- FIXME: Right now, this is made to look like the OCaml parser, but we could+-- optimize everything by factoring out the left parsers that are the same.++lblPatternListP :: Parser Pattern -> Parser ([(Loc Longident, Pattern)], ClosedFlag)+lblPatternListP patternP = choice+ [ try $ do+ p <- lblPatternP'+ semiT+ (fields, closed) <- lblPatternListP'+ return (p : fields, closed)+ , try $ do+ p <- lblPatternP'+ semiT+ underscoreT+ optSemiP+ return ([p], Open)+ , try $ do+ p <- lblPatternP'+ semiT+ return ([p], Closed)+ , do+ p <- lblPatternP'+ return ([p], Closed)+ ]+ where+ lblPatternP' = lblPatternP patternP+ lblPatternListP' = lblPatternListP patternP
+ lib/Language/OCaml/Parser/LetBinding.hs view
@@ -0,0 +1,23 @@+module Language.OCaml.Parser.LetBinding+ ( letBindingP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.Parser.LetBindings+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.LetBindingBody+import Language.OCaml.Parser.PostItemAttributes+import Language.OCaml.Parser.RecFlag+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++letBindingP :: Parser Structure -> Parser Expression -> Parser LetBindings+letBindingP structureP seqExprP = do+ try letT+ -- TODO: extAttributes+ r <- recFlagP+ b <- letBindingBodyP seqExprP+ _a <- postItemAttributesP structureP+ return $ mklbs Nothing r (mklb True b []) -- FIXME
+ lib/Language/OCaml/Parser/LetBindingBody.hs view
@@ -0,0 +1,61 @@+module Language.OCaml.Parser.LetBindingBody+ ( letBindingBodyP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.CoreType+import Language.OCaml.Parser.FunBinding+import Language.OCaml.Parser.Pattern+import Language.OCaml.Parser.PatternNoExn+import Language.OCaml.Parser.SimplePatternNotIdent+import Language.OCaml.Parser.StrictBinding+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.TypeConstraint+import Language.OCaml.Parser.ValIdent+import Language.OCaml.Parser.Utils.Types++letBindingBodyP :: Parser Expression -> Parser (Pattern, Expression)+letBindingBodyP seqExprP = choice+ [ try $ do+ i <- valIdentP+ b <- strictBindingP seqExprP (funBindingP seqExprP)+ return (mkpatvar i 1, b)+ , do+ (i, c) <- try $ do+ i <- valIdentP+ c <- typeConstraintP+ return (i, c)+ equalT+ e <- seqExprP+ let v = mkpatvar i 1+ let t = case c of+ (Just t', Nothing) -> t'+ (_, Just t') -> t'+ _ -> error "This should not happen"+ return ( ghpat $ PpatConstraint v (ghtyp $ PtypPoly [] t)+ , mkexpConstraint e c+ )+ -- TODO: typevarList+ -- TODO: lidentList+ , do+ p <- try $ do+ p <- patternNoExnP+ equalT+ return p+ e <- seqExprP+ return (p, e)+ , do+ p <- try $ do+ p <- simplePatternNotIdentP patternP+ colonT+ return p+ t <- coreTypeP+ equalT+ e <- seqExprP+ return ( ghpat $ PpatConstraint p t+ , e+ )+ ]
+ lib/Language/OCaml/Parser/LetBindings.hs view
@@ -0,0 +1,28 @@+module Language.OCaml.Parser.LetBindings+ ( letBindingsP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Definitions.Parsing.Parser.LetBindings+import Language.OCaml.Parser.Common+-- import Language.OCaml.Parser.Attributes+import Language.OCaml.Parser.LetBinding+import Language.OCaml.Parser.LetBindingBody+import Language.OCaml.Parser.PostItemAttributes+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Combinators+import Language.OCaml.Parser.Utils.Types++letBindingsP :: Parser Structure -> Parser Expression -> Parser LetBindings+letBindingsP structureP seqExprP = leftRecursive+ [ letBindingP structureP seqExprP+ ]+ [ do+ try $ andT+ -- a <- attributesP+ b <- letBindingBodyP seqExprP+ _p <- postItemAttributesP structureP+ return $ \ x -> addlb x (mklb False b []) -- FIXME+ ]
+ lib/Language/OCaml/Parser/MatchCase.hs view
@@ -0,0 +1,33 @@+module Language.OCaml.Parser.MatchCase+ ( matchCaseP+ ) where++import Data.Default+import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ASTHelper.Exp as Exp hiding (try)+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Pattern+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++matchCaseP :: Parser Expression -> Parser Case+matchCaseP seqExprP = choice+ [ do+ p <- try $ do+ p <- patternP+ minusGreaterT+ return p+ e <- seqExprP+ return $ Exp.case' def p e+ , do+ p <- try $ do+ p <- patternP+ whenT+ return p+ w <- seqExprP+ minusGreaterT+ e <- seqExprP+ return $ Exp.case' (def { guard = Just w }) p e+ -- TODO: others+ ]
+ lib/Language/OCaml/Parser/MatchCases.hs view
@@ -0,0 +1,13 @@+module Language.OCaml.Parser.MatchCases+ ( matchCasesP+ ) where++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.MatchCase+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Combinators+import Language.OCaml.Parser.Utils.Types++matchCasesP :: Parser Expression -> Parser [Case]+matchCasesP seqExprP =+ chainl1' (matchCaseP seqExprP) (barT *> return (flip (:))) (: [])
+ lib/Language/OCaml/Parser/ModExtLongident.hs view
@@ -0,0 +1,21 @@+module Language.OCaml.Parser.ModExtLongident+ ( modExtLongidentP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Combinators+import Language.OCaml.Parser.Utils.Types++modExtLongidentP :: Parser Longident+modExtLongidentP = leftRecursive+ [ Lident <$> uIdentT+ ]+ [ try $ do+ dotT+ i <- uIdentT+ return $ \ x -> Ldot x i+ -- TODO: parens+ ]
+ lib/Language/OCaml/Parser/ModLongident.hs view
@@ -0,0 +1,11 @@+module Language.OCaml.Parser.ModLongident+ ( modLongidentP+ ) where++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Combinators+import Language.OCaml.Parser.Utils.Types++modLongidentP :: Parser Longident+modLongidentP = chainl1try' uIdentT (dotT *> return Ldot) Lident
+ lib/Language/OCaml/Parser/ModuleBinding.hs view
@@ -0,0 +1,25 @@+module Language.OCaml.Parser.ModuleBinding+ ( moduleBindingP+ ) where++import Data.Default+import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ASTHelper.Mb as Mb+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.ModuleBindingBody+import Language.OCaml.Parser.PostItemAttributes+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++moduleBindingP :: Parser Structure -> Parser (ModuleBinding, ())+moduleBindingP structureP = do+ try $ moduleT+ -- TODO: extAttributes+ i <- uIdentT+ b <- moduleBindingBodyP+ _a <- postItemAttributesP structureP+ return $ (Mb.mk def (mkRHS i 3) b -- FIXME+ , () -- FIXME+ )
+ lib/Language/OCaml/Parser/ModuleBindingBody.hs view
@@ -0,0 +1,18 @@+module Language.OCaml.Parser.ModuleBindingBody+ ( moduleBindingBodyP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.ModuleExpr+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++moduleBindingBodyP :: Parser ModuleExpr+moduleBindingBodyP = choice+ [ do+ try $ equalT+ moduleExprP+ -- TODO: rest+ ]
+ lib/Language/OCaml/Parser/ModuleExpr.hs view
@@ -0,0 +1,17 @@+module Language.OCaml.Parser.ModuleExpr+ ( moduleExprP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.ModLongident+import Language.OCaml.Parser.Utils.Types++moduleExprP :: Parser ModuleExpr+moduleExprP = choice+ [ do+ i <- modLongidentP+ return . mkmod Nothing $ PmodIdent (mkRHS i 1)+ ]
+ lib/Language/OCaml/Parser/MutableFlag.hs view
@@ -0,0 +1,15 @@+module Language.OCaml.Parser.MutableFlag+ ( mutableFlagP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++mutableFlagP :: Parser MutableFlag+mutableFlagP = choice+ [ mutableT *> return Mutable+ , return Immutable+ ]
+ lib/Language/OCaml/Parser/NonRecFlag.hs view
@@ -0,0 +1,15 @@+module Language.OCaml.Parser.NonRecFlag+ ( nonrecFlagP+ ) where++import Text.Megaparsec++import qualified Language.OCaml.Definitions.Parsing.ASTTypes as ASTTypes+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++nonrecFlagP :: Parser ASTTypes.RecFlag+nonrecFlagP = choice+ [ nonrecT *> return ASTTypes.NonRecursive+ , return ASTTypes.Recursive+ ]
+ lib/Language/OCaml/Parser/OpenStatement.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE NamedFieldPuns #-}++module Language.OCaml.Parser.OpenStatement+ ( openStatementP+ ) where++import Data.Default+import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ASTHelper.Opn as Opn+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common (mkRHS, symbolRLoc, symbolDocs)+-- import Language.OCaml.Parser.ExtAttributes+import Language.OCaml.Parser.ModLongident+import Language.OCaml.Parser.OverrideFlag+import Language.OCaml.Parser.PostItemAttributes+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++openStatementP :: Parser Structure -> Parser (OpenDescription, ())+openStatementP structureP = do+ try $ openT+ override <- overrideFlagP+ -- (ext, attrs) <- extAttributesP+ i <- modLongidentP+ a <- postItemAttributesP structureP+ return (+ Opn.mk+ (def { override+ , attrs = a -- FIXME: ++ attrs+ , loc = symbolRLoc ()+ , docs = symbolDocs ()+ }+ )+ (mkRHS i 4)+ , () -- FIXME: ext+ )
+ lib/Language/OCaml/Parser/Operator.hs view
@@ -0,0 +1,17 @@+module Language.OCaml.Parser.Operator+ ( operatorP+ ) where++import Text.Megaparsec++import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++operatorP :: Parser String+operatorP = choice+ [+ -- TODO+ bangT *> return "!"+ , plusT *> return "+"+ , minusT *> return "-"+ ]
+ lib/Language/OCaml/Parser/OptBar.hs view
@@ -0,0 +1,14 @@+module Language.OCaml.Parser.OptBar+ ( optBarP+ ) where++import Text.Megaparsec++import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++optBarP :: Parser ()+optBarP = choice+ [ barT *> return ()+ , return ()+ ]
+ lib/Language/OCaml/Parser/OptPatternTypeConstraint.hs view
@@ -0,0 +1,16 @@+module Language.OCaml.Parser.OptPatternTypeConstraint+ ( optPatternTypeConstraintP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.CoreType+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++optPatternTypeConstraintP :: Parser (Maybe CoreType)+optPatternTypeConstraintP = choice+ [ Just <$> (colonT *> coreTypeP)+ , return Nothing+ ]
+ lib/Language/OCaml/Parser/OptSemi.hs view
@@ -0,0 +1,14 @@+module Language.OCaml.Parser.OptSemi+ ( optSemiP+ ) where++import Text.Megaparsec++import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++optSemiP :: Parser ()+optSemiP = choice+ [ semiT+ , return ()+ ]
+ lib/Language/OCaml/Parser/OptTypeConstraint.hs view
@@ -0,0 +1,15 @@+module Language.OCaml.Parser.OptTypeConstraint+ ( optTypeConstraintP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.TypeConstraint+import Language.OCaml.Parser.Utils.Types++optTypeConstraintP :: Parser (Maybe (Maybe CoreType, Maybe CoreType))+optTypeConstraintP = choice+ [ Just <$> typeConstraintP+ , return Nothing+ ]
+ lib/Language/OCaml/Parser/OptionalTypeParameter.hs view
@@ -0,0 +1,15 @@+module Language.OCaml.Parser.OptionalTypeParameter+ ( optionalTypeParameterP+ ) where++import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.OptionalTypeVariable+import Language.OCaml.Parser.TypeVariance+import Language.OCaml.Parser.Utils.Types++optionalTypeParameterP :: Parser (CoreType, Variance)+optionalTypeParameterP = do+ v <- typeVarianceP+ t <- optionalTypeVariableP+ return (t, v)
+ lib/Language/OCaml/Parser/OptionalTypeParameters.hs view
@@ -0,0 +1,18 @@+module Language.OCaml.Parser.OptionalTypeParameters+ ( optionalTypeParametersP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.OptionalTypeParameter+import Language.OCaml.Parser.Utils.Types+import Language.OCaml.Parser.Utils.Utils++optionalTypeParametersP :: Parser [(CoreType, Variance)]+optionalTypeParametersP = choice+ [ (: []) <$> optionalTypeParameterP+ , parens (many optionalTypeParameterP)+ , pure []+ ]
+ lib/Language/OCaml/Parser/OptionalTypeVariable.hs view
@@ -0,0 +1,12 @@+module Language.OCaml.Parser.OptionalTypeVariable+ ( optionalTypeVariableP+ ) where+++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++optionalTypeVariableP :: Parser CoreType+optionalTypeVariableP = mktyp . PtypVar <$> (quoteT *> identP)
+ lib/Language/OCaml/Parser/OverrideFlag.hs view
@@ -0,0 +1,15 @@+module Language.OCaml.Parser.OverrideFlag+ ( overrideFlagP+ ) where++import Text.Megaparsec++import qualified Language.OCaml.Definitions.Parsing.ASTTypes as ASTTypes+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++overrideFlagP :: Parser ASTTypes.OverrideFlag+overrideFlagP = choice+ [ bangT *> return ASTTypes.Override+ , return ASTTypes.Fresh+ ]
+ lib/Language/OCaml/Parser/Pattern.hs view
@@ -0,0 +1,40 @@+module Language.OCaml.Parser.Pattern+ ( patternP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.PatternGen+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.ValIdent+import Language.OCaml.Parser.Utils.Combinators+import Language.OCaml.Parser.Utils.Types++patternP :: Parser Pattern+patternP = choice+ [ try $ parser <* notFollowedBy commaT+ , mkpat . PpatTuple <$>+ chainl1' parser (commaT *> (return $ flip (:))) (: [])+ ]+ where+ parser = leftRecursive+ [ patternGenP patternP+ ]+ -- pattern AS valIdent+ [ do+ try $ asT+ i <- valIdentP+ return $ \ x -> mkpat $ PpatAlias x (mkRHS i 3)+ -- pattern COLONCOLON pattern+ , do+ try $ colonColonT+ p2 <- patternP+ return $ \ p1 -> mkpatCons (rhsLoc 2) (ghpat $ PpatTuple [p1, p2]) (symbolRLoc ())+ , do+ try $ barT+ p <- patternP+ return $ \ x -> mkpat $ PpatOr x p+ -- TODO: bunch of other patterns+ ]
+ lib/Language/OCaml/Parser/PatternGen.hs view
@@ -0,0 +1,22 @@+module Language.OCaml.Parser.PatternGen+ ( patternGenP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.ConstrLongident+import Language.OCaml.Parser.SimplePattern+import Language.OCaml.Parser.Utils.Types++patternGenP :: Parser Pattern -> Parser Pattern+patternGenP patternP = choice+ [ try $ do+ i <- constrLongidentP+ p <- patternP+ return $ mkpat $ PpatConstruct (mkRHS i 1) (Just p)+ , try $ simplePatternP'+ ]+ where+ simplePatternP' = simplePatternP patternP
+ lib/Language/OCaml/Parser/PatternNoExn.hs view
@@ -0,0 +1,34 @@+module Language.OCaml.Parser.PatternNoExn+ ( patternNoExnP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.Pattern+import Language.OCaml.Parser.PatternGen+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.ValIdent+import Language.OCaml.Parser.Utils.Combinators+import Language.OCaml.Parser.Utils.Types++patternNoExnP :: Parser Pattern+patternNoExnP = leftRecursive+ [ patternGenP patternP+ ]+ [ do+ try asT+ i <- valIdentP+ return $ \ x -> mkpat $ PpatAlias x (mkRHS i 3)+ -- TODO: patternNoExnCommaList+ -- , do+ -- try colonColonT+ -- p <- patternP+ -- return $ mkpatCons _ _+ , do+ try barT+ p <- patternP+ return $ \ x -> mkpat $ PpatOr x p+ -- TODO: attribute+ ]
+ lib/Language/OCaml/Parser/PatternSemiList.hs view
@@ -0,0 +1,18 @@+module Language.OCaml.Parser.PatternSemiList+ ( patternSemiListP+ ) where++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Combinators+import Language.OCaml.Parser.Utils.Types++patternSemiListP :: Parser Pattern -> Parser [Pattern]+patternSemiListP patternP = leftRecursive+ [ (: []) <$> patternP+ ]+ [ do+ semiT+ e2 <- patternP+ return $ \ e1 -> e2 : e1+ ]
+ lib/Language/OCaml/Parser/Payload.hs view
@@ -0,0 +1,13 @@+module Language.OCaml.Parser.Payload+ ( payloadP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Utils.Types++payloadP :: Parser Structure -> Parser Payload+payloadP structureP = choice+ [ PStr <$> structureP+ ]
+ lib/Language/OCaml/Parser/PolyTypeNoAttr.hs view
@@ -0,0 +1,16 @@+module Language.OCaml.Parser.PolyTypeNoAttr+ ( polyTypeNoAttrP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.CoreType+import Language.OCaml.Parser.CoreTypeNoAttr+import Language.OCaml.Parser.Utils.Types++polyTypeNoAttrP :: Parser CoreType+polyTypeNoAttrP = choice+ [ coreTypenoAttrP coreTypeP+ -- TODO+ ]
+ lib/Language/OCaml/Parser/PostItemAttribute.hs view
@@ -0,0 +1,20 @@+module Language.OCaml.Parser.PostItemAttribute+ ( postItemAttributeP+ ) where++import Text.Megaparsec++import qualified Language.OCaml.Definitions.Parsing.ASTTypes as ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.AttrId+import Language.OCaml.Parser.Payload+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++postItemAttributeP :: Parser Structure -> Parser (ASTTypes.Loc String, Payload)+postItemAttributeP structureP = do+ try $ lBracketAtAtT+ i <- attrIdP+ p <- payloadP structureP+ rBracketT+ return (i, p)
+ lib/Language/OCaml/Parser/PostItemAttributes.hs view
@@ -0,0 +1,13 @@+module Language.OCaml.Parser.PostItemAttributes+ ( postItemAttributesP+ ) where++import Text.Megaparsec++import qualified Language.OCaml.Definitions.Parsing.ASTTypes as ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.PostItemAttribute+import Language.OCaml.Parser.Utils.Types++postItemAttributesP :: Parser Structure -> Parser [(ASTTypes.Loc String, Payload)]+postItemAttributesP structureP = many (postItemAttributeP structureP)
+ lib/Language/OCaml/Parser/PrivateFlag.hs view
@@ -0,0 +1,15 @@+module Language.OCaml.Parser.PrivateFlag+ ( privateFlagP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++privateFlagP :: Parser PrivateFlag+privateFlagP = choice+ [ privateT *> return Private+ , return Public+ ]
+ lib/Language/OCaml/Parser/RecFlag.hs view
@@ -0,0 +1,15 @@+module Language.OCaml.Parser.RecFlag+ ( recFlagP+ ) where++import Text.Megaparsec++import qualified Language.OCaml.Definitions.Parsing.ASTTypes as ASTTypes+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++recFlagP :: Parser ASTTypes.RecFlag+recFlagP = choice+ [ recT *> return ASTTypes.Recursive+ , return ASTTypes.NonRecursive+ ]
+ lib/Language/OCaml/Parser/RecordExpr.hs view
@@ -0,0 +1,28 @@+module Language.OCaml.Parser.RecordExpr+ ( recordExprP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.LblExprList+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++recordExprP ::+ Parser Expression -> Parser Expression -> Parser (Maybe Expression, [(Loc Longident, Expression)])+recordExprP exprP simpleExprP = choice+ [ do+ e <- try $ do+ e <- simpleExprP+ withT+ return e+ l <- lblExprListP'+ return (Just e, l)+ , do+ l <- lblExprListP'+ return (Nothing, l)+ ]+ where+ lblExprListP' = lblExprListP exprP
+ lib/Language/OCaml/Parser/SeqExpr.hs view
@@ -0,0 +1,30 @@+module Language.OCaml.Parser.SeqExpr+ ( seqExprP+ ) where++import Data.Default+import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ASTHelper.Exp as Exp hiding (try)+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Expr+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++seqExprP :: Parser Structure -> Parser Expression+seqExprP structureP = choice+ [ try $ do+ e <- exprP'+ semiT+ s <- seqExprP'+ return $ Exp.mk def (PexpSequence e s)+ , try $ do+ e <- exprP'+ semiT+ return e+ , try $ exprP'+ -- TODO: percent+ ]+ where+ exprP' = exprP structureP seqExprP'+ seqExprP' = seqExprP structureP
+ lib/Language/OCaml/Parser/SigExceptionDeclaration.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}++module Language.OCaml.Parser.SigExceptionDeclaration+ ( sigExceptionDeclarationP+ ) where++import Data.Default++import Language.OCaml.Definitions.Parsing.ASTHelper.Te as Te+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.ConstrIdent+import Language.OCaml.Parser.CoreType+import Language.OCaml.Parser.GeneralizedConstructorArguments+import Language.OCaml.Parser.PostItemAttributes+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++sigExceptionDeclarationP :: Parser Structure -> Parser (ExtensionConstructor, ())+sigExceptionDeclarationP structureP = do+ exceptionT+ -- TODO: extAttributes+ i <- constrIdentP+ (args, res) <- generalizedConstructorArgumentsP coreTypeP+ -- a <- attributesP+ attrs <- postItemAttributesP structureP+ return+ ( Te.decl+ (def { args+ , attrs = attrs {- ++ a -} {- loc and docs -}+ , loc = symbolRLoc ()+ , docs = symbolDocs ()+ }+ )+ res+ (mkRHS i (3 :: Int))+ , ()+ )
+ lib/Language/OCaml/Parser/SimpleCoreType.hs view
@@ -0,0 +1,21 @@+module Language.OCaml.Parser.SimpleCoreType+ ( simpleCoreTypeP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.CoreTypeCommaList+import Language.OCaml.Parser.SimpleCoreType2+import Language.OCaml.Parser.Utils.Types+import Language.OCaml.Parser.Utils.Utils++simpleCoreTypeP :: Parser CoreType -> Parser CoreType+simpleCoreTypeP coreTypeP = choice+ [ try $ simpleCoreType2P coreTypeP+ , do+ l <- parens $ coreTypeCommaListP coreTypeP+ case l of+ [sty] -> return sty+ _ -> fail "Parse error"+ ]
+ lib/Language/OCaml/Parser/SimpleCoreType2.hs view
@@ -0,0 +1,38 @@+module Language.OCaml.Parser.SimpleCoreType2+ ( simpleCoreType2P+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.CoreTypeCommaList+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.TypeLongident+import Language.OCaml.Parser.Utils.Combinators+import Language.OCaml.Parser.Utils.Types++simpleCoreType2P :: Parser CoreType -> Parser CoreType+simpleCoreType2P coreTypeP = leftRecursive+ [ choice+ [ mktyp . PtypVar <$> try (quoteT *> identP)+ , mktyp . const PtypAny <$> underscoreT+ , try $ do+ t <- typeLongidentP+ return $ mktyp $ PtypConstr (mkRHS t 1) []+ , do+ lParenT+ l <- coreTypeCommaListP coreTypeP+ rParenT+ i <- typeLongidentP+ return . mktyp $ PtypConstr (mkRHS i 4)(reverse l)+ -- , do+ -- a <- chainl1' simpleCoreType2P _ _ -- (return $ \ a b -> PtypConstr (mkRHS b 2) [a])+ -- t <- typeLongidentP+ -- return $ mkTyp $ PtypConstr (mkRHS t 2) [a]+ ]+ ]+ [ do+ t <- typeLongidentP+ return $ \ x -> mktyp $ PtypConstr (mkRHS t 2) [x]+ ]
+ lib/Language/OCaml/Parser/SimpleCoreTypeOrTuple.hs view
@@ -0,0 +1,26 @@+module Language.OCaml.Parser.SimpleCoreTypeOrTuple+ ( simpleCoreTypeOrTupleP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.CoreTypeList+import Language.OCaml.Parser.SimpleCoreType+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++simpleCoreTypeOrTupleP :: Parser CoreType -> Parser CoreType+simpleCoreTypeOrTupleP coreTypeP = choice+ [ do+ t <- try $ do+ t <- simpleCoreTypeP'+ starT+ return t+ l <- coreTypelistP coreTypeP+ return . mktyp . PtypTuple $ t : reverse l+ , simpleCoreTypeP'+ ]+ where+ simpleCoreTypeP' = simpleCoreTypeP coreTypeP
+ lib/Language/OCaml/Parser/SimpleDelimitedPattern.hs view
@@ -0,0 +1,45 @@+module Language.OCaml.Parser.SimpleDelimitedPattern+ ( simpleDelimitedPatternP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.LblPatternList+import Language.OCaml.Parser.OptSemi+import Language.OCaml.Parser.PatternSemiList+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++simpleDelimitedPatternP :: Parser Pattern -> Parser Pattern+simpleDelimitedPatternP patternP = choice+ [ do+ (fields, closed) <- try $ do+ lBraceT+ lblPatternListP patternP+ rBraceT+ return $ mkpat $ PpatRecord fields closed+ , do+ l <- try $ do+ lBracketT+ l <- patternSemiListP patternP+ optSemiP+ return l+ rBracketT+ return $ mktailpat (rhsLoc 4) (reverse l)+ , do+ l <- try $ do+ lBracketBarT+ l <- patternSemiListP'+ optSemiP+ return l+ barRBracketT+ return $ mkpat $ PpatArray (reverse l)+ , do+ lBracketBarT+ barRBracketT+ return $ mkpat $ PpatArray []+ ]+ where+ patternSemiListP' = patternSemiListP patternP
+ lib/Language/OCaml/Parser/SimpleExpr.hs view
@@ -0,0 +1,50 @@+module Language.OCaml.Parser.SimpleExpr+ ( simpleExprP+ ) where++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.Constant+import Language.OCaml.Parser.ConstrLongident+import Language.OCaml.Parser.ExprSemiList+import Language.OCaml.Parser.LabelLongident+import Language.OCaml.Parser.OptSemi+import Language.OCaml.Parser.RecordExpr+import Language.OCaml.Parser.ValLongident+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Combinators+import Language.OCaml.Parser.Utils.Types++simpleExprP :: Parser Expression -> Parser Expression -> Parser Expression+simpleExprP seqExprP exprP = leftRecursive+ [ do+ i <- valLongidentP+ return . mkexp $ PexpIdent (mkRHS i 1)+ , mkexp . PexpConstant <$> constantP+ , do+ i <- constrLongidentP+ return $ mkexp $ PexpConstruct (mkRHS i 1) Nothing+ , do+ lParenT+ e <- seqExprP+ rParenT+ return $ relocExp e+ , do+ lBracketT+ l <- exprSemiListP exprP+ optSemiP+ rBracketT+ return $ relocExp $ mktailexp (rhsLoc 4) (reverse l)+ , do+ lBraceT+ (exten, fields) <- recordExprP exprP simpleExprP'+ rBraceT+ return $ mkexp $ PexpRecord fields exten+ ]+ [ do+ dotT+ i <- labelLongidentP+ return $ \ x -> mkexp $ PexpField x (mkRHS i 3)+ ]+ where+ simpleExprP' = simpleExprP seqExprP exprP
+ lib/Language/OCaml/Parser/SimpleLabeledExprList.hs view
@@ -0,0 +1,16 @@+module Language.OCaml.Parser.SimpleLabeledExprList+ ( simpleLabeledExprListP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.LabeledSimpleExpr+import Language.OCaml.Parser.Utils.Types++-- NOTE: the OCaml version builds the list backwards for efficiency reasons+-- We call `reverse` to match it, even though it is inefficient.+-- We could update this once the whole code base is ready. #FIXME+simpleLabeledExprListP :: Parser Expression -> Parser Expression -> Parser [(ArgLabel, Expression)]+simpleLabeledExprListP seqExprP exprP = reverse <$> many (labeledSimpleExprP seqExprP exprP)
+ lib/Language/OCaml/Parser/SimplePattern.hs view
@@ -0,0 +1,21 @@+module Language.OCaml.Parser.SimplePattern+ ( simplePatternP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.SimplePatternNotIdent+import Language.OCaml.Parser.ValIdent+import Language.OCaml.Parser.Utils.Types++simplePatternP :: Parser Pattern -> Parser Pattern+simplePatternP patternP = choice+ [ do+ i <- valIdentP+ return $ mkpat $ PpatVar $ mkRHS i 1+ , simplePatternNotIdentP'+ ]+ where+ simplePatternNotIdentP' = simplePatternNotIdentP patternP
+ lib/Language/OCaml/Parser/SimplePatternNotIdent.hs view
@@ -0,0 +1,33 @@+module Language.OCaml.Parser.SimplePatternNotIdent+ ( simplePatternNotIdentP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.ConstrLongident+import Language.OCaml.Parser.SimpleDelimitedPattern+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++simplePatternNotIdentP :: Parser Pattern -> Parser Pattern+simplePatternNotIdentP patternP = choice+ [ do+ underscoreT+ return $ mkpat $ PpatAny+ -- TODO: signed constants+ , do+ i <- constrLongidentP+ return $ mkpat $ PpatConstruct (mkRHS i 1) Nothing+ -- TODO: name_tag+ -- TODO: HASH+ , simpleDelimitedPatternP'+ , do+ lParenT+ p <- patternP+ rParenT+ return $ relocPat p+ ]+ where+ simpleDelimitedPatternP' = simpleDelimitedPatternP patternP
+ lib/Language/OCaml/Parser/SingleAttrId.hs view
@@ -0,0 +1,15 @@+module Language.OCaml.Parser.SingleAttrId+ ( singleAttrIdP+ ) where++import Text.Megaparsec++import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++singleAttrIdP :: Parser String+singleAttrIdP = choice+ [ lIdentT+ , uIdentT+ -- TODO+ ]
+ lib/Language/OCaml/Parser/StrExceptionDeclaration.hs view
@@ -0,0 +1,15 @@+module Language.OCaml.Parser.StrExceptionDeclaration+ ( strExceptionDeclarationP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.SigExceptionDeclaration+import Language.OCaml.Parser.Utils.Types++strExceptionDeclarationP :: Parser Structure -> Parser (ExtensionConstructor, ())+strExceptionDeclarationP structureP = choice+ [ sigExceptionDeclarationP structureP+ -- TODO+ ]
+ lib/Language/OCaml/Parser/StrictBinding.hs view
@@ -0,0 +1,24 @@+module Language.OCaml.Parser.StrictBinding+ ( strictBindingP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.LabeledSimplePattern+import Language.OCaml.Parser.Pattern+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++strictBindingP :: Parser Expression -> Parser Expression -> Parser Expression+strictBindingP seqExprP funBindingP = choice+ [ do+ try $ equalT+ seqExprP+ , do+ (l, o, p) <- labeledSimplePatternP patternP+ b <- funBindingP+ return $ ghexp $ PexpFun l o p b+ -- TODO+ ]
+ lib/Language/OCaml/Parser/Structure.hs view
@@ -0,0 +1,39 @@+module Language.OCaml.Parser.Structure+ ( structureP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.PostItemAttributes+import Language.OCaml.Parser.SeqExpr+import Language.OCaml.Parser.StructureItem+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Utils+import Language.OCaml.Parser.Utils.Types++structureP :: Parser Structure+structureP = ocamlSpace *> choice+ [ do+ e <- seqExprP structureP+ a <- postItemAttributesP structureP+ s <- structureTailP+ return $ textStr 1 ++ mkstrexp e a : s+ , structureTailP+ ]+ where+ structureTailP :: Parser [StructureItem]+ structureTailP = choice+ [ do+ (i, t) <- try $ do+ i <- structureItemP structureP+ t <- structureTailP+ return (i, t)+ return $ textStr 1 ++ i : t+ , do+ try $ semiSemiT+ s <- structureP+ return $ textStr 1 ++ s+ , ocamlSpace *> return []+ ]
+ lib/Language/OCaml/Parser/StructureItem.hs view
@@ -0,0 +1,32 @@+module Language.OCaml.Parser.StructureItem+ ( structureItemP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.LetBindings+import Language.OCaml.Parser.ModuleBinding+import Language.OCaml.Parser.OpenStatement+import Language.OCaml.Parser.SeqExpr+import Language.OCaml.Parser.StrExceptionDeclaration+import Language.OCaml.Parser.TypeDeclarations+import Language.OCaml.Parser.Utils.Types++structureItemP :: Parser Structure -> Parser StructureItem+structureItemP structureP = choice+ [ valOfLetBindings <$> letBindingsP structureP (seqExprP structureP)+ , do+ (nr, l) <- typeDeclarationsP structureP+ return $ mkstrExt (PstrType nr (reverse l)) Nothing -- FIXME: not Nothing+ , do+ (l, _ext) <- strExceptionDeclarationP structureP+ return $ mkstrExt (PstrException l) Nothing -- FIXME+ , do+ (body, _ext) <- openStatementP structureP+ return $ mkstrExt (PstrOpen body) Nothing -- FIXME+ , do+ (body, _ext) <- moduleBindingP structureP+ return $ mkstrExt (PstrModule body) Nothing -- FIXME+ ]
+ lib/Language/OCaml/Parser/Tokens.hs view
@@ -0,0 +1,322 @@+module Language.OCaml.Parser.Tokens+ ( andT+ , asT+ , atT+ , bangT+ , barT+ , barRBracketT+ , caretT+ , charT+ , colonT+ , colonColonT+ , colonGreaterT+ , commaT+ , dotT+ , elseT+ , equalT+ , exceptionT+ , falseT+ , funT+ , functionT+ , greaterT+ , ifT+ , inT+ , intT+ , lBraceT+ , lBracketT+ , lBracketAtT+ , lBracketAtAtT+ , lBracketBarT+ , lIdentT+ , lParenT+ , letT+ , matchT+ , minusT+ , minusGreaterT+ , moduleT+ , mutableT+ , nonrecT+ , ofT+ , openT+ , plusT+ , privateT+ , quoteT+ , rBraceT+ , rBracketT+ , rParenT+ , recT+ , semiT+ , semiSemiT+ , starT+ , stringT+ , thenT+ , trueT+ , typeT+ , uIdentT+ , underscoreT+ , whenT+ , withT+ ) where++import Data.Char+import Text.Megaparsec+import Text.Megaparsec.Char++import Language.OCaml.Parser.Utils.Utils+import Language.OCaml.Parser.Utils.Types++andT :: Parser ()+andT = rword "and"++asT :: Parser ()+asT = rword "as"++atT :: Parser ()+atT = symbol "@"++bangT :: Parser ()+bangT = symbol "!"++barT :: Parser ()+barT = symbol "|"++barRBracketT :: Parser ()+barRBracketT = symbol "|]"++binDigitChar :: Parser Char+binDigitChar = char '0' <|> char '1'++binLiteralP :: Parser String+binLiteralP = do -- WARNING: do not add `lexeme` here+ _ <- char '0'+ _ <- char 'b' <|> char 'B'+ h <- binDigitChar+ t <- many (binDigitChar <|> char '_')+ return $ h : t++caretT :: Parser ()+caretT = symbol "^"++charT :: Parser Char+charT = do+ symbol "'"+ c <- satisfy (not . (`elem` ['\\', '\'', '\010', '\013']))+ symbol "'"+ return c++colonT :: Parser ()+colonT = symbol ":"++colonColonT :: Parser ()+colonColonT = symbol "::"++colonGreaterT :: Parser ()+colonGreaterT = symbol ":>"++commaT :: Parser ()+commaT = symbol ","++decimalLiteralP :: Parser String+decimalLiteralP = do -- WARNING: do not add `lexeme` here+ h <- digitChar+ t <- many (digitChar <|> char '_')+ return $ h : t++dotT :: Parser ()+dotT = symbol "."++elseT :: Parser ()+elseT = rword "else"++equalT :: Parser ()+equalT = symbol "="++falseT :: Parser ()+falseT = rword "false"++funT :: Parser ()+funT = rword "fun"++functionT :: Parser ()+functionT = rword "function"++ifT :: Parser ()+ifT = rword "if"++exceptionT :: Parser ()+exceptionT = rword "exception"++greaterT :: Parser ()+greaterT = symbol ">"++hexLiteralP :: Parser String+hexLiteralP = do -- WARNING: do not add `lexeme` here+ _ <- char '0'+ _ <- char 'x' <|> char 'X'+ h <- hexDigitChar+ t <- many (hexDigitChar <|> char '_')+ return $ h : t++intLiteralP :: Parser String+intLiteralP = choice+ [ decimalLiteralP+ , hexLiteralP+ , octLiteralP+ , binLiteralP+ ]++inT :: Parser ()+inT = rword "in"++intT :: Parser (String, Maybe Char)+intT = lexeme $ do+ l <- intLiteralP+ m <- choice+ [ Just <$> literalModifierP+ , return Nothing+ ]+ return (l, m)++isBetween :: Char -> Char -> Char -> Bool+isBetween cmin c cmax = (vmin <= v && v <= vmax)+ where+ vmin = conv cmin+ v = conv c+ vmax = conv cmax+ conv = ord++isModifier :: Char -> Bool+isModifier c = isBetween 'G' c 'Z' || isBetween 'g' c 'z'++literalModifierP :: Parser Char+literalModifierP = satisfy isModifier++identCharT :: Parser Char+identCharT = choice+ [ upperChar+ , lowerChar+ , char '_'+ , char '\''+ , digitChar+ ]++lBraceT :: Parser ()+lBraceT = symbol "{"++lBracketT :: Parser ()+lBracketT = symbol "["++lBracketAtT :: Parser ()+lBracketAtT = symbol "[@"++lBracketAtAtT :: Parser ()+lBracketAtAtT = symbol "[@@"++lBracketBarT :: Parser ()+lBracketBarT = symbol "[|"++lIdentT :: Parser String+lIdentT = identifier $ do+ c <- lowerChar+ cs <- many identCharT+ return $ c : cs++lParenT :: Parser ()+lParenT = symbol "("++letT :: Parser ()+letT = rword "let"++matchT :: Parser ()+matchT = rword "match"++minusT :: Parser ()+minusT = symbol "-"++minusGreaterT :: Parser ()+minusGreaterT = symbol "->"++moduleT :: Parser ()+moduleT = rword "module"++mutableT :: Parser ()+mutableT = rword "mutable"++nonrecT :: Parser ()+nonrecT = rword "nonrec"++octLiteralP :: Parser String+octLiteralP = do -- WARNING: do not add `lexeme` here+ _ <- char '0'+ _ <- char 'o' <|> char 'O'+ h <- octDigitChar+ t <- many (octDigitChar <|> char '_')+ return $ h : t++ofT :: Parser ()+ofT = rword "of"++openT :: Parser ()+openT = rword "open"++plusT :: Parser ()+plusT = symbol "+"++privateT :: Parser ()+privateT = rword "private"++quoteT :: Parser ()+quoteT = symbol "'"++rBraceT :: Parser ()+rBraceT = symbol "}"++rBracketT :: Parser ()+rBracketT = symbol "]"++rParenT :: Parser ()+rParenT = symbol ")"++recT :: Parser ()+recT = rword "rec"++semiT :: Parser ()+semiT = symbol ";"++semiSemiT :: Parser ()+semiSemiT = symbol ";;"++starT :: Parser ()+starT = symbol "*"++-- FIXME: real strings have nesting comments and escape characters+stringT :: Parser (String, Maybe String)+stringT = lexeme $ do+ _ <- char '"'+ s <- many $ satisfy ((/=) '"')+ _ <- char '"'+ return (s, Nothing)++thenT :: Parser ()+thenT = rword "then"++trueT :: Parser ()+trueT = rword "true"++typeT :: Parser ()+typeT = rword "type"++uIdentT :: Parser String+uIdentT = identifier $ do+ c <- upperChar+ cs <- many identCharT+ return $ c : cs++underscoreT :: Parser ()+underscoreT = symbol "_"++whenT :: Parser ()+whenT = rword "when"++withT :: Parser ()+withT = rword "with"
+ lib/Language/OCaml/Parser/TypeConstraint.hs view
@@ -0,0 +1,30 @@+module Language.OCaml.Parser.TypeConstraint+ ( typeConstraintP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.CoreType+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++typeConstraintP :: Parser (Maybe CoreType, Maybe CoreType)+typeConstraintP = choice+ [ do+ t1 <- try $ do+ colonT+ t1 <- coreTypeP+ colonGreaterT+ return t1+ t2 <- coreTypeP+ return (Just t1, Just t2)+ , try $ do+ colonT+ t <- coreTypeP+ return (Just t, Nothing)+ , do+ try $ colonGreaterT+ t <- coreTypeP+ return (Nothing, Just t)+ ]
+ lib/Language/OCaml/Parser/TypeDeclaration.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}++module Language.OCaml.Parser.TypeDeclaration+ ( typeDeclarationP+ ) where++import Data.Default+import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ASTHelper.Type as Type+import qualified Language.OCaml.Definitions.Parsing.ASTTypes as ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.NonRecFlag+import Language.OCaml.Parser.OptionalTypeParameters+import Language.OCaml.Parser.PostItemAttributes+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.TypeKind+import Language.OCaml.Parser.Utils.Types++typeDeclarationP :: Parser Structure -> Parser (ASTTypes.RecFlag, TypeDeclaration)+typeDeclarationP structureP = do+ try $ typeT+ -- TODO: extAttributes+ nonrecFlag <- nonrecFlagP+ params <- optionalTypeParametersP+ n <- lIdentT+ (kind, priv, manifest) <- typeKindP structureP+ -- TODO: constraints+ attrs <- postItemAttributesP structureP+ let ty = Type.mk (def { attrs, kind, params, priv }) manifest (mkRHS n 5)+ return (nonrecFlag, ty)
+ lib/Language/OCaml/Parser/TypeDeclarations.hs view
@@ -0,0 +1,25 @@+module Language.OCaml.Parser.TypeDeclarations+ ( typeDeclarationsP+ ) where++import qualified Language.OCaml.Definitions.Parsing.ASTTypes as ASTTypes+import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.AndTypeDeclaration+import Language.OCaml.Parser.TypeDeclaration+import Language.OCaml.Parser.Utils.Combinators+import Language.OCaml.Parser.Utils.Types++typeDeclarationsP ::+ Parser Structure -> Parser (ASTTypes.RecFlag, [TypeDeclaration])+typeDeclarationsP structureP = leftRecursive+ [ do+ (nonrecFlag, ty) <- typeDeclarationP'+ return $ (nonrecFlag, [ty])+ ]+ [ do+ ty <- andTypeDeclarationP'+ return $ \ (nonrecFlag, tys) -> (nonrecFlag, ty : tys)+ ]+ where+ typeDeclarationP' = typeDeclarationP structureP+ andTypeDeclarationP' = andTypeDeclarationP structureP
+ lib/Language/OCaml/Parser/TypeKind.hs view
@@ -0,0 +1,40 @@+module Language.OCaml.Parser.TypeKind+ ( typeKindP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.ConstructorDeclarations+import Language.OCaml.Parser.CoreType+import Language.OCaml.Parser.LabelDeclarations+import Language.OCaml.Parser.PrivateFlag+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++typeKindP :: Parser Structure -> Parser (TypeKind, PrivateFlag, Maybe CoreType)+typeKindP structureP = choice+ [ do+ t <- try $ do+ equalT+ coreTypeP+ return (PtypeAbstract, Public, Just t)+ , do+ cs <- try $ do+ equalT+ constructorDeclarationsP'+ return (PtypeVariant (reverse cs), Private, Nothing)+ , do+ priv <- try $ do+ equalT+ priv <- privateFlagP+ lBraceT+ return priv+ labels <- labelDeclarationsP+ rBraceT+ return (PtypeRecord labels, priv, Nothing)+ -- FIXME: commenting this out as it helps with debugging, but this is a valid parse of type kind+ -- , return (PtypeAbstract, Public, Nothing)+ ]+ where+ constructorDeclarationsP' = constructorDeclarationsP structureP coreTypeP
+ lib/Language/OCaml/Parser/TypeLongident.hs view
@@ -0,0 +1,20 @@+module Language.OCaml.Parser.TypeLongident+ ( typeLongidentP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.ModExtLongident+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++typeLongidentP :: Parser Longident+typeLongidentP = choice+ [ Lident <$> lIdentT+ , do+ p <- modExtLongidentP+ dotT+ i <- lIdentT+ return $ Ldot p i+ ]
+ lib/Language/OCaml/Parser/TypeVariable.hs view
@@ -0,0 +1,12 @@+module Language.OCaml.Parser.TypeVariable+ ( typeVariableP+ ) where+++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.Common+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++typeVariableP :: Parser CoreType+typeVariableP = mktyp . PtypVar <$> (quoteT *> identP)
+ lib/Language/OCaml/Parser/TypeVariance.hs view
@@ -0,0 +1,16 @@+module Language.OCaml.Parser.TypeVariance+ ( typeVarianceP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++typeVarianceP :: Parser Variance+typeVarianceP = choice+ [ plusT *> pure Covariant+ , minusT *> pure Contravariant+ , pure Invariant+ ]
+ lib/Language/OCaml/Parser/Utils/Combinators.hs view
@@ -0,0 +1,77 @@+module Language.OCaml.Parser.Utils.Combinators+ ( chainl1+ , chainl1'+ , chainl1try+ , chainl1try'+ , leftRecursive+ ) where++import Control.Applicative+import Text.Megaparsec++import Language.OCaml.Parser.Utils.Types++{-++This combinator is necessary because we want to parse succesfully even when+the `op` is not part of the chain.++For instance, in OCaml, a modLongident is a sequence of `Foo.Bar.Baz` and must+be parsed as a chain. However, when presented with `Foo.Bar.baz`, we'd like the+chain to capture `Foo.Bar` and ignore the `.baz`.++-}+chainl1try' :: Parser a -> Parser (b -> a -> b) -> (a -> b) -> Parser b+chainl1try' p op bc = p >>= rest . bc+ where+ rest x = tryOp x <|> return x+ tryOp x = try $ do+ f <- op+ y <- p+ rest (f x y)++chainl1try :: Parser b -> Parser (b -> b -> b) -> Parser b+chainl1try p op = chainl1try' p op id++chainl1' :: (Alternative m, Monad m) => m a -> m (b -> a -> b) -> (a -> b) -> m b+chainl1' p op bc = p >>= rest . bc+ where+ rest x = do { f <- op ; y <- p ; rest (f x y) } <|> return x++chainl1 :: (Alternative m, Monad m) => m a -> m (a -> a -> a) -> m a+chainl1 p op = chainl1' p op id++{-++This applies the procedure of turning a left-recursive grammar into a+non-left-recursive one. Essentially, when wanting to write the grammar:++A ::=+| A B { foo A B }+| C { bar C }++One instead writes the following:++A' ::=+| C R { R (bar C) }++R ::=+| B R { \ A -> R (foo A B) }+| {-empty-} { id }++The two arguments to `leftRecursive` are the grammars for A' and R (except the+last line of R is not needed, but added by the combinator).++-}+leftRecursive :: (Monad m, Alternative m) => [m a] -> [m (a -> a)] -> m a+leftRecursive prefixes suffixes = choice $ map patchPrefix prefixes+ where+ patchPrefix prefixP = do+ p <- prefixP+ r <- rest+ return $ r p+ patchSuffix suffixP = do+ s <- suffixP+ r <- rest+ return $ r . s+ rest = choice $ map patchSuffix suffixes ++ [ return id ]
+ lib/Language/OCaml/Parser/Utils/Types.hs view
@@ -0,0 +1,8 @@+module Language.OCaml.Parser.Utils.Types+ ( Parser+ ) where++import Data.Void+import Text.Megaparsec++type Parser = Parsec Void String
+ lib/Language/OCaml/Parser/Utils/Utils.hs view
@@ -0,0 +1,115 @@+module Language.OCaml.Parser.Utils.Utils+ -- , checkIdentifier+ ( identifier+ , lexeme+ , ocamlSpace+ , parens+ , rword+ , symbol+ ) where++import Data.Functor+import Text.Megaparsec+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L+import Text.Printf++import Language.OCaml.Parser.Utils.Types++checkIdentifier :: String -> Parser String+checkIdentifier c =+ if c `elem` reservedWords+ then fail $ printf "keyword %s cannot be an identifier" (show c)+ else return c++identifier :: Parser String -> Parser String+identifier p = (lexeme . try) (p >>= checkIdentifier)++-- identifier :: Parser String+-- identifier = (lexeme . try) (p >>= checkIdentifier)+-- where+-- p = (:) <$> letterChar <*> many (alphaNumChar <|> char '_')++ocamlSpace :: Parser ()+ocamlSpace = L.space (void spaceChar) lineCmnt blockCmnt+ where+ lineCmnt = L.skipLineComment "//"+ blockCmnt = L.skipBlockComment "(*" "*)"++lexeme :: Parser a -> Parser a+lexeme = L.lexeme ocamlSpace++parens :: Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++rword :: String -> Parser ()+rword w =+ if w `elem` reservedWords+ then string w *> notFollowedBy alphaNumChar *> ocamlSpace+ else error+ $ "The following word must be added to reservedWords in Language.OCaml.Parser.Utils.Utils: "+ ++ w++symbol :: String -> Parser ()+symbol = void . L.symbol ocamlSpace++reservedWords :: [String] -- list of reserved words+reservedWords =+ [ "and"+ , "as"+ , "assert"+ , "begin"+ , "class"+ , "constraint"+ , "do"+ , "done"+ , "downto"+ , "else"+ , "end"+ , "exception"+ , "external"+ , "false"+ , "for"+ , "fun"+ , "function"+ , "functor"+ , "if"+ , "in"+ , "include"+ , "inherit"+ , "initializer"+ , "lazy"+ , "let"+ , "match"+ , "method"+ , "module"+ , "mutable"+ , "new"+ , "nonrec"+ , "object"+ , "of"+ , "open"+ , "or"+ -- , "parser"+ , "private"+ , "rec"+ , "sig"+ , "struct"+ , "then"+ , "to"+ , "true"+ , "try"+ , "type"+ , "val"+ , "virtual"+ , "when"+ , "while"+ , "with"+ , "lor"+ , "lxor"+ , "mod"+ , "land"+ , "lsl"+ , "lsr"+ , "asr"+ ]
+ lib/Language/OCaml/Parser/ValIdent.hs view
@@ -0,0 +1,20 @@+module Language.OCaml.Parser.ValIdent+ ( valIdentP+ ) where++import Text.Megaparsec++import Language.OCaml.Parser.Operator+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types++valIdentP :: Parser String+valIdentP = choice+ [ lIdentT+ , do+ o <- try $ do+ lParenT+ operatorP+ rParenT+ return o+ ]
+ lib/Language/OCaml/Parser/ValLongident.hs view
@@ -0,0 +1,23 @@+module Language.OCaml.Parser.ValLongident+ ( valLongidentP+ ) where++import Text.Megaparsec++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.Parser.ModLongident+import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.Utils.Types+import Language.OCaml.Parser.ValIdent++valLongidentP :: Parser Longident+valLongidentP = choice+ [ Lident <$> valIdentP+ , do+ l <- try $ do+ l <- modLongidentP+ dotT+ return l+ i <- valIdentP+ return $ Ldot l i+ ]
+ lib/Language/OCaml/PrettyPrinter.hs view
@@ -0,0 +1,10 @@+module Language.OCaml.PrettyPrinter+ ( pretty+ , structurePP+ ) where++import Data.Text.Prettyprint.Doc (pretty)++import Language.OCaml.PrettyPrinter.Payload ()+import Language.OCaml.PrettyPrinter.Structure+import Language.OCaml.PrettyPrinter.StructureItem ()
+ lib/Language/OCaml/PrettyPrinter/ArgLabel.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.PrettyPrinter.ArgLabel+ ( argLabelPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.PrettyPrinter.Case ()+import Language.OCaml.PrettyPrinter.Loc ()+import Language.OCaml.PrettyPrinter.Longident ()++argLabelPP :: ArgLabel -> Doc a+argLabelPP = \case+ Nolabel -> ""+ _ -> error "TODO"++instance Pretty ArgLabel where+ pretty = argLabelPP
+ lib/Language/OCaml/PrettyPrinter/Case.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.OCaml.PrettyPrinter.Case+ ( casePP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.Pattern ()++casePP :: (Pretty Expression) => Case -> Doc a+casePP d = fillCat [ pipe, space, lhs, guard, space, "->", space, rhs ]+ where+ lhs = pretty $ pcLHS d+ rhs = pretty $ pcRHS d+ guard = case pcGuard d of+ Nothing -> ""+ Just g -> space <> fillSep [ "when", pretty g ]++instance Pretty Expression => Pretty Case where+ pretty = casePP
+ lib/Language/OCaml/PrettyPrinter/Constant.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.PrettyPrinter.Constant+ ( constantPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree++constantPP :: Constant -> Doc a+constantPP = \case+ PconstInteger s Nothing -> pretty s+ PconstInteger s (Just c) -> "0" <> pretty c <> pretty s+ PconstChar c -> pretty c+ PconstString s Nothing -> dquote <> pretty s <> dquote+ PconstString _s (Just _q) -> error "TODO"+ PconstFloat s Nothing -> pretty s+ PconstFloat _s (Just _c) -> error "TODO"++instance Pretty Constant where+ pretty = constantPP
+ lib/Language/OCaml/PrettyPrinter/ConstructorArguments.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.PrettyPrinter.ConstructorArguments+ ( constructorArgumentsPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.CoreType ()++constructorArgumentsPP :: ConstructorArguments -> Doc a+constructorArgumentsPP = \case+ PcstrTuple l -> case l of+ [] -> ""+ [x] -> fillSep [ "of", pretty x ]+ _ -> fillSep [ "of", encloseSep "" "" " * " (map pretty l) ]+ PcstrRecord _ -> error "TODO"++instance Pretty ConstructorArguments where+ pretty = constructorArgumentsPP
+ lib/Language/OCaml/PrettyPrinter/ConstructorDeclaration.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.PrettyPrinter.ConstructorDeclaration+ ( constructorDeclarationPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.ConstructorArguments ()++constructorDeclarationPP :: ConstructorDeclaration -> Doc a+constructorDeclarationPP d =+ fillSep [ pipe, name, args, res ]+ where+ name = pretty $ pcdName d+ args = pretty $ pcdArgs d+ res = case pcdRes d of+ Nothing -> ""+ Just _r -> "TODO: res Just"++instance Pretty ConstructorDeclaration where+ pretty = constructorDeclarationPP
+ lib/Language/OCaml/PrettyPrinter/CoreType.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.PrettyPrinter.CoreType+ ( coreTypePP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.CoreTypeDesc ()++coreTypePP :: CoreType -> Doc a+coreTypePP = pretty . ptypDesc++instance Pretty CoreType where+ pretty = coreTypePP
+ lib/Language/OCaml/PrettyPrinter/CoreTypeDesc.hs view
@@ -0,0 +1,37 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.OCaml.PrettyPrinter.CoreTypeDesc+ ( coreTypedescPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.Loc ()+import Language.OCaml.PrettyPrinter.Longident ()++coreTypedescPP :: (Pretty CoreType) => CoreTypeDesc -> Doc a+coreTypedescPP = \case+ PtypAlias _ _ -> error "TODO"+ PtypAny -> "_"+ PtypArrow _ _ _ -> error "TODO"+ PtypClass _ _ -> error "TODO"+ PtypConstr i [] -> pretty i+ PtypConstr i [x] -> fillSep $ [ pretty x, pretty i ]+ PtypConstr ctor args ->+ fillSep $ map pretty (reverse args) ++ [pretty ctor]+ PtypPoly _ _ -> error "TODO"+ PtypTuple l -> encloseSep "" "" " * " $ map pretty l+ PtypVar s -> fillCat [ squote, pretty s ]+ PtypVariant _ _ _ -> error "TODO"+ PtypObject _ _ -> error "TODO"+ PtypExtension _ -> error "TODO"+ PtypPackage _ -> error "TODO"++instance Pretty CoreType => Pretty CoreTypeDesc where+ pretty = coreTypedescPP
+ lib/Language/OCaml/PrettyPrinter/Expression.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.PrettyPrinter.Expression+ ( expressionPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.ExpressionDesc ()++expressionPP :: Expression -> Doc a+expressionPP = pretty . pexpDesc++instance Pretty Expression where+ pretty = expressionPP
+ lib/Language/OCaml/PrettyPrinter/ExpressionDesc.hs view
@@ -0,0 +1,91 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.OCaml.PrettyPrinter.ExpressionDesc+ ( expressionDescPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.ArgLabel ()+import Language.OCaml.PrettyPrinter.Case ()+import Language.OCaml.PrettyPrinter.Constant ()+import Language.OCaml.PrettyPrinter.Loc ()+import Language.OCaml.PrettyPrinter.Longident ()+import Language.OCaml.PrettyPrinter.RecFlag ()+import Language.OCaml.PrettyPrinter.ValueBinding ()++expressionDescPP :: (Pretty Case, Pretty Expression) => ExpressionDesc -> Doc a+expressionDescPP = \case++ PexpApply e l ->+ encloseSep "" "" " " $ pretty e : map (\ (_lbl, expr) -> prettyExpr expr) l -- FIXME: lbl+ where+ prettyExpr expr@(Expression { pexpDesc }) = case pexpDesc of+ PexpApply _ _ -> parens $ pretty expr+ _ -> pretty expr++ PexpArray _ -> error "TODO"+ PexpAssert _ -> error "TODO"+ PexpCoerce _ _ _ -> error "TODO"+ PexpConstant c -> pretty c+ PexpConstraint _ _ -> error "TODO"++ PexpConstruct i e ->+ -- NOTE: adding space so as to print `Some x` rather than `Somex` when parentheses are omitted+ fillCat [ pretty i, space, pretty e ]++ PexpExtension _e -> error "TODO"+ PexpField _e _i -> error "TODO"+ PexpFor _ _ _ _ _ -> error "TODO"++ PexpFun _argLabel _ patt expr -> fillCat [ "fun ", pretty patt, " -> ", pretty expr ]++ PexpFunction l -> case l of+ [] -> error "TODO"+ [x] -> fillSep [ "function", pretty x ]+ _ -> fillSep [ "function", nest 2 $ line <> (vcat $ map pretty l) ]++ PexpIdent i -> pretty i+ PexpIfThenElse _e1 _e2 _e3 -> error "TODO"+ PexpLazy _ -> error "TODO"++ PexpLet r l e -> case l of+ [] -> error "TODO"+ [x] -> fillCat [ "let ", pretty r, pretty x, " in ", pretty e ]+ _ -> error "TODO"++ PexpLetException _ _ -> error "TODO"+ PexpLetModule _ _ _ -> error "TODO"++ PexpMatch discriminee branches -> vcat $ pretty discriminee : map pretty branches++ PexpNew _ -> error "TODO"+ PexpNewType _ _ -> error "TODO"+ PexpObject _ -> error "TODO"+ PexpOpen _ _ _ -> error "TODO"+ PexpOverride _ -> error "TODO"+ PexpPack _ -> error "TODO"+ PexpPoly _ _ -> error "TODO"+ PexpRecord _ _ -> error "TODO"+ PexpSend _ _ -> error "TODO"+ PexpSequence _e1 _e2 -> error "TODO"+ PexpSetField _ _ _ -> error "TODO"+ PexpSetInstVar _ _ -> error "TODO"+ PexpTry _ _ -> error "TODO"++ PexpTuple l -> encloseSep "(" ")" ", " (map pretty l)++ PexpUnreachable -> error "TODO"+ PexpVariant _ _ -> error "TODO"+ PexpWhile _ _ -> error "TODO"++instance Pretty Expression => Pretty ExpressionDesc where+ pretty = expressionDescPP
+ lib/Language/OCaml/PrettyPrinter/Internal.hs view
@@ -0,0 +1,6 @@+module Language.OCaml.PrettyPrinter.Internal+ ( structureItemPP+ ) where++import Language.OCaml.PrettyPrinter.Payload ()+import Language.OCaml.PrettyPrinter.StructureItem
+ lib/Language/OCaml/PrettyPrinter/LabelDeclaration.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.PrettyPrinter.LabelDeclaration+ ( labelDeclarationPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.CoreType ()+import Language.OCaml.PrettyPrinter.MutableFlag ()++labelDeclarationPP :: LabelDeclaration -> Doc a+labelDeclarationPP d = fillCat [ name, space, colon, space, mutable, type' ]+ where+ name = pretty $ pldName d+ mutable = pretty $ pldMutable d+ type' = pretty $ pldType d++instance Pretty LabelDeclaration where+ pretty = labelDeclarationPP
+ lib/Language/OCaml/PrettyPrinter/Loc.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.PrettyPrinter.Loc+ ( locPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ASTTypes++locPP :: (Pretty a) => Loc a -> Doc b+locPP = pretty . txt++instance Pretty a => Pretty (Loc a) where+ pretty = locPP
+ lib/Language/OCaml/PrettyPrinter/Longident.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.PrettyPrinter.Longident+ ( longidentPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree++longidentPP :: Longident -> Doc b+longidentPP = \case+ Lident s -> pretty s+ Ldot p s -> group $ pretty p <> "." <> pretty s+ Lapply _p _s -> error "TODO"++instance Pretty Longident where+ pretty = longidentPP
+ lib/Language/OCaml/PrettyPrinter/ModuleBinding.hs view
@@ -0,0 +1,22 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.PrettyPrinter.ModuleBinding+ ( moduleBindingPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.ModuleExpr ()++moduleBindingPP :: ModuleBinding -> Doc a+moduleBindingPP d = fillSep [ "module", name, "=", expr ]+ where+ name = pretty $ pmbName d+ expr = pretty $ pmbExpr d++instance Pretty ModuleBinding where+ pretty = moduleBindingPP
+ lib/Language/OCaml/PrettyPrinter/ModuleExpr.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.PrettyPrinter.ModuleExpr+ ( moduleExprPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.ModuleExprDesc ()++moduleExprPP :: ModuleExpr -> Doc a+moduleExprPP = pretty . pmodDesc++instance Pretty ModuleExpr where+ pretty = moduleExprPP
+ lib/Language/OCaml/PrettyPrinter/ModuleExprDesc.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.PrettyPrinter.ModuleExprDesc+ ( moduleExprDescPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.Loc ()+import Language.OCaml.PrettyPrinter.Longident ()++moduleExprDescPP :: ModuleExprDesc -> Doc a+moduleExprDescPP = \case+ PmodIdent i -> pretty i+ PmodStructure _ -> error "TODO"+ PmodFunctor _ _ _ -> error "TODO"+ PmodApply _ _ -> error "TODO"+ PmodConstraint _ _ -> error "TODO"+ PmodUnpack _ -> error "TODO"+ PmodExtension _ -> error "TODO"++instance Pretty ModuleExprDesc where+ pretty = moduleExprDescPP
+ lib/Language/OCaml/PrettyPrinter/MutableFlag.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.PrettyPrinter.MutableFlag+ ( mutableFlagPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.CoreType ()+import Language.OCaml.PrettyPrinter.Loc ()+import Language.OCaml.PrettyPrinter.Longident ()+import Language.OCaml.PrettyPrinter.OverrideFlag ()++mutableFlagPP :: MutableFlag -> Doc a+mutableFlagPP = \case+ Immutable -> ""+ Mutable -> fillCat [ "mutable", space ]++instance Pretty MutableFlag where+ pretty = mutableFlagPP
+ lib/Language/OCaml/PrettyPrinter/OpenDescription.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.PrettyPrinter.OpenDescription+ ( openDescriptionPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.Loc ()+import Language.OCaml.PrettyPrinter.Longident ()+import Language.OCaml.PrettyPrinter.OverrideFlag ()++openDescriptionPP :: OpenDescription -> Doc a+openDescriptionPP d = fillCat+ [ "open"+ , space+ , pretty $ popenOverride d+ , pretty $ popenLid d+ ]++instance Pretty OpenDescription where+ pretty = openDescriptionPP
+ lib/Language/OCaml/PrettyPrinter/OverrideFlag.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.PrettyPrinter.OverrideFlag+ ( overrideFlagPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ASTTypes++overrideFlagPP :: OverrideFlag -> Doc a+overrideFlagPP = \case+ Override -> "!"+ Fresh -> ""++instance Pretty OverrideFlag where+ pretty = overrideFlagPP
+ lib/Language/OCaml/PrettyPrinter/Pattern.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.PrettyPrinter.Pattern+ ( patternPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.PatternDesc ()++patternPP :: Pattern -> Doc a+patternPP = pretty . ppatDesc++instance Pretty Pattern where+ pretty = patternPP
+ lib/Language/OCaml/PrettyPrinter/PatternDesc.hs view
@@ -0,0 +1,56 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.OCaml.PrettyPrinter.PatternDesc+ ( patternDescPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.ModuleBinding ()+import Language.OCaml.PrettyPrinter.OpenDescription ()+import Language.OCaml.PrettyPrinter.TypeDeclaration ()++patternDescPP :: Pretty Pattern => PatternDesc -> Doc a+patternDescPP = \case++ PpatAlias _p _v -> error "TODO"++ PpatAny -> "_"++ PpatArray _ -> error "TODO"+ PpatConstant _c -> error "TODO"+ PpatConstraint _ _ -> error "TODO"++ PpatConstruct i p -> case p of+ Nothing -> pretty i+ Just p' ->+ -- NOTE: adding space here so as to print `Constructor _` rather than `Constructor_`+ fillCat [ pretty i, space, pretty p' ]++ PpatException _ -> error "TODO"+ PpatExtension _ -> error "TODO"+ PpatInterval _ _ -> error "TODO"+ PpatLazy _ -> error "TODO"+ PpatOpen _ _ -> error "TODO"++ PpatOr p1 p2 -> vcat [ pretty p1, fillSep [ pipe, pretty p2 ] ]++ PpatRecord _ _ -> error "TODO"++ PpatTuple l -> encloseSep "(" ")" "," $ map pretty l++ PpatType _ -> error "TODO"+ PpatUnpack _ -> error "TODO"++ PpatVar v -> pretty v++ PpatVariant _ _ -> error "TODO"++instance Pretty Pattern => Pretty PatternDesc where+ pretty = patternDescPP
+ lib/Language/OCaml/PrettyPrinter/Payload.hs view
@@ -0,0 +1,33 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.OCaml.PrettyPrinter.Payload+ ( payloadPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.ConstructorDeclaration ()+import Language.OCaml.PrettyPrinter.LabelDeclaration ()+import Language.OCaml.PrettyPrinter.Structure++payloadPP ::+ --( Pretty SignatureItem+ ( Pretty StructureItem+ ) => Payload -> Doc a+payloadPP = \case+ PStr s -> structurePP s+ PSig _s -> error "TODO" -- pretty s+ PTyp t -> pretty t+ PPat _p _e -> error "TODO"++instance --( Pretty SignatureItem+ ( Pretty StructureItem+ ) => Pretty Payload where+ pretty = payloadPP
+ lib/Language/OCaml/PrettyPrinter/RecFlag.hs view
@@ -0,0 +1,22 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.OCaml.PrettyPrinter.RecFlag+ ( recFlagPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ASTTypes++recFlagPP :: RecFlag -> Doc a+recFlagPP = \case+ Recursive -> "rec "+ NonRecursive -> ""++instance Pretty RecFlag where+ pretty = recFlagPP
+ lib/Language/OCaml/PrettyPrinter/Structure.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE FlexibleContexts #-}++module Language.OCaml.PrettyPrinter.Structure+ ( structurePP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.StructureItem ()++structurePP :: (Pretty Payload) => Structure -> Doc a+structurePP = vcat . map pretty
+ lib/Language/OCaml/PrettyPrinter/StructureItem.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.OCaml.PrettyPrinter.StructureItem+ ( structureItemPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.StructureItemDesc ()++structureItemPP :: (Pretty Payload) => StructureItem -> Doc a+structureItemPP = pretty . pstrDesc++instance (Pretty Payload) => Pretty StructureItem where+ pretty = structureItemPP
+ lib/Language/OCaml/PrettyPrinter/StructureItemDesc.hs view
@@ -0,0 +1,58 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.OCaml.PrettyPrinter.StructureItemDesc+ ( structureItemDescPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.Expression ()+import Language.OCaml.PrettyPrinter.ModuleBinding ()+import Language.OCaml.PrettyPrinter.OpenDescription ()+import Language.OCaml.PrettyPrinter.TypeDeclaration ()+import Language.OCaml.PrettyPrinter.ValueBinding ()++structureItemDescPP ::+ (Pretty Payload) => StructureItemDesc -> Doc a+structureItemDescPP = \case++ PstrAttribute _a -> error "TODO"+ PstrClass _ -> error "TODO"+ PstrClassType _ -> error "TODO"++ PstrEval e _a -> pretty e++ PstrException _e -> error "TODO"+ PstrExtension _e _a -> error "TODO"+ PstrInclude _ -> error "TODO"+ PstrModType _ -> error "TODO"++ PstrModule m -> pretty m++ PstrOpen o -> pretty o++ PstrPrimitive _ -> error "TODO"+ PstrRecModule _ -> error "TODO"++ PstrType _r l -> case l of+ [] -> error "?"+ h:t -> vcat $ fillSep [ "type", pretty h ]+ : map ((\ d -> fillSep [ "\nand", d]) . pretty) t++ PstrTypExt _ -> error "TODO"++ PstrValue r l -> case l of+ [] -> error "?"+ h : t ->+ vcat $ []+ ++ [ fillCat [ "let ", pretty r, pretty h ] ]+ ++ map ((\ d -> fillSep [ "\nand", d ]) . pretty) t++instance (Pretty Payload) => Pretty StructureItemDesc where+ pretty = structureItemDescPP
+ lib/Language/OCaml/PrettyPrinter/TypeDeclaration.hs view
@@ -0,0 +1,51 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.OCaml.PrettyPrinter.TypeDeclaration+ ( typeDeclarationPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.ConstructorDeclaration ()+import Language.OCaml.PrettyPrinter.LabelDeclaration ()+import Language.OCaml.PrettyPrinter.Variance ()++typeDeclarationPP :: (Pretty Payload) => TypeDeclaration -> Doc a+typeDeclarationPP d =+ fillCat [ params, name, space, "=", body, attrs ]+ where+ params = hcat $ map prettyParam $ ptypeParams d+ prettyParam (t, v) = fillCat [ pretty v, pretty t, space ]+ name = pretty $ ptypeName d+ manifest = case ptypeManifest d of+ Nothing -> "FIXME manifest"+ Just t -> pretty t+ body = case ptypeKind d of+ PtypeAbstract -> fillCat [ space, manifest ]+ PtypeVariant l -> case l of+ [] -> fillCat [ space, pipe ]+ _ -> nest 2 $ fillCat [ line, vcat $ map pretty l ]+ PtypeRecord l ->+ space+ <> (nest 2+ $ line+ <> encloseSep+ (lbrace <> space)+ (line <> rbrace)+ (semi <> space)+ (map pretty l)+ )+ PtypeOpen -> "TODO: Ptype_open"+ attrs = case ptypeAttributes d of+ [] -> ""+ as -> line <> (vcat . map displayAttr $ as)+ where+ displayAttr (s, p) = fillSep [ "[@@", pretty s, pretty p, "]" ]++instance (Pretty Payload) => Pretty TypeDeclaration where+ pretty = typeDeclarationPP
+ lib/Language/OCaml/PrettyPrinter/ValueBinding.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.OCaml.PrettyPrinter.ValueBinding+ ( valueBindingPP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ParseTree+import Language.OCaml.PrettyPrinter.Pattern ()++valueBindingPP :: (Pretty Expression) => ValueBinding -> Doc a+valueBindingPP d = fillSep [ pattern', "=", expr ]+ where+ pattern' = pretty $ pvbPat d+ expr = pretty $ pvbExpr d++instance (Pretty Expression) => Pretty ValueBinding where+ pretty = valueBindingPP
+ lib/Language/OCaml/PrettyPrinter/Variance.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.OCaml.PrettyPrinter.Variance+ ( variancePP+ ) where++import Data.Text.Prettyprint.Doc++import Language.OCaml.Definitions.Parsing.ASTTypes+import Language.OCaml.PrettyPrinter.ConstructorDeclaration ()+import Language.OCaml.PrettyPrinter.LabelDeclaration ()++variancePP :: Variance -> Doc a+variancePP = \case+ Contravariant -> "-"+ Covariant -> "+"+ Invariant -> ""++instance Pretty Variance where+ pretty = variancePP
+ lib/Language/OCaml/Utils.hs view
@@ -0,0 +1,9 @@+module Language.OCaml.Utils+ ( (<*^>)+ ) where++infixl 4 <*^>++-- like <*>, but lifts the incoming argument+(<*^>) :: (Applicative f) => f (a -> b) -> a -> f b+(<*^>) f a = f <*> pure a
+ test/Language/OCaml/Parser/AndLetBinding/Test.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.AndLetBinding.Test+ ( testStrings+ ) where++import Data.String.Interpolate++import qualified Language.OCaml.Parser.Attributes.Test as Attributes+import qualified Language.OCaml.Parser.LetBindingBody.Test as LetBindingBody+import qualified Language.OCaml.Parser.Payload.Test as Payload+import qualified Language.OCaml.Parser.PostItemAttributes.Test as PostItemAttributes++limit :: Int+limit = 10++testStrings :: [String] -> [String]+testStrings structure = []+ ++ [ [i| and #{a} #{lbb} #{pia} |]+ | a <- attributes+ , lbb <- letBindingBody+ , pia <- postItemAttributes+ ]+ where+ attributes = take limit $ Attributes.testStrings payload+ letBindingBody = take limit $ LetBindingBody.testStrings+ payload = take limit $ Payload.testStrings structure+ postItemAttributes = take limit $ PostItemAttributes.testStrings payload
+ test/Language/OCaml/Parser/AttrId/Test.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.AttrId.Test+ ( testStrings+ ) where++import Data.String.Interpolate++import qualified Language.OCaml.Parser.SingleAttrId.Test as SingleAttrId++limit :: Int+limit = 10++testStrings :: [String]+testStrings = []+ ++ SingleAttrId.testStrings+ ++ [ [i| #{sai}.#{ai} ] |]+ | sai <- SingleAttrId.testStrings+ , ai <- take limit testStrings+ ]
+ test/Language/OCaml/Parser/Attribute/Test.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.Attribute.Test+ ( testStrings+ ) where++import Data.String.Interpolate++import qualified Language.OCaml.Parser.AttrId.Test as AttrId++testStrings :: [String] -> [String]+testStrings payload = []+ ++ [ [i| [@@#{ai} #{p}] |]+ | ai <- AttrId.testStrings+ , p <- payload+ ]
+ test/Language/OCaml/Parser/Attributes/Test.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.Attributes.Test+ ( testStrings+ ) where++import Data.String.Interpolate++import qualified Language.OCaml.Parser.Attribute.Test as Attribute++limit :: Int+limit = 10++testStrings :: [String] -> [String]+testStrings payload = []+ ++ [ "" ]+ ++ [ [i| #{a} #{as} |]+ | a <- Attribute.testStrings payload+ , as <- take limit this+ ]+ where+ this = testStrings payload
+ test/Language/OCaml/Parser/Common/Test.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.Common.Test+ ( test+ , unitTests+ ) where++import Test.Tasty++import Language.OCaml.Parser.Internal+import Language.OCaml.Parser.TestUtils++constrIdentTests :: [String]+constrIdentTests =+ [ "A"+ , "Ab"+ , "AB"+ , "[]"+ , "false"+ , "true"+ , "A "+ , "Ab "+ , "AB "+ , "[] "+ , "false "+ , "true "+ ]++identTests :: [String]+identTests =+ [ "A"+ , "Ab"+ , "AB"+ , "a"+ , "aB"+ , "ab"+ , "A "+ , "Ab "+ , "AB "+ , "a "+ , "aB "+ , "ab "+ ]++unitTests :: TestTree+unitTests = testGroup "Language.OCaml.Parser.Common" $ []+ ++ map (mkParsingTest "constrIdentP" constrIdentP) constrIdentTests+ ++ map (mkParsingTest "identP" identP) identTests++test :: IO ()+test = defaultMain unitTests
+ test/Language/OCaml/Parser/Constant/Test.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.Parser.Constant.Test+ ( test+ , testStrings+ , unitTests+ ) where++import Test.Tasty++import Language.OCaml.Parser.Internal+import qualified Language.OCaml.Parser.Int.Test as Int+import Language.OCaml.Parser.TestUtils++testStrings :: [String]+testStrings = []+ ++ Int.testStrings+ -- TODO: CHAR+ -- TODO: STRING+ -- TODO: FLOAT++unitTests :: TestTree+unitTests = testGroup "Language.OCaml.Parser.Constant" $ []+ ++ map (mkParsingTest "valLongIdentP" valLongidentP) testStrings++test :: IO ()+test = defaultMain unitTests
+ test/Language/OCaml/Parser/ConstrLongident/Test.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.ConstrLongident.Test+ ( test+ , testStrings+ , unitTests+ ) where++import Data.String.Interpolate+import Test.Tasty++import Language.OCaml.Parser.Internal+import qualified Language.OCaml.Parser.ModLongident.Test as ModLongident+import Language.OCaml.Parser.TestUtils++testStrings :: [String]+testStrings = []+ ++ ModLongident.testStrings+ ++ [ [i| #{ml}.(::) |]+ | ml <- ModLongident.testStrings+ ]+ ++ [ "[]"+ , "()"+ , "(::)"+ , "false"+ , "true"+ ]++unitTests :: TestTree+unitTests = testGroup "Language.OCaml.Parser.ConstrLongident" $ []+ ++ map (mkParsingTest "constrLongidentP" constrLongidentP) testStrings++test :: IO ()+test = defaultMain unitTests
+ test/Language/OCaml/Parser/Expr/Test.hs view
@@ -0,0 +1,9 @@+module Language.OCaml.Parser.Expr.Test+ ( testStrings+ ) where++import qualified Language.OCaml.Parser.SimpleExpr.Test as SimpleExpr++testStrings :: [String] -> [String]+testStrings seqExpr = []+ ++ SimpleExpr.testStrings seqExpr
+ test/Language/OCaml/Parser/ExtAttributes/Test.hs view
@@ -0,0 +1,9 @@+module Language.OCaml.Parser.ExtAttributes.Test+ ( testStrings+ ) where++testStrings :: [String]+testStrings = []+ ++ [ "" ]+ -- TODO: Attribute Attributes+ -- TODO: % AttrId Attributes
+ test/Language/OCaml/Parser/Generator/Expr/Test.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.Generator.Expr.Test+ ( test+ , unitTests+ ) where++import Test.Tasty++import Language.OCaml.Parser.Generator.Parser+import Language.OCaml.Parser.TestUtils+import qualified Language.OCaml.Parser.TestStrings as TestStrings++unitTests :: TestTree+unitTests = testGroup "Language.OCaml.Parser.Generator.Expr" $ []+ ++ map (mkParsingTestG parseExpr) TestStrings.expr++test :: IO ()+test = defaultMain unitTests
+ test/Language/OCaml/Parser/Generator/Implementation/Test.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.Generator.Implementation.Test+ ( test+ , unitTests+ ) where++-- import Data.String.QQ+import Test.Tasty++-- import Language.OCaml.Parser.Generator.Lexer+import Language.OCaml.Parser.Generator.Parser+import Language.OCaml.Parser.TestUtils+import Language.OCaml.Parser.Implementation.Test (testFiles)++-- prefix :: FilePath+-- prefix = "test/ocaml/"++-- mlFiles :: [String]+-- mlFiles = []+-- ++ map (prefix ++)+-- [ "typing/typetexp.ml"+-- , "typing/path.ml"+-- , "typing/includecore.ml"+-- , "typing/printtyped.ml"+-- , "typing/typedecl.ml"+-- , "typing/btype.ml"+-- , "typing/typemod.ml"+-- , "typing/tast_mapper.ml"+-- , "typing/subst.ml"+-- , "typing/typecore.ml"+-- , "typing/datarepr.ml"+-- , "typing/typedtree.ml"+-- , "typing/untypeast.ml"+-- , "typing/parmatch.ml"+-- , "typing/ident.ml"+-- , "typing/cmt_format.ml"+-- , "typing/oprint.ml"+-- , "typing/env.ml"+-- , "typing/stypes.ml"+-- , "typing/includemod.ml"+-- , "typing/includeclass.ml"+-- , "typing/primitive.ml"+-- , "typing/envaux.ml"+-- , "typing/typeclass.ml"+-- , "typing/cmi_format.ml"+-- , "typing/printtyp.ml"+-- , "typing/mtype.ml"+-- , "typing/types.ml"+-- , "typing/typedtreeIter.ml"+-- , "typing/typedtreeMap.ml"+-- , "typing/typeopt.ml"+-- , "typing/printpat.ml"+-- , "typing/predef.ml"+-- , "typing/ctype.ml"+-- ]++unitTests :: TestTree+unitTests = testGroup "Language.OCaml.Parser.Generator.Implementation" $ []+ ++ map (mkParsingTestFromFileG parseImplementation) testFiles+ -- ++ map (mkParsingTestFromFileG parseImplementation) mlFiles++test :: IO ()+test = defaultMain unitTests
+ test/Language/OCaml/Parser/Generator/SeqExpr/Test.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.Generator.SeqExpr.Test+ ( test+ , unitTests+ ) where++-- import Data.String.QQ+import Test.Tasty++-- import Language.OCaml.Parser.Generator.Lexer+import Language.OCaml.Parser.Generator.Parser+-- import Language.OCaml.Parser.Internal+import Language.OCaml.Parser.TestUtils+import qualified Language.OCaml.Parser.TestStrings as TestStrings++unitTests :: TestTree+unitTests = testGroup "Language.OCaml.Parser.Generator.SeqExpr" $ []+ ++ map (mkParsingTestG parseSeqExpr) TestStrings.seqExpr+ -- ++ map (compareParses "SeqExpr" seqExprP parseSeqExpr) testStrings++test :: IO ()+test = defaultMain unitTests
+ test/Language/OCaml/Parser/Generator/SimpleExpr/Test.hs view
@@ -0,0 +1,17 @@+module Language.OCaml.Parser.Generator.SimpleExpr.Test+ ( test+ , unitTests+ ) where++import Test.Tasty++import Language.OCaml.Parser.Generator.Parser+import qualified Language.OCaml.Parser.TestStrings as TestStrings+import Language.OCaml.Parser.TestUtils++unitTests :: TestTree+unitTests = testGroup "Language.OCaml.Parser.Generator.SimpleExpr" $ []+ ++ map (mkParsingTestG parseSimpleExpr) TestStrings.simpleExpr++test :: IO ()+test = defaultMain unitTests
+ test/Language/OCaml/Parser/Generator/ValLongident/Test.hs view
@@ -0,0 +1,17 @@+module Language.OCaml.Parser.Generator.ValLongident.Test+ ( test+ , unitTests+ ) where++import Test.Tasty++import Language.OCaml.Parser.Generator.Parser+import Language.OCaml.Parser.TestUtils+import Language.OCaml.Parser.ValLongident.Test (testStrings)++unitTests :: TestTree+unitTests = testGroup "Language.OCaml.Parser.Generator.ValLongident" $ []+ ++ map (mkParsingTestG parseValLongident) testStrings++test :: IO ()+test = defaultMain unitTests
+ test/Language/OCaml/Parser/Implementation/Test.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.Implementation.Test+ ( test+ , testFiles+ , testStrings+ , unitTests+ ) where++-- import Data.String.QQ+import Test.Tasty++import Language.OCaml.Parser.Internal+import qualified Language.OCaml.Parser.Structure.Test as Structure+-- import Language.OCaml.Parser.Tokens+import Language.OCaml.Parser.TestUtils++prefix :: FilePath+prefix = "test/Language/OCaml/Parser/Implementation/"++testStrings :: [String]+testStrings = Structure.testStrings++testFiles :: [FilePath]+testFiles = map (prefix ++)+ [ "test_00.ml"+ , "test_01.ml"+ , "test_02.ml"+ , "test_03.ml"+ , "test_04.ml"+ , "test_05.ml"+ , "test_06.ml"+ , "test_07.ml"+ , "test_08.ml"+ -- , "FaCT/tast.ml"+ -- , "FaCT/tast-00.ml"+ -- , "FaCT/tast-01.ml"+ ]++unitTests :: TestTree+unitTests = testGroup "Language.OCaml.Parser.Generator.Implementation" $ []+ ++ map (mkParsingTestFromFile implementationP) testFiles++test :: IO ()+test = defaultMain unitTests
+ test/Language/OCaml/Parser/Int/Test.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.Parser.Int.Test+ ( test+ , testStrings+ , unitTests+ ) where++import Test.Tasty++import Language.OCaml.Parser.Internal+import Language.OCaml.Parser.TestUtils++testStrings :: [String]+testStrings =+ -- decimal literals+ [ "0"+ , "1234"+ , "01_23_45_67_89"+ -- hex literals+ , "0x01_23_45_67_89_AB_CD_EF"+ , "0X01_23_45_67_89_ab_cd_ef"+ -- oct literals+ , "0o01_23_45_67"+ , "0O01_23_45_67"+ -- bin literals+ , "0b01"+ , "0B01"+ ]++unitTests :: TestTree+unitTests = testGroup "Language.OCaml.Parser.Int" $ []+ ++ map (mkParsingTest "valLongIdentP" valLongidentP) testStrings++test :: IO ()+test = defaultMain unitTests
+ test/Language/OCaml/Parser/LetBinding/Test.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.LetBinding.Test+ ( testStrings+ ) where++import Data.String.Interpolate++import qualified Language.OCaml.Parser.ExtAttributes.Test as ExtAttributes+import qualified Language.OCaml.Parser.LetBindingBody.Test as LetBindingBody+import qualified Language.OCaml.Parser.Payload.Test as Payload+import qualified Language.OCaml.Parser.PostItemAttributes.Test as PostItemAttributes+import qualified Language.OCaml.Parser.RecFlag.Test as RecFlag++limit :: Int+limit = 10++testStrings :: [String] -> [String]+testStrings structure = []+ ++ [ [i| let #{ea} #{rf} #{lbb} #{pia} |]+ | ea <- extAttributes+ , rf <- recFlag+ , lbb <- letBindingBody+ , pia <- postItemAttributes+ ]+ where+ extAttributes = take limit $ ExtAttributes.testStrings+ recFlag = take limit $ RecFlag.testStrings+ letBindingBody = take limit $ LetBindingBody.testStrings+ payload = take limit $ Payload.testStrings structure+ postItemAttributes = take limit $ PostItemAttributes.testStrings payload
+ test/Language/OCaml/Parser/LetBindingBody/Test.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.LetBindingBody.Test+ ( testStrings+ ) where++import Data.String.Interpolate++import qualified Language.OCaml.Parser.StrictBinding.Test as StrictBinding+import qualified Language.OCaml.Parser.ValIdent.Test as ValIdent++limit :: Int+limit = 100++testStrings :: [String]+testStrings = []+ ++ [ [i| #{vi} #{sb} |]+ | vi <- valIdent+ , sb <- strictBinding+ ]+ where+ valIdent = take limit $ ValIdent.testStrings+ strictBinding = take limit $ StrictBinding.testStrings
+ test/Language/OCaml/Parser/LetBindings/Test.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.LetBindings.Test+ ( testStrings+ ) where++import Data.String.Interpolate++import qualified Language.OCaml.Parser.AndLetBinding.Test as AndLetBinding+import qualified Language.OCaml.Parser.LetBinding.Test as LetBinding++limit :: Int+limit = 10++testStrings :: [String] -> [String]+testStrings structure = []+ ++ letBinding+ ++ [ [i| #{lb} #{alb} |]+ | lb <- letBindings+ , alb <- andLetBinding+ ]+ where+ andLetBinding = take limit $ AndLetBinding.testStrings structure+ letBinding = take limit $ LetBinding.testStrings structure+ letBindings = take limit $ testStrings structure
+ test/Language/OCaml/Parser/MatchCase/Test.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.Parser.MatchCase.Test+ ( test+ , unitTests+ ) where++import Test.Tasty++import Language.OCaml.Parser.Internal+import Language.OCaml.Parser.TestUtils++matchCaseTests :: [String]+matchCaseTests =+ [ "a -> b"+ , "a -> B.c_d"+ , "a when b -> c"+ ]++unitTests :: TestTree+unitTests = testGroup "Language.OCaml.Parser.MatchCase" $ []+ ++ map (mkParsingTest "matchCaseP" matchCaseP) matchCaseTests++test :: IO ()+test = defaultMain unitTests
+ test/Language/OCaml/Parser/ModLongident/Test.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.Parser.ModLongident.Test+ ( test+ , testStrings+ , unitTests+ ) where++import Test.Tasty++import Language.OCaml.Parser.Internal+import Language.OCaml.Parser.TestUtils++testStrings :: [String]+testStrings =+ [ "Mod"+ , "Mod.Mod"+ ]++unitTests :: TestTree+unitTests = testGroup "Language.OCaml.Parser.ModLongident" $ []+ ++ map (mkParsingTest "modLongidentP" modLongidentP) testStrings++test :: IO ()+test = defaultMain unitTests
+ test/Language/OCaml/Parser/OpenStatement/Test.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.Parser.OpenStatement.Test+ ( test+ , unitTests+ ) where++import Test.Tasty++import Language.OCaml.Parser.Internal+import Language.OCaml.Parser.TestUtils++openStatementTests :: [String]+openStatementTests =+ [ "open A"+ , "open !A"+ -- , "(* A *) open !A"+ , "open !A (* A *)"+ -- , "(* A *) open !A (* A *)"+ ]++unitTests :: TestTree+unitTests = testGroup "Language.OCaml.Parser.OpenStatement" $ []+ ++ map (mkParsingTest "openStatementP" (openStatementP structureP)) openStatementTests++test :: IO ()+test = defaultMain unitTests
+ test/Language/OCaml/Parser/Operator/Test.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.Parser.Operator.Test+ ( testStrings+ ) where++testStrings :: [String]+testStrings =+ [ "!"+ , "+"+ , "+."+ , "-"+ , "-."+ , " *" -- needs space so that, when placed in parenthesis, does not become a comment+ , "="+ -- TODO+ ]
+ test/Language/OCaml/Parser/Pattern/Test.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.Parser.Pattern.Test+ ( test+ , unitTests+ ) where++import Test.Tasty++import Language.OCaml.Parser.Internal+import Language.OCaml.Parser.TestUtils++patternTests :: [String]+patternTests =+ [ "_"+ , "a"+ , "A"+ , "A a"+ , "A B"+ , "A _"+ , "A _ | B _"+ , "_, _"+ , "A _, B _"+ ]++unitTests :: TestTree+unitTests = testGroup "Language.OCaml.Parser.Pattern" $ []+ ++ map (mkParsingTest "patternP" patternP) patternTests++test :: IO ()+test = defaultMain unitTests
+ test/Language/OCaml/Parser/Payload/Test.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.Payload.Test+ ( testStrings+ ) where++-- import Data.String.Interpolate++testStrings :: [String] -> [String]+testStrings structure = []+ ++ structure
+ test/Language/OCaml/Parser/PostItemAttribute/Test.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.PostItemAttribute.Test+ --( test+ ( testStrings+ --, unitTests+ ) where++import Data.String.Interpolate+-- import Test.Tasty++-- import Language.OCaml.Parser.Internal+import qualified Language.OCaml.Parser.AttrId.Test as AttrId+-- import Language.OCaml.Parser.TestUtils++limit :: Int+limit = 3++testStrings :: [String] -> [String]+testStrings payload = []+ ++ [ [i| [@@ #{ai} #{p} ] |]+ | ai <- AttrId.testStrings+ , p <- take limit payload+ ]++-- unitTests :: TestTree+-- unitTests = testGroup "Language.OCaml.Parser.PostItemAttribute" $ []+-- ++ map (mkParsingTest "seqExprP" seqExprP) testStrings++-- test :: IO ()+-- test = defaultMain unitTests
+ test/Language/OCaml/Parser/PostItemAttributes/Test.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.PostItemAttributes.Test+ --( test+ ( testStrings+ --, unitTests+ ) where++import Data.String.Interpolate++import qualified Language.OCaml.Parser.PostItemAttribute.Test as PostItemAttribute++recursionLimit :: Int+recursionLimit = 10++testStrings :: [String] -> [String]+testStrings payload = []+ ++ [ "" ]+ ++ [ [i|#{pia} #{pias}|]+ | pia <- PostItemAttribute.testStrings payload+ , pias <- take recursionLimit this+ ]+ where+ this = testStrings payload++-- unitTests :: TestTree+-- unitTests = testGroup "Language.OCaml.Parser.PostItemAttributes" $ []+-- ++ map (mkParsingTest "seqExprP" seqExprP) testStrings++-- test :: IO ()+-- test = defaultMain unitTests
+ test/Language/OCaml/Parser/RecFlag/Test.hs view
@@ -0,0 +1,6 @@+module Language.OCaml.Parser.RecFlag.Test+ ( testStrings+ ) where++testStrings :: [String]+testStrings = [ "", "rec" ]
+ test/Language/OCaml/Parser/SeqExpr/Test.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.SeqExpr.Test+ ( testStrings+ ) where++import Data.String.Interpolate++import qualified Language.OCaml.Parser.Expr.Test as Expr++limit :: Int+limit = 5++testStrings :: [String]+testStrings = []+ ++ expr+ ++ [ [i|#{e};|] | e <- expr ]+ ++ [ [i|#{e};#{se}|] | e <- expr+ , se <- seqExpr ]+ where+ expr = Expr.testStrings seqExpr+ seqExpr = take limit testStrings
+ test/Language/OCaml/Parser/SimpleExpr/Test.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.SimpleExpr.Test+ ( testStrings+ ) where++import Data.String.Interpolate++import qualified Language.OCaml.Parser.Constant.Test as Constant+import qualified Language.OCaml.Parser.ConstrLongident.Test as ConstrLongident+import qualified Language.OCaml.Parser.ValLongident.Test as ValLongident++testStrings :: [String] -> [String]+testStrings seqExpr = []+ ++ ValLongident.testStrings+ ++ Constant.testStrings+ ++ ConstrLongident.testStrings+ -- TODO: NameTag+ ++ [ [i| (#{se}) |]+ | se <- seqExpr+ ]
+ test/Language/OCaml/Parser/SimplePattern/Test.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.OCaml.Parser.SimplePattern.Test+ ( test+ , unitTests+ ) where++import Test.Tasty++import Language.OCaml.Parser.Internal+import Language.OCaml.Parser.TestUtils++simplePatternTests :: [String]+simplePatternTests =+ [ "_"+ , "a"+ , "A"+ , "A.B"+ ]++unitTests :: TestTree+unitTests = testGroup "Language.OCaml.Parser.Pattern" $ []+ ++ map (mkParsingTest "simplePatternP" simplePatternP) simplePatternTests++test :: IO ()+test = defaultMain unitTests
+ test/Language/OCaml/Parser/SingleAttrId/Test.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.SingleAttrId.Test+ ( testStrings+ ) where++testStrings :: [String]+testStrings =+ [ "foo"+ , "Foo"+ , "and"+ , "as"+ , "and"+ , "as"+ , "assert"+ , "begin"+ , "class"+ , "constraint"+ , "do"+ , "done"+ , "downto"+ , "else"+ , "end"+ , "exception"+ , "external"+ , "false"+ , "for"+ , "fun"+ , "function"+ , "functor"+ , "if"+ , "in"+ , "include"+ , "inherit"+ , "initializer"+ , "lazy"+ , "let"+ , "match"+ , "method"+ , "module"+ , "mutable"+ , "new"+ , "nonrec"+ , "object"+ , "of"+ , "open"+ , "or"+ , "private"+ , "rec"+ , "sig"+ , "struct"+ , "then"+ , "to"+ , "true"+ , "try"+ , "type"+ , "val"+ , "virtual"+ , "when"+ , "while"+ , "with"+ ]
+ test/Language/OCaml/Parser/StrictBinding/Test.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.StrictBinding.Test+ ( testStrings+ ) where++import Data.String.Interpolate++import qualified Language.OCaml.Parser.SeqExpr.Test as SeqExpr++limit :: Int+limit = 100++testStrings :: [String]+testStrings = []+ ++ [ [i| = #{se} |]+ | se <- seqExpr+ ]+ -- TODO: rest+ where+ seqExpr = take limit $ SeqExpr.testStrings
+ test/Language/OCaml/Parser/Structure/Test.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.Structure.Test+ ( test+ , testStrings+ , unitTests+ ) where++import Data.String.Interpolate+import Test.Tasty++import Language.OCaml.Parser.Internal+import qualified Language.OCaml.Parser.Payload.Test as Payload+import qualified Language.OCaml.Parser.PostItemAttributes.Test as PostItemAttributes+import qualified Language.OCaml.Parser.SeqExpr.Test as SeqExpr+import qualified Language.OCaml.Parser.StructureTail.Test as StructureTail+import Language.OCaml.Parser.TestUtils++limit :: Int+limit = 2++testStrings :: [String]+testStrings = []+ ++ [ [i|#{se} #{pia} #{st}|]+ | se <- seqExpr+ , pia <- postItemAttributes+ , st <- structureTail+ ]+ where+ payload = take limit $ Payload.testStrings structure+ postItemAttributes = take limit $ PostItemAttributes.testStrings payload+ seqExpr = take limit $ SeqExpr.testStrings+ structure = take limit $ testStrings+ structureTail = take limit $ StructureTail.testStrings structure++unitTests :: TestTree+unitTests = testGroup "Language.OCaml.Parser.Structure" $ []+ ++ map (mkParsingTest "structureP" structureP) testStrings++test :: IO ()+test = defaultMain unitTests++-- debug = debugParsing structureP (structureTests !! 9)
+ test/Language/OCaml/Parser/StructureItem/Test.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.StructureItem.Test+ ( testStrings+ ) where++import qualified Language.OCaml.Parser.LetBindings.Test as LetBindings++limit :: Int+limit = 10++testStrings :: [String] -> [String]+testStrings structure = []+ ++ letBindings+ where+ letBindings = take limit $ LetBindings.testStrings structure
+ test/Language/OCaml/Parser/StructureTail/Test.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.StructureTail.Test+ ( testStrings+ ) where++import Data.String.Interpolate++import qualified Language.OCaml.Parser.StructureItem.Test as StructureItem++limit :: Int+limit = 10++testStrings :: [String] -> [String]+testStrings structure = []+ ++ [ "" ]+ ++ [ [i| ;; #{s} |]+ | s <- structure+ ]+ ++ [ [i| #{si} #{st} |]+ | si <- structureItem+ , st <- structureTail+ ]+ where+ structureItem = take limit $ StructureItem.testStrings structure+ structureTail = take limit $ testStrings structure
+ test/Language/OCaml/Parser/TestStrings.hs view
@@ -0,0 +1,43 @@+module Language.OCaml.Parser.TestStrings+ ( attributes+ , expr+ , payload+ , seqExpr+ , simpleExpr+ , structure+ , valIdent+ , valLongident+ ) where++import qualified Language.OCaml.Parser.Attributes.Test as Attributes+import qualified Language.OCaml.Parser.Expr.Test as Expr+import qualified Language.OCaml.Parser.Payload.Test as Payload+import qualified Language.OCaml.Parser.SeqExpr.Test as SeqExpr+import qualified Language.OCaml.Parser.SimpleExpr.Test as SimpleExpr+import qualified Language.OCaml.Parser.Structure.Test as Structure+import qualified Language.OCaml.Parser.ValIdent.Test as ValIdent+import qualified Language.OCaml.Parser.ValLongident.Test as ValLongident++attributes :: [String]+attributes = Attributes.testStrings payload++expr :: [String]+expr = Expr.testStrings seqExpr++payload :: [String]+payload = Payload.testStrings structure++seqExpr :: [String]+seqExpr = SeqExpr.testStrings++simpleExpr :: [String]+simpleExpr = SimpleExpr.testStrings seqExpr++structure :: [String]+structure = Structure.testStrings++valIdent :: [String]+valIdent = ValIdent.testStrings++valLongident :: [String]+valLongident = ValLongident.testStrings
+ test/Language/OCaml/Parser/TestUtils.hs view
@@ -0,0 +1,64 @@+module Language.OCaml.Parser.TestUtils+ ( compareParses+ , debugParsing+ , mkParsingTest+ , mkParsingTestG+ , mkParsingTestFromFile+ , mkParsingTestFromFileG+ , parse+ ) where++import Data.Void+import Text.Megaparsec+import Test.Tasty+import Test.Tasty.HUnit++import Language.OCaml.Parser+import Language.OCaml.Parser.Internal+import Language.OCaml.Parser.Utils.Utils++assertParsesC :: ParserC a -> String -> Assertion+assertParsesC parser input = do+ case parseMaybe parser input of+ Nothing -> assertFailure $ "Failed to parse: " ++ take 60 input+ Just _ -> return ()++assertParsesG :: ParserG a -> String -> Assertion+assertParsesG parser input = do+ case parser input of+ Left msg -> assertFailure msg+ Right _ -> return ()++mkParsingTest :: TestName -> Parser a -> String -> TestTree+mkParsingTest name parser input = testCase name $ assertParsesC parser input++mkParsingTestG :: (String -> Either String a) -> String -> TestTree+mkParsingTestG parser input = testCase shortInput $ assertParsesG parser input+ where+ shortInput | length input <= 40 = input+ | otherwise = take 40 input ++ "..."++mkParsingTestFromFile :: Parser a -> FilePath -> TestTree+mkParsingTestFromFile parser fileName = testCase fileName $ readFile fileName >>= assertParsesC parser++mkParsingTestFromFileG :: (String -> Either String a) -> FilePath -> TestTree+mkParsingTestFromFileG parser fileName = testCase fileName $ readFile fileName >>= assertParsesG parser++debugParsing :: Parser a -> String -> Either (ParseError (Token String) Void) a+debugParsing parser input =+ parse (ocamlSpace *> parser <* eof) "DEBUG" input++compareParses ::+ (Eq a, Show a) =>+ TestName -> Parser a -> (String -> Either String a) -> String -> TestTree+compareParses name parserC parserG input =+ testCase name $ do+ case (parseMaybe parserC input, parserG input) of+ (Just outputC, Right outputG) -> (outputC == outputG)+ @? ("Results differ:\n"+ ++ "Combinator: " ++ show outputC ++ "\n"+ ++ "Generator: " ++ show outputG ++ "\n"+ )+ (Just _, Left _) -> False @? "Parser generator failed"+ (Nothing, Right _) -> False @? "Parser combinator failed"+ (Nothing, Left _) -> False @? "Both parsers failed"
+ test/Language/OCaml/Parser/Tokens/Test.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.Tokens.Test+ ( test+ , unitTests+ ) where++import Data.String.QQ+-- import Text.Megaparsec+import Test.Tasty++import Language.OCaml.Parser.Internal+import Language.OCaml.Parser.TestUtils++-- lIdentTests :: [String]+-- lIdentTests = [ "a", "a " ]++-- uIdentTests :: [String]+-- uIdentTests = [ "A", "A " ]++-- starTests :: [String]+-- starTests = [ "*", "* ", " *", " * " ]++stringTests :: [String]+stringTests =+ [ [s|"foo"|]+ ]++unitTests :: TestTree+unitTests = testGroup "Language.OCaml.Parser.Tokens" $ []+ ++ map (mkParsingTest "stringT" stringT) stringTests++test :: IO ()+test = defaultMain unitTests++-- foo = debugParsing (stringT *> stringT) [s|"foo" "bar"|]
+ test/Language/OCaml/Parser/ValIdent/Test.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.ValIdent.Test+ ( testStrings+ ) where++import Data.String.Interpolate++import qualified Language.OCaml.Parser.Operator.Test as Operator++testStrings :: [String]+testStrings = []+ ++ [ "foo" ]+ ++ [ [i|(#{op})|] | op <- Operator.testStrings ]
+ test/Language/OCaml/Parser/ValLongident/Test.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.Parser.ValLongident.Test+ ( testStrings+ ) where++import Data.String.Interpolate++import qualified Language.OCaml.Parser.ModLongident.Test as ModLongident+import qualified Language.OCaml.Parser.ValIdent.Test as ValIdent++testStrings :: [String]+testStrings = []+ ++ ValIdent.testStrings+ ++ [ [i| #{m}.#{v} |]+ | m <- ModLongident.testStrings+ , v <- ValIdent.testStrings+ ]
+ test/Language/OCaml/PrettyPrinter/Structure/Test.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.PrettyPrinter.Structure.Test+ ( test+ , unitTests+ ) where++import Data.String.QQ+import Data.Text.Prettyprint.Doc+import Test.Tasty++import Language.OCaml.Parser.Generator.Parser (parseStructure)+import Language.OCaml.PrettyPrinter.Internal+import Language.OCaml.PrettyPrinter.TestUtils++structureTests :: [String]+structureTests =+ [ [s|+open Lexing+open Ast+open Env++type 'a binary_tree =+ | Leaf of 'a+ | Tree of 'a binary_tree * 'a binary_tree+ |]++ ]++unitTests :: TestTree+unitTests = testGroup "Language.OCaml.PrettyPrinter.Structure" $ []+ ++ map (mkPrettyPrinterTest+ "structurePP"+ parseStructure+ (vcat . map structureItemPP)+ ) structureTests++test :: IO ()+test = defaultMain unitTests++-- _foo = debugPrettyPrinter structureP (vcat . map structureItemPP) (structureTests !! 0)
+ test/Language/OCaml/PrettyPrinter/StructureItem/Test.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Language.OCaml.PrettyPrinter.StructureItem.Test+ ( test+ , unitTests+ ) where++import Data.String.QQ+-- import Data.Text.Prettyprint.Doc+import Test.Tasty++import Language.OCaml.Parser.Generator.Parser (parseStructureItem)+import Language.OCaml.PrettyPrinter.Internal+import Language.OCaml.PrettyPrinter.TestUtils++structureItemTests :: [String]+structureItemTests =++ [ "type a = _"++ , "type a = 'b"++ , "type a = b"++ , "type a = |"++ , "type a = A"++ , "type a = A of t"++ , "type a = A of t | B of t"++ , "type a = A | B"++ , "type a = A | B | C"++ , "type a = | A | B | C"++ , [s|+type a =+ | B+ | C+ |]++ , "type a_b = {c: float; d: float}"++ , "type a_b = C of D.e_f"++ , [s|+type a =+ | B of C.d_e+ | F+ |]++ , "open A"++ , "open !A"++ , "open !A (* A *)"++ , "module F = Format"++ , [s|+type a_b =+ { foo_bar: float+ ; bar: float }+ |]++ , "type c_d = {a: b; c: d}"++ , "type e_f = G of A.b * C.d_f | H | I"++ , "let a = b"++ , [s|+let some_function = function+ | Constructor _ ->+ Module.some_other_function+ | OtherConstructor _ ->+ OtherModule.other_function+ |]++ , [s|+let string_of_something = function+ | Constructor _ ->+ "some_string"+ |]++ , [s|+let multi_patterns = function+ | Constructor1 foo_bar+ | Constructor2 foo_bar+ | Constructor3 foo_bar ->+ Some foo_bar+ | _ ->+ None+ |]++ , [s|+let rec f =+ let a = b in c+ |]++ , [s|+type 'a binary_tree =+ | Leaf of 'a+ | Tree of 'a binary_tree * 'a binary_tree+ |]++ , [s|+type 'a list =+ | Nil+ | Cons of ('a * 'a list)+ |]++ ]++unitTests :: TestTree+unitTests = testGroup "Language.OCaml.PrettyPrinter.StructureItem" $ []+ ++ map (mkPrettyPrinterTest+ "structureItemPP"+ parseStructureItem+ structureItemPP+ ) structureItemTests++test :: IO ()+test = defaultMain unitTests++-- foo = debugPrettyPrinter parseStructureItem structureItemPP (structureItemTests !! 24)
+ test/Language/OCaml/PrettyPrinter/TestUtils.hs view
@@ -0,0 +1,71 @@+module Language.OCaml.PrettyPrinter.TestUtils+ ( DebugPrettyPrinter(..)+ , debugPrettyPrinter+ , mkPrettyPrinterTest+ , parseAndPrettyPrint+ , parseMaybe+ , pretty+ , roundtrip+ ) where++import Data.Text.Prettyprint.Doc+import Text.Megaparsec+import Test.Tasty+import Test.Tasty.HUnit++-- import Language.OCaml.++import Language.OCaml.Parser++mkPrettyPrinterTest :: (Eq a) => TestName -> ParserG a -> (a -> Doc b) -> String -> TestTree+mkPrettyPrinterTest name parser printer input =+ testCase name $ condition @? message+ where+ condition =+ case parser input of+ Left _ -> False+ Right r ->+ case parser (show $ printer r) of+ Left _ -> False+ Right r' -> r == r'+ message = "Failed to roundtrip:\n" ++ prefix ++ if length input > 20 then "..." else ""+ prefix = take 20 input++data DebugPrettyPrinter a b+ = NoParse1+ | NoParse2 a (Doc b)+ | ParseDiff a a+ | ParseEq a++instance (Pretty a, Show a) => Show (DebugPrettyPrinter a b) where+ show NoParse1 = "The input did not parse correctly"+ show (NoParse2 a d) =+ "The input parsed correctly, but its pretty-printed version did not parse\n"+ ++ show a ++ "\n"+ ++ show d ++ "\n"+ show (ParseDiff a b) =+ "The input parsed correctly, but its re-parse differs from it\n"+ ++ show a ++ "\n"+ ++ show b ++ "\n"+ ++ show (pretty a) ++ "\n"+ ++ show (pretty b) ++ "\n"+ show (ParseEq a) =+ "The input parsed correctly, and its re-parse matches\n"+ ++ show a ++ "\n"+ ++ show (pretty a) ++ "\n"++debugPrettyPrinter ::+ (Eq a) => ParserG a -> (a -> Doc b) -> String -> DebugPrettyPrinter a b+debugPrettyPrinter parser printer input =+ case parser input of+ Left _ -> NoParse1+ Right r ->+ case parser (show $ printer r) of+ Left _ -> NoParse2 r (printer r)+ Right r' -> if r == r' then ParseEq r' else ParseDiff r r'++parseAndPrettyPrint :: ParserG a -> (a -> Doc b) -> String -> Either String (Doc b)+parseAndPrettyPrint parser printer input = printer <$> parser input++roundtrip :: ParserG a -> (a -> Doc b) -> String -> Either String String+roundtrip p pp s = (show . pp) <$> p s
+ test/Main.hs view
@@ -0,0 +1,89 @@+{-# language OverloadedStrings #-}++module Main where++import Test.Tasty++-- import qualified Language.OCaml.Parser.Common.Test+-- import qualified Language.OCaml.Parser.ConstrLongident.Test+-- import qualified Language.OCaml.Parser.Expr.Test+-- import qualified Language.OCaml.Parser.Generator.Common.Test+-- import qualified Language.OCaml.Parser.Generator.ConstrLongident.Test+import qualified Language.OCaml.Parser.Generator.Expr.Test+import qualified Language.OCaml.Parser.Generator.Implementation.Test+-- import qualified Language.OCaml.Parser.Generator.MatchCase.Test+-- import qualified Language.OCaml.Parser.Generator.ModLongident.Test+-- import qualified Language.OCaml.Parser.Generator.OpenStatement.Test+-- import qualified Language.OCaml.Parser.Generator.Pattern.Test+import qualified Language.OCaml.Parser.Generator.SeqExpr.Test+import qualified Language.OCaml.Parser.Generator.SimpleExpr.Test+-- import qualified Language.OCaml.Parser.Generator.SimplePattern.Test+-- import qualified Language.OCaml.Parser.Generator.Structure.Test+-- import qualified Language.OCaml.Parser.Generator.StructureItem.Test+-- import qualified Language.OCaml.Parser.Generator.Tokens.Test+-- import qualified Language.OCaml.Parser.Generator.ValIdent.Test+import qualified Language.OCaml.Parser.Generator.ValLongident.Test+-- import qualified Language.OCaml.Parser.Implementation.Test+-- import qualified Language.OCaml.Parser.MatchCase.Test+-- import qualified Language.OCaml.Parser.ModLongident.Test+-- import qualified Language.OCaml.Parser.OpenStatement.Test+-- import qualified Language.OCaml.Parser.Pattern.Test+-- import qualified Language.OCaml.Parser.SeqExpr.Test+-- import qualified Language.OCaml.Parser.SimpleExpr.Test+-- import qualified Language.OCaml.Parser.SimplePattern.Test+-- import qualified Language.OCaml.Parser.Structure.Test+-- import qualified Language.OCaml.Parser.StructureItem.Test+-- import qualified Language.OCaml.Parser.Tokens.Test+-- import qualified Language.OCaml.Parser.ValIdent.Test+-- import qualified Language.OCaml.Parser.ValLongident.Test+import qualified Language.OCaml.PrettyPrinter.StructureItem.Test+import qualified Language.OCaml.PrettyPrinter.Structure.Test++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" $ []+ -- ++ [ testGroup "Parser combinator" $+ -- [ Language.OCaml.Parser.Common.Test.unitTests+ -- , Language.OCaml.Parser.ConstrLongident.Test.unitTests+ -- , Language.OCaml.Parser.Expr.Test.unitTests+ -- , Language.OCaml.Parser.Implementation.Test.unitTests+ -- , Language.OCaml.Parser.MatchCase.Test.unitTests+ -- , Language.OCaml.Parser.ModLongident.Test.unitTests+ -- , Language.OCaml.Parser.OpenStatement.Test.unitTests+ -- , Language.OCaml.Parser.Pattern.Test.unitTests+ -- , Language.OCaml.Parser.SeqExpr.Test.unitTests+ -- , Language.OCaml.Parser.SimpleExpr.Test.unitTests+ -- , Language.OCaml.Parser.SimplePattern.Test.unitTests+ -- , Language.OCaml.Parser.Structure.Test.unitTests+ -- , Language.OCaml.Parser.StructureItem.Test.unitTests+ -- , Language.OCaml.Parser.Tokens.Test.unitTests+ -- , Language.OCaml.Parser.ValIdent.Test.unitTests+ -- , Language.OCaml.Parser.ValLongident.Test.unitTests+ -- ]+ -- ]+ ++ [ testGroup "Parser generator" $+ -- [ Language.OCaml.Parser.Generator.Common.Test.unitTests+ -- , Language.OCaml.Parser.Generator.ConstrLongident.Test.unitTests+ [ Language.OCaml.Parser.Generator.Expr.Test.unitTests+ , Language.OCaml.Parser.Generator.Implementation.Test.unitTests+ -- , Language.OCaml.Parser.Generator.MatchCase.Test.unitTests+ -- , Language.OCaml.Parser.Generator.ModLongident.Test.unitTests+ -- , Language.OCaml.Parser.Generator.OpenStatement.Test.unitTests+ -- , Language.OCaml.Parser.Generator.Pattern.Test.unitTests+ , Language.OCaml.Parser.Generator.SeqExpr.Test.unitTests+ , Language.OCaml.Parser.Generator.SimpleExpr.Test.unitTests+ -- , Language.OCaml.Parser.Generator.SimplePattern.Test.unitTests+ -- , Language.OCaml.Parser.Generator.Structure.Test.unitTests+ -- , Language.OCaml.Parser.Generator.StructureItem.Test.unitTests+ -- , Language.OCaml.Parser.Generator.Tokens.Test.unitTests+ -- , Language.OCaml.Parser.Generator.ValIdent.Test.unitTests+ , Language.OCaml.Parser.Generator.ValLongident.Test.unitTests+ ]+ ]+ ++ [ testGroup "PrettyPrinter" $+ [ Language.OCaml.PrettyPrinter.Structure.Test.unitTests+ , Language.OCaml.PrettyPrinter.StructureItem.Test.unitTests+ ]+ ]