From 791ce64726a480440ea64584189e21136a6d665b Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Sat, 6 Jul 2024 16:46:34 +0200 Subject: [PATCH] Add a parse command to benchmark the cst parser --- app/Command/Compile.hs | 94 ++++++++++++++++++++++++++- app/Main.hs | 3 + src/Language/PureScript/CST/Types.hs | 96 ++++++++++++++++++++++++++++ 3 files changed, 190 insertions(+), 3 deletions(-) diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index d81dd75c07..432c90a13e 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -1,4 +1,5 @@ -module Command.Compile (command) where +{-# LANGUAGE NumericUnderscores #-} +module Command.Compile (command, parseCommand) where import Prelude @@ -7,11 +8,13 @@ import Control.Monad (when) import Data.Aeson qualified as A import Data.Bool (bool) import Data.ByteString.Lazy.UTF8 qualified as LBU8 -import Data.List (intercalate) +import Data.List qualified as List import Data.Map qualified as M import Data.Set qualified as S +import Data.Ord (comparing) import Data.Text qualified as T import Data.Traversable (for) +import Language.PureScript.CST.Parser qualified as CST.Parser import Language.PureScript qualified as P import Language.PureScript.CST qualified as CST import Language.PureScript.Errors.JSON (JSONResult(..), toJSONErrors) @@ -24,6 +27,11 @@ import System.Exit (exitSuccess, exitFailure) import System.Directory (getCurrentDirectory) import System.IO (hPutStr, stderr, stdout) import System.IO.UTF8 (readUTF8FilesT) +import System.CPUTime (getCPUTime) +import Text.Printf (printf) +import Control.Exception (evaluate) +import Control.Monad (void) +import Control.DeepSeq (rnf) data PSCMakeOptions = PSCMakeOptions { pscmInput :: [FilePath] @@ -120,7 +128,7 @@ codegenTargets = Opts.option targetParser $ ) targetsMessage :: String -targetsMessage = "Accepted codegen targets are '" <> intercalate "', '" (M.keys P.codegenTargets) <> "'." +targetsMessage = "Accepted codegen targets are '" <> List.intercalate "', '" (M.keys P.codegenTargets) <> "'." targetParser :: Opts.ReadM [P.CodegenTarget] targetParser = @@ -153,3 +161,83 @@ pscMakeOptions = PSCMakeOptions <$> many SharedCLI.inputFile command :: Opts.Parser (IO ()) command = compile <$> (Opts.helper <*> pscMakeOptions) + +parseCommand :: Opts.Parser (IO ()) +parseCommand = parse <$> (Opts.helper <*> pscMakeOptions) + +parse :: PSCMakeOptions -> IO () +parse PSCMakeOptions{..} = do + input <- toInputGlobs $ PSCGlobs + { pscInputGlobs = pscmInput + , pscInputGlobsFromFile = pscmInputFromFile + , pscExcludeGlobs = pscmExclude + , pscWarnFileTypeNotFound = warnFileTypeNotFound "compile" + } + when (null input) $ do + hPutStr stderr $ unlines + [ "purs compile: No input files." + , "Usage: For basic information, try the `--help' option." + ] + exitFailure + modules <- readUTF8FilesT input + -- (makeErrors, makeWarnings) <- runMake pscmOpts $ do + durationStats <- for modules $ \(fp, content) -> do + start <- getCPUTime + void $ do + x <- evaluate $ CST.Parser.parse content + rnf x `seq` return () + end <- getCPUTime + let ms = (fromIntegral (end - start)) / (1_000_000_000 :: Double) + pure $ DurationStat ms fp + let stats = getDurationStats durationStats + putStrLn $ displayDurationStats stats "Parse" + + exitSuccess + +data DurationStat = DurationStat + { duration :: !Double + , file :: !FilePath + -- , result :: !(Either (NE.NonEmpty ParserError) (CST.Module ())) + } + +data DurationStats = DurationStats + { minDuration :: ![DurationStat] + , maxDuration :: ![DurationStat] + , mean :: !Double + } + +getDurationStats :: [DurationStat] -> DurationStats +getDurationStats res = DurationStats + { minDuration = List.take 20 sorted + , maxDuration = List.reverse (takeEnd 20 sorted) + , mean = mean $ map duration sorted + } + where + sorted = List.sortBy (comparing duration) res + + mean :: [Double] -> Double + mean xs = (sum xs) / fromIntegral (length xs) + +displayDurationStats :: DurationStats -> String -> String +displayDurationStats (DurationStats { minDuration, maxDuration, mean }) title = + List.intercalate "\n" + [ "" + , "---- [ " <> title <> " Timing Information ] ----" + , "Fastest Parse Times:" + , List.intercalate "\n" $ displayLine <$> minDuration + , "" + , "Slowest Parse Times:" + , List.intercalate "\n" $ displayLine <$> maxDuration + , "" + , "Mean Parse: " <> formatMs mean + ] + + where + displayLine (DurationStat{ file, duration }) = + takeEnd 12 (" " <> formatMs duration) <> " " <> file -- <> " " <> (either (const "0") (const " ") result) + + formatMs :: Double -> String + formatMs = printf "%.3f ms" + +takeEnd :: Int -> [a] -> [a] +takeEnd n xs = List.foldl' (const . drop 1) xs (drop n xs) diff --git a/app/Main.hs b/app/Main.hs index c925a4a313..dbeb80edbf 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -64,6 +64,9 @@ main = do , Opts.command "compile" (Opts.info Compile.command (Opts.progDesc "Compile PureScript source files")) + , Opts.command "parse" + (Opts.info Compile.parseCommand + (Opts.progDesc "Parse PureScript source files and output timing information")) , Opts.command "docs" (Opts.info Docs.command (Opts.progDesc "Generate documentation from PureScript source files in a variety of formats, including Markdown and HTML" <> Docs.infoModList)) diff --git a/src/Language/PureScript/CST/Types.hs b/src/Language/PureScript/CST/Types.hs index ba90f7e95b..2a34cc5419 100644 --- a/src/Language/PureScript/CST/Types.hs +++ b/src/Language/PureScript/CST/Types.hs @@ -92,39 +92,53 @@ data Ident = Ident { getIdent :: Text } deriving (Show, Eq, Ord, Generic) +instance NFData Ident + data Name a = Name { nameTok :: SourceToken , nameValue :: a } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (Name a) + data QualifiedName a = QualifiedName { qualTok :: SourceToken , qualModule :: Maybe N.ModuleName , qualName :: a } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (QualifiedName a) + data Label = Label { lblTok :: SourceToken , lblName :: PSString } deriving (Show, Eq, Ord, Generic) +instance NFData Label + data Wrapped a = Wrapped { wrpOpen :: SourceToken , wrpValue :: a , wrpClose :: SourceToken } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (Wrapped a) + data Separated a = Separated { sepHead :: a , sepTail :: [(SourceToken, a)] } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (Separated a) + data Labeled a b = Labeled { lblLabel :: a , lblSep :: SourceToken , lblValue :: b } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance (NFData a, NFData b) => NFData (Labeled a b) + type Delimited a = Wrapped (Maybe (Separated a)) type DelimitedNonEmpty a = Wrapped (Separated a) @@ -133,6 +147,8 @@ data OneOrDelimited a | Many (DelimitedNonEmpty a) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (OneOrDelimited a) + data Type a = TypeVar a (Name Ident) | TypeConstructor a (QualifiedName (N.ProperName 'N.TypeName)) @@ -154,21 +170,29 @@ data Type a | TypeUnaryRow a SourceToken (Type a) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (Type a) + data TypeVarBinding a = TypeVarKinded (Wrapped (Labeled (Maybe SourceToken, Name Ident) (Type a))) | TypeVarName (Maybe SourceToken, Name Ident) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (TypeVarBinding a) + data Constraint a = Constraint a (QualifiedName (N.ProperName 'N.ClassName)) [Type a] | ConstraintParens a (Wrapped (Constraint a)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (Constraint a) + data Row a = Row { rowLabels :: Maybe (Separated (Labeled Label (Type a))) , rowTail :: Maybe (SourceToken, Type a) } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (Row a) + data Module a = Module { modAnn :: a , modKeyword :: SourceToken @@ -180,6 +204,8 @@ data Module a = Module , modTrailingComments :: [Comment LineFeed] } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (Module a) + data Export a = ExportValue a (Name Ident) | ExportOp a (Name (N.OpName 'N.ValueOpName)) @@ -189,11 +215,15 @@ data Export a | ExportModule a SourceToken (Name N.ModuleName) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (Export a) + data DataMembers a = DataAll a SourceToken | DataEnumerated a (Delimited (Name (N.ProperName 'N.ConstructorName))) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (DataMembers a) + data Declaration a = DeclData a (DataHead a) (Maybe (SourceToken, Separated (DataCtor a))) | DeclType a (DataHead a) SourceToken (Type a) @@ -209,16 +239,22 @@ data Declaration a | DeclRole a SourceToken SourceToken (Name (N.ProperName 'N.TypeName)) (NonEmpty Role) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (Declaration a) + data Instance a = Instance { instHead :: InstanceHead a , instBody :: Maybe (SourceToken, NonEmpty (InstanceBinding a)) } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (Instance a) + data InstanceBinding a = InstanceBindingSignature a (Labeled (Name Ident) (Type a)) | InstanceBindingName a (ValueBindingFields a) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (InstanceBinding a) + data ImportDecl a = ImportDecl { impAnn :: a , impKeyword :: SourceToken @@ -227,6 +263,8 @@ data ImportDecl a = ImportDecl , impQual :: Maybe (SourceToken, Name N.ModuleName) } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (ImportDecl a) + data Import a = ImportValue a (Name Ident) | ImportOp a (Name (N.OpName 'N.ValueOpName)) @@ -235,18 +273,24 @@ data Import a | ImportClass a SourceToken (Name (N.ProperName 'N.ClassName)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (Import a) + data DataHead a = DataHead { dataHdKeyword :: SourceToken , dataHdName :: Name (N.ProperName 'N.TypeName) , dataHdVars :: [TypeVarBinding a] } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (DataHead a) + data DataCtor a = DataCtor { dataCtorAnn :: a , dataCtorName :: Name (N.ProperName 'N.ConstructorName) , dataCtorFields :: [Type a] } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (DataCtor a) + data ClassHead a = ClassHead { clsKeyword :: SourceToken , clsSuper :: Maybe (OneOrDelimited (Constraint a), SourceToken) @@ -255,11 +299,15 @@ data ClassHead a = ClassHead , clsFundeps :: Maybe (SourceToken, Separated ClassFundep) } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (ClassHead a) + data ClassFundep = FundepDetermined SourceToken (NonEmpty (Name Ident)) | FundepDetermines (NonEmpty (Name Ident)) SourceToken (NonEmpty (Name Ident)) deriving (Show, Eq, Ord, Generic) +instance NFData ClassFundep + data InstanceHead a = InstanceHead { instKeyword :: SourceToken , instNameSep :: Maybe (Name Ident, SourceToken) @@ -268,34 +316,46 @@ data InstanceHead a = InstanceHead , instTypes :: [Type a] } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (InstanceHead a) + data Fixity = Infix | Infixl | Infixr deriving (Show, Eq, Ord, Generic) +instance NFData Fixity + data FixityOp = FixityValue (QualifiedName (Either Ident (N.ProperName 'N.ConstructorName))) SourceToken (Name (N.OpName 'N.ValueOpName)) | FixityType SourceToken (QualifiedName (N.ProperName 'N.TypeName)) SourceToken (Name (N.OpName 'N.TypeOpName)) deriving (Show, Eq, Ord, Generic) +instance NFData FixityOp + data FixityFields = FixityFields { fxtKeyword :: (SourceToken, Fixity) , fxtPrec :: (SourceToken, Integer) , fxtOp :: FixityOp } deriving (Show, Eq, Ord, Generic) +instance NFData FixityFields + data ValueBindingFields a = ValueBindingFields { valName :: Name Ident , valBinders :: [Binder a] , valGuarded :: Guarded a } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (ValueBindingFields a) + data Guarded a = Unconditional SourceToken (Where a) | Guarded (NonEmpty (GuardedExpr a)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (Guarded a) + data GuardedExpr a = GuardedExpr { grdBar :: SourceToken , grdPatterns :: Separated (PatternGuard a) @@ -303,22 +363,30 @@ data GuardedExpr a = GuardedExpr , grdWhere :: Where a } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (GuardedExpr a) + data PatternGuard a = PatternGuard { patBinder :: Maybe (Binder a, SourceToken) , patExpr :: Expr a } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (PatternGuard a) + data Foreign a = ForeignValue (Labeled (Name Ident) (Type a)) | ForeignData SourceToken (Labeled (Name (N.ProperName 'N.TypeName)) (Type a)) | ForeignKind SourceToken (Name (N.ProperName 'N.TypeName)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (Foreign a) + data Role = Role { roleTok :: SourceToken , roleValue :: R.Role } deriving (Show, Eq, Ord, Generic) +instance NFData Role + data Expr a = ExprHole a (Name Ident) | ExprSection a SourceToken @@ -348,22 +416,30 @@ data Expr a | ExprAdo a (AdoBlock a) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (Expr a) + data RecordLabeled a = RecordPun (Name Ident) | RecordField Label SourceToken a deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (RecordLabeled a) + data RecordUpdate a = RecordUpdateLeaf Label SourceToken (Expr a) | RecordUpdateBranch Label (DelimitedNonEmpty (RecordUpdate a)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (RecordUpdate a) + data RecordAccessor a = RecordAccessor { recExpr :: Expr a , recDot :: SourceToken , recPath :: Separated Label } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (RecordAccessor a) + data Lambda a = Lambda { lmbSymbol :: SourceToken , lmbBinders :: NonEmpty (Binder a) @@ -371,6 +447,8 @@ data Lambda a = Lambda , lmbBody :: Expr a } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (Lambda a) + data IfThenElse a = IfThenElse { iteIf :: SourceToken , iteCond :: Expr a @@ -380,6 +458,8 @@ data IfThenElse a = IfThenElse , iteFalse :: Expr a } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (IfThenElse a) + data CaseOf a = CaseOf { caseKeyword :: SourceToken , caseHead :: Separated (Expr a) @@ -387,6 +467,8 @@ data CaseOf a = CaseOf , caseBranches :: NonEmpty (Separated (Binder a), Guarded a) } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (CaseOf a) + data LetIn a = LetIn { letKeyword :: SourceToken , letBindings :: NonEmpty (LetBinding a) @@ -394,28 +476,38 @@ data LetIn a = LetIn , letBody :: Expr a } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (LetIn a) + data Where a = Where { whereExpr :: Expr a , whereBindings :: Maybe (SourceToken, NonEmpty (LetBinding a)) } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (Where a) + data LetBinding a = LetBindingSignature a (Labeled (Name Ident) (Type a)) | LetBindingName a (ValueBindingFields a) | LetBindingPattern a (Binder a) SourceToken (Where a) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (LetBinding a) + data DoBlock a = DoBlock { doKeyword :: SourceToken , doStatements :: NonEmpty (DoStatement a) } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (DoBlock a) + data DoStatement a = DoLet SourceToken (NonEmpty (LetBinding a)) | DoDiscard (Expr a) | DoBind (Binder a) SourceToken (Expr a) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (DoStatement a) + data AdoBlock a = AdoBlock { adoKeyword :: SourceToken , adoStatements :: [DoStatement a] @@ -423,6 +515,8 @@ data AdoBlock a = AdoBlock , adoResult :: Expr a } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +instance NFData a => NFData (AdoBlock a) + data Binder a = BinderWildcard a SourceToken | BinderVar a (Name Ident) @@ -438,3 +532,5 @@ data Binder a | BinderTyped a (Binder a) SourceToken (Type a) | BinderOp a (Binder a) (QualifiedName (N.OpName 'N.ValueOpName)) (Binder a) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +instance NFData a => NFData (Binder a)