diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/language-ocaml.cabal b/language-ocaml.cabal new file mode 100644 --- /dev/null +++ b/language-ocaml.cabal @@ -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 diff --git a/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Common.hs b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Common.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Common.hs @@ -0,0 +1,8 @@ +module Language.OCaml.Definitions.Parsing.ASTHelper.Common + ( defaultLoc + ) where + +import Language.OCaml.Definitions.Parsing.Location + +defaultLoc :: Location +defaultLoc = none diff --git a/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Exception.hs b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Exception.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Exception.hs @@ -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 + } diff --git a/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Exp.hs b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Exp.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Exp.hs @@ -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 diff --git a/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Mb.hs b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Mb.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Mb.hs @@ -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 = [] + } diff --git a/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Mod.hs b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Mod.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Mod.hs @@ -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 + } diff --git a/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Mtd.hs b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Mtd.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Mtd.hs @@ -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 = [] + } diff --git a/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Mty.hs b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Mty.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Mty.hs @@ -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 diff --git a/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Opn.hs b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Opn.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Opn.hs @@ -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 + } diff --git a/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Pat.hs b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Pat.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Pat.hs @@ -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 + } diff --git a/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Str.hs b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Str.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Str.hs @@ -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 diff --git a/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Te.hs b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Te.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Te.hs @@ -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 + } diff --git a/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Typ.hs b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Typ.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Typ.hs @@ -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 } diff --git a/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Type.hs b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Type.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Type.hs @@ -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 = [] + } diff --git a/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Val.hs b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Val.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Val.hs @@ -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 = [] + } diff --git a/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Vb.hs b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Vb.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/ASTHelper/Vb.hs @@ -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 = [] + } diff --git a/lib/Language/OCaml/Definitions/Parsing/ASTTypes.hs b/lib/Language/OCaml/Definitions/Parsing/ASTTypes.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/ASTTypes.hs @@ -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) diff --git a/lib/Language/OCaml/Definitions/Parsing/Docstrings.hs b/lib/Language/OCaml/Definitions/Parsing/Docstrings.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/Docstrings.hs @@ -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 } diff --git a/lib/Language/OCaml/Definitions/Parsing/Location.hs b/lib/Language/OCaml/Definitions/Parsing/Location.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/Location.hs @@ -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__" diff --git a/lib/Language/OCaml/Definitions/Parsing/Longident.hs b/lib/Language/OCaml/Definitions/Parsing/Longident.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/Longident.hs @@ -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" diff --git a/lib/Language/OCaml/Definitions/Parsing/ParseTree.hs b/lib/Language/OCaml/Definitions/Parsing/ParseTree.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/ParseTree.hs @@ -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 diff --git a/lib/Language/OCaml/Definitions/Parsing/Parser/LetBinding.hs b/lib/Language/OCaml/Definitions/Parsing/Parser/LetBinding.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/Parser/LetBinding.hs @@ -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) diff --git a/lib/Language/OCaml/Definitions/Parsing/Parser/LetBindings.hs b/lib/Language/OCaml/Definitions/Parsing/Parser/LetBindings.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/Parsing/Parser/LetBindings.hs @@ -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) diff --git a/lib/Language/OCaml/Definitions/StdLib/Lexing.hs b/lib/Language/OCaml/Definitions/StdLib/Lexing.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/StdLib/Lexing.hs @@ -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) diff --git a/lib/Language/OCaml/Definitions/StdLib/Parsing.hs b/lib/Language/OCaml/Definitions/StdLib/Parsing.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Definitions/StdLib/Parsing.hs @@ -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 diff --git a/lib/Language/OCaml/Parser.hs b/lib/Language/OCaml/Parser.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/AndTypeDeclaration.hs b/lib/Language/OCaml/Parser/AndTypeDeclaration.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/AndTypeDeclaration.hs @@ -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 [] diff --git a/lib/Language/OCaml/Parser/AttrId.hs b/lib/Language/OCaml/Parser/AttrId.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/AttrId.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/Attribute.hs b/lib/Language/OCaml/Parser/Attribute.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/Attribute.hs @@ -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) diff --git a/lib/Language/OCaml/Parser/Attributes.hs b/lib/Language/OCaml/Parser/Attributes.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/Attributes.hs @@ -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) diff --git a/lib/Language/OCaml/Parser/BarConstructorDeclaration.hs b/lib/Language/OCaml/Parser/BarConstructorDeclaration.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/BarConstructorDeclaration.hs @@ -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)) diff --git a/lib/Language/OCaml/Parser/Common.hs b/lib/Language/OCaml/Parser/Common.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/Common.hs @@ -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) diff --git a/lib/Language/OCaml/Parser/Constant.hs b/lib/Language/OCaml/Parser/Constant.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/Constant.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/ConstrIdent.hs b/lib/Language/OCaml/Parser/ConstrIdent.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/ConstrIdent.hs @@ -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" + ] diff --git a/lib/Language/OCaml/Parser/ConstrLongident.hs b/lib/Language/OCaml/Parser/ConstrLongident.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/ConstrLongident.hs @@ -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") + ] diff --git a/lib/Language/OCaml/Parser/ConstructorArguments.hs b/lib/Language/OCaml/Parser/ConstructorArguments.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/ConstructorArguments.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/ConstructorDeclaration.hs b/lib/Language/OCaml/Parser/ConstructorDeclaration.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/ConstructorDeclaration.hs @@ -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)) diff --git a/lib/Language/OCaml/Parser/ConstructorDeclarations.hs b/lib/Language/OCaml/Parser/ConstructorDeclarations.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/ConstructorDeclarations.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/CoreType.hs b/lib/Language/OCaml/Parser/CoreType.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/CoreType.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/CoreType2.hs b/lib/Language/OCaml/Parser/CoreType2.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/CoreType2.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/CoreTypeCommaList.hs b/lib/Language/OCaml/Parser/CoreTypeCommaList.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/CoreTypeCommaList.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/CoreTypeList.hs b/lib/Language/OCaml/Parser/CoreTypeList.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/CoreTypeList.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/CoreTypeNoAttr.hs b/lib/Language/OCaml/Parser/CoreTypeNoAttr.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/CoreTypeNoAttr.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/Expr.hs b/lib/Language/OCaml/Parser/Expr.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/Expr.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/ExprSemiList.hs b/lib/Language/OCaml/Parser/ExprSemiList.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/ExprSemiList.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/FunBinding.hs b/lib/Language/OCaml/Parser/FunBinding.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/FunBinding.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/FunDef.hs b/lib/Language/OCaml/Parser/FunDef.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/FunDef.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/GeneralizedConstructorArguments.hs b/lib/Language/OCaml/Parser/GeneralizedConstructorArguments.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/GeneralizedConstructorArguments.hs @@ -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) + ] diff --git a/lib/Language/OCaml/Parser/Generator/Lexer.x b/lib/Language/OCaml/Parser/Generator/Lexer.x new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/Generator/Lexer.x @@ -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 + \" { endString } + . { appendString } + \\[nt\"] { escapeString } + + -- while inside a comment + "(*" { beginInnerComment False } + "*)" { endComment } + [.\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) + +} diff --git a/lib/Language/OCaml/Parser/Generator/Parser.y b/lib/Language/OCaml/Parser/Generator/Parser.y new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/Generator/Parser.y @@ -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 " } + | 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 " } +-- | 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 " } + -- TODO + +Pattern :: { Pattern } + : Pattern as ValIdent { mkpat $ PpatAlias $1 (mkRHS $3 3) } + | Pattern as error {% alexError "Pattern as " } + | PatternCommaList %prec belowComma { mkpat $ PpatTuple (reverse $1) } + | Pattern "::" Pattern { mkpatCons (rhsLoc 2) (ghpat $ PpatTuple [$1, $3]) (symbolRLoc ()) } + | Pattern "::" error {% alexError "Pattern :: " } + | Pattern "|" Pattern { mkpat $ PpatOr $1 $3 } + | Pattern "|" error {% alexError "Pattern | " } + -- | 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 , " } + +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 " } + | PatternNoExnCommaList %prec belowComma { mkpat $ PpatTuple (reverse $1) } + | PatternNoExn "::" Pattern { mkpatCons (rhsLoc 2) (ghpat $ PpatTuple [$1, $3]) (symbolRLoc ()) } + | PatternNoExn "::" error {% alexError "PatternNoExn :: " } + | PatternNoExn "|" Pattern { mkpat $ PpatOr $1 $3 } + | PatternNoExn "|" error {% alexError "PatternNoExn | " } + | PatternNoExn Attribute { Pat.attr $1 $2 } + | PatternGen { $1 } + +PatternNoExnCommaList :: { [Pattern] } + : PatternNoExnCommaList "," Pattern { $3 : $1 } + | PatternNoExn "," Pattern { [$3, $1] } + | PatternNoExn "," error {% alexError "PatternNoExn , " } + +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 " } + | "[" PatternSemiList OptSemi "]" { relocPat $ mktailpat (rhsLoc 4) (reverse $2) } + | "[" PatternSemiList OptSemi error {% alexError "[ PatternSemiList OptSemi " } + | "[|" PatternSemiList OptSemi "|]" { mkpat $ PpatArray (reverse $2) } + | "[|" "|]" { mkpat $ PpatArray [] } + | "[|" PatternSemiList OptSemi error {% alexError "[| PatternSemiList OptSemi " } + +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 " } + | begin ExtAttributes SeqExpr end { wrapExpAttrs (relocExp $3) $2 } + | begin ExtAttributes end { mkexpAttrs (PexpConstruct (mkLoc (Lident "()") (symbolRLoc ())) Nothing) $2 } + | begin ExtAttributes error {% alexError "begin ExtAttributes " } + | "(" 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 . ( " } + | "(" Pattern ")" { relocPat $2 } + | "(" Pattern error {% alexError "( Pattern " } + | "(" Pattern ":" CoreType ")" { mkpat $ PpatConstraint $2 $4 } + | "(" Pattern ":" CoreType error {% alexError "( Pattern : CoreType " } + | "(" Pattern ":" error {% alexError "( Pattern : " } + | "(" 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 " } + | 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 {% alexError ":> " } + +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 + +} diff --git a/lib/Language/OCaml/Parser/Implementation.hs b/lib/Language/OCaml/Parser/Implementation.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/Implementation.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/Internal.hs b/lib/Language/OCaml/Parser/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/Internal.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/Label.hs b/lib/Language/OCaml/Parser/Label.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/Label.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/LabelDeclaration.hs b/lib/Language/OCaml/Parser/LabelDeclaration.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/LabelDeclaration.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/LabelDeclarationSemi.hs b/lib/Language/OCaml/Parser/LabelDeclarationSemi.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/LabelDeclarationSemi.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/LabelDeclarations.hs b/lib/Language/OCaml/Parser/LabelDeclarations.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/LabelDeclarations.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/LabelLongident.hs b/lib/Language/OCaml/Parser/LabelLongident.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/LabelLongident.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/LabeledSimpleExpr.hs b/lib/Language/OCaml/Parser/LabeledSimpleExpr.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/LabeledSimpleExpr.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/LabeledSimplePattern.hs b/lib/Language/OCaml/Parser/LabeledSimplePattern.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/LabeledSimplePattern.hs @@ -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) + ] diff --git a/lib/Language/OCaml/Parser/LblExpr.hs b/lib/Language/OCaml/Parser/LblExpr.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/LblExpr.hs @@ -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) + ] diff --git a/lib/Language/OCaml/Parser/LblExprList.hs b/lib/Language/OCaml/Parser/LblExprList.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/LblExprList.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/LblPattern.hs b/lib/Language/OCaml/Parser/LblPattern.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/LblPattern.hs @@ -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) + ] diff --git a/lib/Language/OCaml/Parser/LblPatternList.hs b/lib/Language/OCaml/Parser/LblPatternList.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/LblPatternList.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/LetBinding.hs b/lib/Language/OCaml/Parser/LetBinding.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/LetBinding.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/LetBindingBody.hs b/lib/Language/OCaml/Parser/LetBindingBody.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/LetBindingBody.hs @@ -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 + ) + ] diff --git a/lib/Language/OCaml/Parser/LetBindings.hs b/lib/Language/OCaml/Parser/LetBindings.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/LetBindings.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/MatchCase.hs b/lib/Language/OCaml/Parser/MatchCase.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/MatchCase.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/MatchCases.hs b/lib/Language/OCaml/Parser/MatchCases.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/MatchCases.hs @@ -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 (:))) (: []) diff --git a/lib/Language/OCaml/Parser/ModExtLongident.hs b/lib/Language/OCaml/Parser/ModExtLongident.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/ModExtLongident.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/ModLongident.hs b/lib/Language/OCaml/Parser/ModLongident.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/ModLongident.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/ModuleBinding.hs b/lib/Language/OCaml/Parser/ModuleBinding.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/ModuleBinding.hs @@ -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 + ) diff --git a/lib/Language/OCaml/Parser/ModuleBindingBody.hs b/lib/Language/OCaml/Parser/ModuleBindingBody.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/ModuleBindingBody.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/ModuleExpr.hs b/lib/Language/OCaml/Parser/ModuleExpr.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/ModuleExpr.hs @@ -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) + ] diff --git a/lib/Language/OCaml/Parser/MutableFlag.hs b/lib/Language/OCaml/Parser/MutableFlag.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/MutableFlag.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/NonRecFlag.hs b/lib/Language/OCaml/Parser/NonRecFlag.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/NonRecFlag.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/OpenStatement.hs b/lib/Language/OCaml/Parser/OpenStatement.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/OpenStatement.hs @@ -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 + ) diff --git a/lib/Language/OCaml/Parser/Operator.hs b/lib/Language/OCaml/Parser/Operator.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/Operator.hs @@ -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 "-" + ] diff --git a/lib/Language/OCaml/Parser/OptBar.hs b/lib/Language/OCaml/Parser/OptBar.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/OptBar.hs @@ -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 () + ] diff --git a/lib/Language/OCaml/Parser/OptPatternTypeConstraint.hs b/lib/Language/OCaml/Parser/OptPatternTypeConstraint.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/OptPatternTypeConstraint.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/OptSemi.hs b/lib/Language/OCaml/Parser/OptSemi.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/OptSemi.hs @@ -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 () + ] diff --git a/lib/Language/OCaml/Parser/OptTypeConstraint.hs b/lib/Language/OCaml/Parser/OptTypeConstraint.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/OptTypeConstraint.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/OptionalTypeParameter.hs b/lib/Language/OCaml/Parser/OptionalTypeParameter.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/OptionalTypeParameter.hs @@ -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) diff --git a/lib/Language/OCaml/Parser/OptionalTypeParameters.hs b/lib/Language/OCaml/Parser/OptionalTypeParameters.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/OptionalTypeParameters.hs @@ -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 [] + ] diff --git a/lib/Language/OCaml/Parser/OptionalTypeVariable.hs b/lib/Language/OCaml/Parser/OptionalTypeVariable.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/OptionalTypeVariable.hs @@ -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) diff --git a/lib/Language/OCaml/Parser/OverrideFlag.hs b/lib/Language/OCaml/Parser/OverrideFlag.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/OverrideFlag.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/Pattern.hs b/lib/Language/OCaml/Parser/Pattern.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/Pattern.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/PatternGen.hs b/lib/Language/OCaml/Parser/PatternGen.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/PatternGen.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/PatternNoExn.hs b/lib/Language/OCaml/Parser/PatternNoExn.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/PatternNoExn.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/PatternSemiList.hs b/lib/Language/OCaml/Parser/PatternSemiList.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/PatternSemiList.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/Payload.hs b/lib/Language/OCaml/Parser/Payload.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/Payload.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/PolyTypeNoAttr.hs b/lib/Language/OCaml/Parser/PolyTypeNoAttr.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/PolyTypeNoAttr.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/PostItemAttribute.hs b/lib/Language/OCaml/Parser/PostItemAttribute.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/PostItemAttribute.hs @@ -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) diff --git a/lib/Language/OCaml/Parser/PostItemAttributes.hs b/lib/Language/OCaml/Parser/PostItemAttributes.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/PostItemAttributes.hs @@ -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) diff --git a/lib/Language/OCaml/Parser/PrivateFlag.hs b/lib/Language/OCaml/Parser/PrivateFlag.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/PrivateFlag.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/RecFlag.hs b/lib/Language/OCaml/Parser/RecFlag.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/RecFlag.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/RecordExpr.hs b/lib/Language/OCaml/Parser/RecordExpr.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/RecordExpr.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/SeqExpr.hs b/lib/Language/OCaml/Parser/SeqExpr.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/SeqExpr.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/SigExceptionDeclaration.hs b/lib/Language/OCaml/Parser/SigExceptionDeclaration.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/SigExceptionDeclaration.hs @@ -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)) + , () + ) diff --git a/lib/Language/OCaml/Parser/SimpleCoreType.hs b/lib/Language/OCaml/Parser/SimpleCoreType.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/SimpleCoreType.hs @@ -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" + ] diff --git a/lib/Language/OCaml/Parser/SimpleCoreType2.hs b/lib/Language/OCaml/Parser/SimpleCoreType2.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/SimpleCoreType2.hs @@ -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] + ] diff --git a/lib/Language/OCaml/Parser/SimpleCoreTypeOrTuple.hs b/lib/Language/OCaml/Parser/SimpleCoreTypeOrTuple.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/SimpleCoreTypeOrTuple.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/SimpleDelimitedPattern.hs b/lib/Language/OCaml/Parser/SimpleDelimitedPattern.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/SimpleDelimitedPattern.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/SimpleExpr.hs b/lib/Language/OCaml/Parser/SimpleExpr.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/SimpleExpr.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/SimpleLabeledExprList.hs b/lib/Language/OCaml/Parser/SimpleLabeledExprList.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/SimpleLabeledExprList.hs @@ -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) diff --git a/lib/Language/OCaml/Parser/SimplePattern.hs b/lib/Language/OCaml/Parser/SimplePattern.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/SimplePattern.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/SimplePatternNotIdent.hs b/lib/Language/OCaml/Parser/SimplePatternNotIdent.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/SimplePatternNotIdent.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/SingleAttrId.hs b/lib/Language/OCaml/Parser/SingleAttrId.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/SingleAttrId.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/StrExceptionDeclaration.hs b/lib/Language/OCaml/Parser/StrExceptionDeclaration.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/StrExceptionDeclaration.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/StrictBinding.hs b/lib/Language/OCaml/Parser/StrictBinding.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/StrictBinding.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/Structure.hs b/lib/Language/OCaml/Parser/Structure.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/Structure.hs @@ -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 [] + ] diff --git a/lib/Language/OCaml/Parser/StructureItem.hs b/lib/Language/OCaml/Parser/StructureItem.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/StructureItem.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/Tokens.hs b/lib/Language/OCaml/Parser/Tokens.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/Tokens.hs @@ -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" diff --git a/lib/Language/OCaml/Parser/TypeConstraint.hs b/lib/Language/OCaml/Parser/TypeConstraint.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/TypeConstraint.hs @@ -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) + ] diff --git a/lib/Language/OCaml/Parser/TypeDeclaration.hs b/lib/Language/OCaml/Parser/TypeDeclaration.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/TypeDeclaration.hs @@ -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) diff --git a/lib/Language/OCaml/Parser/TypeDeclarations.hs b/lib/Language/OCaml/Parser/TypeDeclarations.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/TypeDeclarations.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/TypeKind.hs b/lib/Language/OCaml/Parser/TypeKind.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/TypeKind.hs @@ -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 diff --git a/lib/Language/OCaml/Parser/TypeLongident.hs b/lib/Language/OCaml/Parser/TypeLongident.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/TypeLongident.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/TypeVariable.hs b/lib/Language/OCaml/Parser/TypeVariable.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/TypeVariable.hs @@ -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) diff --git a/lib/Language/OCaml/Parser/TypeVariance.hs b/lib/Language/OCaml/Parser/TypeVariance.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/TypeVariance.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/Utils/Combinators.hs b/lib/Language/OCaml/Parser/Utils/Combinators.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/Utils/Combinators.hs @@ -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 ] diff --git a/lib/Language/OCaml/Parser/Utils/Types.hs b/lib/Language/OCaml/Parser/Utils/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/Utils/Types.hs @@ -0,0 +1,8 @@ +module Language.OCaml.Parser.Utils.Types + ( Parser + ) where + +import Data.Void +import Text.Megaparsec + +type Parser = Parsec Void String diff --git a/lib/Language/OCaml/Parser/Utils/Utils.hs b/lib/Language/OCaml/Parser/Utils/Utils.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/Utils/Utils.hs @@ -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" + ] diff --git a/lib/Language/OCaml/Parser/ValIdent.hs b/lib/Language/OCaml/Parser/ValIdent.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/ValIdent.hs @@ -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 + ] diff --git a/lib/Language/OCaml/Parser/ValLongident.hs b/lib/Language/OCaml/Parser/ValLongident.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Parser/ValLongident.hs @@ -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 + ] diff --git a/lib/Language/OCaml/PrettyPrinter.hs b/lib/Language/OCaml/PrettyPrinter.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter.hs @@ -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 () diff --git a/lib/Language/OCaml/PrettyPrinter/ArgLabel.hs b/lib/Language/OCaml/PrettyPrinter/ArgLabel.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/ArgLabel.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/Case.hs b/lib/Language/OCaml/PrettyPrinter/Case.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/Case.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/Constant.hs b/lib/Language/OCaml/PrettyPrinter/Constant.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/Constant.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/ConstructorArguments.hs b/lib/Language/OCaml/PrettyPrinter/ConstructorArguments.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/ConstructorArguments.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/ConstructorDeclaration.hs b/lib/Language/OCaml/PrettyPrinter/ConstructorDeclaration.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/ConstructorDeclaration.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/CoreType.hs b/lib/Language/OCaml/PrettyPrinter/CoreType.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/CoreType.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/CoreTypeDesc.hs b/lib/Language/OCaml/PrettyPrinter/CoreTypeDesc.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/CoreTypeDesc.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/Expression.hs b/lib/Language/OCaml/PrettyPrinter/Expression.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/Expression.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/ExpressionDesc.hs b/lib/Language/OCaml/PrettyPrinter/ExpressionDesc.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/ExpressionDesc.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/Internal.hs b/lib/Language/OCaml/PrettyPrinter/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/Internal.hs @@ -0,0 +1,6 @@ +module Language.OCaml.PrettyPrinter.Internal + ( structureItemPP + ) where + +import Language.OCaml.PrettyPrinter.Payload () +import Language.OCaml.PrettyPrinter.StructureItem diff --git a/lib/Language/OCaml/PrettyPrinter/LabelDeclaration.hs b/lib/Language/OCaml/PrettyPrinter/LabelDeclaration.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/LabelDeclaration.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/Loc.hs b/lib/Language/OCaml/PrettyPrinter/Loc.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/Loc.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/Longident.hs b/lib/Language/OCaml/PrettyPrinter/Longident.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/Longident.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/ModuleBinding.hs b/lib/Language/OCaml/PrettyPrinter/ModuleBinding.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/ModuleBinding.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/ModuleExpr.hs b/lib/Language/OCaml/PrettyPrinter/ModuleExpr.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/ModuleExpr.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/ModuleExprDesc.hs b/lib/Language/OCaml/PrettyPrinter/ModuleExprDesc.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/ModuleExprDesc.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/MutableFlag.hs b/lib/Language/OCaml/PrettyPrinter/MutableFlag.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/MutableFlag.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/OpenDescription.hs b/lib/Language/OCaml/PrettyPrinter/OpenDescription.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/OpenDescription.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/OverrideFlag.hs b/lib/Language/OCaml/PrettyPrinter/OverrideFlag.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/OverrideFlag.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/Pattern.hs b/lib/Language/OCaml/PrettyPrinter/Pattern.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/Pattern.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/PatternDesc.hs b/lib/Language/OCaml/PrettyPrinter/PatternDesc.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/PatternDesc.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/Payload.hs b/lib/Language/OCaml/PrettyPrinter/Payload.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/Payload.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/RecFlag.hs b/lib/Language/OCaml/PrettyPrinter/RecFlag.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/RecFlag.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/Structure.hs b/lib/Language/OCaml/PrettyPrinter/Structure.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/Structure.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/StructureItem.hs b/lib/Language/OCaml/PrettyPrinter/StructureItem.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/StructureItem.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/StructureItemDesc.hs b/lib/Language/OCaml/PrettyPrinter/StructureItemDesc.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/StructureItemDesc.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/TypeDeclaration.hs b/lib/Language/OCaml/PrettyPrinter/TypeDeclaration.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/TypeDeclaration.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/ValueBinding.hs b/lib/Language/OCaml/PrettyPrinter/ValueBinding.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/ValueBinding.hs @@ -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 diff --git a/lib/Language/OCaml/PrettyPrinter/Variance.hs b/lib/Language/OCaml/PrettyPrinter/Variance.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/PrettyPrinter/Variance.hs @@ -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 diff --git a/lib/Language/OCaml/Utils.hs b/lib/Language/OCaml/Utils.hs new file mode 100644 --- /dev/null +++ b/lib/Language/OCaml/Utils.hs @@ -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 diff --git a/test/Language/OCaml/Parser/AndLetBinding/Test.hs b/test/Language/OCaml/Parser/AndLetBinding/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/AndLetBinding/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/AttrId/Test.hs b/test/Language/OCaml/Parser/AttrId/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/AttrId/Test.hs @@ -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 + ] diff --git a/test/Language/OCaml/Parser/Attribute/Test.hs b/test/Language/OCaml/Parser/Attribute/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/Attribute/Test.hs @@ -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 + ] diff --git a/test/Language/OCaml/Parser/Attributes/Test.hs b/test/Language/OCaml/Parser/Attributes/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/Attributes/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/Common/Test.hs b/test/Language/OCaml/Parser/Common/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/Common/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/Constant/Test.hs b/test/Language/OCaml/Parser/Constant/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/Constant/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/ConstrLongident/Test.hs b/test/Language/OCaml/Parser/ConstrLongident/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/ConstrLongident/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/Expr/Test.hs b/test/Language/OCaml/Parser/Expr/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/Expr/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/ExtAttributes/Test.hs b/test/Language/OCaml/Parser/ExtAttributes/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/ExtAttributes/Test.hs @@ -0,0 +1,9 @@ +module Language.OCaml.Parser.ExtAttributes.Test + ( testStrings + ) where + +testStrings :: [String] +testStrings = [] + ++ [ "" ] + -- TODO: Attribute Attributes + -- TODO: % AttrId Attributes diff --git a/test/Language/OCaml/Parser/Generator/Expr/Test.hs b/test/Language/OCaml/Parser/Generator/Expr/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/Generator/Expr/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/Generator/Implementation/Test.hs b/test/Language/OCaml/Parser/Generator/Implementation/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/Generator/Implementation/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/Generator/SeqExpr/Test.hs b/test/Language/OCaml/Parser/Generator/SeqExpr/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/Generator/SeqExpr/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/Generator/SimpleExpr/Test.hs b/test/Language/OCaml/Parser/Generator/SimpleExpr/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/Generator/SimpleExpr/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/Generator/ValLongident/Test.hs b/test/Language/OCaml/Parser/Generator/ValLongident/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/Generator/ValLongident/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/Implementation/Test.hs b/test/Language/OCaml/Parser/Implementation/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/Implementation/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/Int/Test.hs b/test/Language/OCaml/Parser/Int/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/Int/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/LetBinding/Test.hs b/test/Language/OCaml/Parser/LetBinding/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/LetBinding/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/LetBindingBody/Test.hs b/test/Language/OCaml/Parser/LetBindingBody/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/LetBindingBody/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/LetBindings/Test.hs b/test/Language/OCaml/Parser/LetBindings/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/LetBindings/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/MatchCase/Test.hs b/test/Language/OCaml/Parser/MatchCase/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/MatchCase/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/ModLongident/Test.hs b/test/Language/OCaml/Parser/ModLongident/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/ModLongident/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/OpenStatement/Test.hs b/test/Language/OCaml/Parser/OpenStatement/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/OpenStatement/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/Operator/Test.hs b/test/Language/OCaml/Parser/Operator/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/Operator/Test.hs @@ -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 + ] diff --git a/test/Language/OCaml/Parser/Pattern/Test.hs b/test/Language/OCaml/Parser/Pattern/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/Pattern/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/Payload/Test.hs b/test/Language/OCaml/Parser/Payload/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/Payload/Test.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Language.OCaml.Parser.Payload.Test + ( testStrings + ) where + +-- import Data.String.Interpolate + +testStrings :: [String] -> [String] +testStrings structure = [] + ++ structure diff --git a/test/Language/OCaml/Parser/PostItemAttribute/Test.hs b/test/Language/OCaml/Parser/PostItemAttribute/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/PostItemAttribute/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/PostItemAttributes/Test.hs b/test/Language/OCaml/Parser/PostItemAttributes/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/PostItemAttributes/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/RecFlag/Test.hs b/test/Language/OCaml/Parser/RecFlag/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/RecFlag/Test.hs @@ -0,0 +1,6 @@ +module Language.OCaml.Parser.RecFlag.Test + ( testStrings + ) where + +testStrings :: [String] +testStrings = [ "", "rec" ] diff --git a/test/Language/OCaml/Parser/SeqExpr/Test.hs b/test/Language/OCaml/Parser/SeqExpr/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/SeqExpr/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/SimpleExpr/Test.hs b/test/Language/OCaml/Parser/SimpleExpr/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/SimpleExpr/Test.hs @@ -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 + ] diff --git a/test/Language/OCaml/Parser/SimplePattern/Test.hs b/test/Language/OCaml/Parser/SimplePattern/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/SimplePattern/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/SingleAttrId/Test.hs b/test/Language/OCaml/Parser/SingleAttrId/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/SingleAttrId/Test.hs @@ -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" + ] diff --git a/test/Language/OCaml/Parser/StrictBinding/Test.hs b/test/Language/OCaml/Parser/StrictBinding/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/StrictBinding/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/Structure/Test.hs b/test/Language/OCaml/Parser/Structure/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/Structure/Test.hs @@ -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) diff --git a/test/Language/OCaml/Parser/StructureItem/Test.hs b/test/Language/OCaml/Parser/StructureItem/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/StructureItem/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/StructureTail/Test.hs b/test/Language/OCaml/Parser/StructureTail/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/StructureTail/Test.hs @@ -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 diff --git a/test/Language/OCaml/Parser/TestStrings.hs b/test/Language/OCaml/Parser/TestStrings.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/TestStrings.hs @@ -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 diff --git a/test/Language/OCaml/Parser/TestUtils.hs b/test/Language/OCaml/Parser/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/TestUtils.hs @@ -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" diff --git a/test/Language/OCaml/Parser/Tokens/Test.hs b/test/Language/OCaml/Parser/Tokens/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/Tokens/Test.hs @@ -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"|] diff --git a/test/Language/OCaml/Parser/ValIdent/Test.hs b/test/Language/OCaml/Parser/ValIdent/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/ValIdent/Test.hs @@ -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 ] diff --git a/test/Language/OCaml/Parser/ValLongident/Test.hs b/test/Language/OCaml/Parser/ValLongident/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/Parser/ValLongident/Test.hs @@ -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 + ] diff --git a/test/Language/OCaml/PrettyPrinter/Structure/Test.hs b/test/Language/OCaml/PrettyPrinter/Structure/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/PrettyPrinter/Structure/Test.hs @@ -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) diff --git a/test/Language/OCaml/PrettyPrinter/StructureItem/Test.hs b/test/Language/OCaml/PrettyPrinter/StructureItem/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/PrettyPrinter/StructureItem/Test.hs @@ -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) diff --git a/test/Language/OCaml/PrettyPrinter/TestUtils.hs b/test/Language/OCaml/PrettyPrinter/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/Language/OCaml/PrettyPrinter/TestUtils.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ] + ]