nyan-interpolation-core (empty) → 0.9
raw patch · 22 files changed
+2281/−0 lines, 22 filesdep +HUnitdep +basedep +doctest-parallel
Dependencies added: HUnit, base, doctest-parallel, fmt, megaparsec, mtl, nyan-interpolation-core, process, tasty, tasty-hunit-compat, template-haskell, text, vector
Files
- CHANGES.md +9/−0
- LICENSE +373/−0
- app/Main.hs +24/−0
- nyan-interpolation-core.cabal +118/−0
- src/Text/Interpolation/Nyan/Core.hs +119/−0
- src/Text/Interpolation/Nyan/Core/Internal/Base.hs +177/−0
- src/Text/Interpolation/Nyan/Core/Internal/Parser.hs +348/−0
- src/Text/Interpolation/Nyan/Core/Internal/Processor.hs +122/−0
- src/Text/Interpolation/Nyan/Core/Internal/RMode.hs +33/−0
- src/Text/Interpolation/Nyan/Core/Internal/Splice.hs +184/−0
- src/Text/Interpolation/Nyan/RModes/Buildable.hs +23/−0
- src/Text/Interpolation/Nyan/RModes/CommonExtra.hs +32/−0
- src/Text/Interpolation/Nyan/RModes/Show.hs +15/−0
- tests/Main.hs +14/−0
- tests/Test/Customization.hs +41/−0
- tests/Test/Interpolator.hs +314/−0
- tests/Test/Parser.hs +139/−0
- tests/Test/Processor.hs +33/−0
- tests/Test/Util.hs +100/−0
- tests/Test/ValueInterpolators.hs +51/−0
- tests/Tree.hs +5/−0
- tests/doctests.hs +7/−0
+ CHANGES.md view
@@ -0,0 +1,9 @@+<!--+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>+--+-- SPDX-License-Identifier: MPL-2.0+-->++# 0.1++Initial version.
+ LICENSE view
@@ -0,0 +1,373 @@+Mozilla Public License Version 2.0+==================================++1. Definitions+--------------++1.1. "Contributor"+ means each individual or legal entity that creates, contributes to+ the creation of, or owns Covered Software.++1.2. "Contributor Version"+ means the combination of the Contributions of others (if any) used+ by a Contributor and that particular Contributor's Contribution.++1.3. "Contribution"+ means Covered Software of a particular Contributor.++1.4. "Covered Software"+ means Source Code Form to which the initial Contributor has attached+ the notice in Exhibit A, the Executable Form of such Source Code+ Form, and Modifications of such Source Code Form, in each case+ including portions thereof.++1.5. "Incompatible With Secondary Licenses"+ means++ (a) that the initial Contributor has attached the notice described+ in Exhibit B to the Covered Software; or++ (b) that the Covered Software was made available under the terms of+ version 1.1 or earlier of the License, but not also under the+ terms of a Secondary License.++1.6. "Executable Form"+ means any form of the work other than Source Code Form.++1.7. "Larger Work"+ means a work that combines Covered Software with other material, in+ a separate file or files, that is not Covered Software.++1.8. "License"+ means this document.++1.9. "Licensable"+ means having the right to grant, to the maximum extent possible,+ whether at the time of the initial grant or subsequently, any and+ all of the rights conveyed by this License.++1.10. "Modifications"+ means any of the following:++ (a) any file in Source Code Form that results from an addition to,+ deletion from, or modification of the contents of Covered+ Software; or++ (b) any new file in Source Code Form that contains any Covered+ Software.++1.11. "Patent Claims" of a Contributor+ means any patent claim(s), including without limitation, method,+ process, and apparatus claims, in any patent Licensable by such+ Contributor that would be infringed, but for the grant of the+ License, by the making, using, selling, offering for sale, having+ made, import, or transfer of either its Contributions or its+ Contributor Version.++1.12. "Secondary License"+ means either the GNU General Public License, Version 2.0, the GNU+ Lesser General Public License, Version 2.1, the GNU Affero General+ Public License, Version 3.0, or any later versions of those+ licenses.++1.13. "Source Code Form"+ means the form of the work preferred for making modifications.++1.14. "You" (or "Your")+ means an individual or a legal entity exercising rights under this+ License. For legal entities, "You" includes any entity that+ controls, is controlled by, or is under common control with You. For+ purposes of this definition, "control" means (a) the power, direct+ or indirect, to cause the direction or management of such entity,+ whether by contract or otherwise, or (b) ownership of more than+ fifty percent (50%) of the outstanding shares or beneficial+ ownership of such entity.++2. License Grants and Conditions+--------------------------------++2.1. Grants++Each Contributor hereby grants You a world-wide, royalty-free,+non-exclusive license:++(a) under intellectual property rights (other than patent or trademark)+ Licensable by such Contributor to use, reproduce, make available,+ modify, display, perform, distribute, and otherwise exploit its+ Contributions, either on an unmodified basis, with Modifications, or+ as part of a Larger Work; and++(b) under Patent Claims of such Contributor to make, use, sell, offer+ for sale, have made, import, and otherwise transfer either its+ Contributions or its Contributor Version.++2.2. Effective Date++The licenses granted in Section 2.1 with respect to any Contribution+become effective for each Contribution on the date the Contributor first+distributes such Contribution.++2.3. Limitations on Grant Scope++The licenses granted in this Section 2 are the only rights granted under+this License. No additional rights or licenses will be implied from the+distribution or licensing of Covered Software under this License.+Notwithstanding Section 2.1(b) above, no patent license is granted by a+Contributor:++(a) for any code that a Contributor has removed from Covered Software;+ or++(b) for infringements caused by: (i) Your and any other third party's+ modifications of Covered Software, or (ii) the combination of its+ Contributions with other software (except as part of its Contributor+ Version); or++(c) under Patent Claims infringed by Covered Software in the absence of+ its Contributions.++This License does not grant any rights in the trademarks, service marks,+or logos of any Contributor (except as may be necessary to comply with+the notice requirements in Section 3.4).++2.4. Subsequent Licenses++No Contributor makes additional grants as a result of Your choice to+distribute the Covered Software under a subsequent version of this+License (see Section 10.2) or under the terms of a Secondary License (if+permitted under the terms of Section 3.3).++2.5. Representation++Each Contributor represents that the Contributor believes its+Contributions are its original creation(s) or it has sufficient rights+to grant the rights to its Contributions conveyed by this License.++2.6. Fair Use++This License is not intended to limit any rights You have under+applicable copyright doctrines of fair use, fair dealing, or other+equivalents.++2.7. Conditions++Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted+in Section 2.1.++3. Responsibilities+-------------------++3.1. Distribution of Source Form++All distribution of Covered Software in Source Code Form, including any+Modifications that You create or to which You contribute, must be under+the terms of this License. You must inform recipients that the Source+Code Form of the Covered Software is governed by the terms of this+License, and how they can obtain a copy of this License. You may not+attempt to alter or restrict the recipients' rights in the Source Code+Form.++3.2. Distribution of Executable Form++If You distribute Covered Software in Executable Form then:++(a) such Covered Software must also be made available in Source Code+ Form, as described in Section 3.1, and You must inform recipients of+ the Executable Form how they can obtain a copy of such Source Code+ Form by reasonable means in a timely manner, at a charge no more+ than the cost of distribution to the recipient; and++(b) You may distribute such Executable Form under the terms of this+ License, or sublicense it under different terms, provided that the+ license for the Executable Form does not attempt to limit or alter+ the recipients' rights in the Source Code Form under this License.++3.3. Distribution of a Larger Work++You may create and distribute a Larger Work under terms of Your choice,+provided that You also comply with the requirements of this License for+the Covered Software. If the Larger Work is a combination of Covered+Software with a work governed by one or more Secondary Licenses, and the+Covered Software is not Incompatible With Secondary Licenses, this+License permits You to additionally distribute such Covered Software+under the terms of such Secondary License(s), so that the recipient of+the Larger Work may, at their option, further distribute the Covered+Software under the terms of either this License or such Secondary+License(s).++3.4. Notices++You may not remove or alter the substance of any license notices+(including copyright notices, patent notices, disclaimers of warranty,+or limitations of liability) contained within the Source Code Form of+the Covered Software, except that You may alter any license notices to+the extent required to remedy known factual inaccuracies.++3.5. Application of Additional Terms++You may choose to offer, and to charge a fee for, warranty, support,+indemnity or liability obligations to one or more recipients of Covered+Software. However, You may do so only on Your own behalf, and not on+behalf of any Contributor. You must make it absolutely clear that any+such warranty, support, indemnity, or liability obligation is offered by+You alone, and You hereby agree to indemnify every Contributor for any+liability incurred by such Contributor as a result of warranty, support,+indemnity or liability terms You offer. You may include additional+disclaimers of warranty and limitations of liability specific to any+jurisdiction.++4. Inability to Comply Due to Statute or Regulation+---------------------------------------------------++If it is impossible for You to comply with any of the terms of this+License with respect to some or all of the Covered Software due to+statute, judicial order, or regulation then You must: (a) comply with+the terms of this License to the maximum extent possible; and (b)+describe the limitations and the code they affect. Such description must+be placed in a text file included with all distributions of the Covered+Software under this License. Except to the extent prohibited by statute+or regulation, such description must be sufficiently detailed for a+recipient of ordinary skill to be able to understand it.++5. Termination+--------------++5.1. The rights granted under this License will terminate automatically+if You fail to comply with any of its terms. However, if You become+compliant, then the rights granted under this License from a particular+Contributor are reinstated (a) provisionally, unless and until such+Contributor explicitly and finally terminates Your grants, and (b) on an+ongoing basis, if such Contributor fails to notify You of the+non-compliance by some reasonable means prior to 60 days after You have+come back into compliance. Moreover, Your grants from a particular+Contributor are reinstated on an ongoing basis if such Contributor+notifies You of the non-compliance by some reasonable means, this is the+first time You have received notice of non-compliance with this License+from such Contributor, and You become compliant prior to 30 days after+Your receipt of the notice.++5.2. If You initiate litigation against any entity by asserting a patent+infringement claim (excluding declaratory judgment actions,+counter-claims, and cross-claims) alleging that a Contributor Version+directly or indirectly infringes any patent, then the rights granted to+You by any and all Contributors for the Covered Software under Section+2.1 of this License shall terminate.++5.3. In the event of termination under Sections 5.1 or 5.2 above, all+end user license agreements (excluding distributors and resellers) which+have been validly granted by You or Your distributors under this License+prior to termination shall survive termination.++************************************************************************+* *+* 6. Disclaimer of Warranty *+* ------------------------- *+* *+* Covered Software is provided under this License on an "as is" *+* basis, without warranty of any kind, either expressed, implied, or *+* statutory, including, without limitation, warranties that the *+* Covered Software is free of defects, merchantable, fit for a *+* particular purpose or non-infringing. The entire risk as to the *+* quality and performance of the Covered Software is with You. *+* Should any Covered Software prove defective in any respect, You *+* (not any Contributor) assume the cost of any necessary servicing, *+* repair, or correction. This disclaimer of warranty constitutes an *+* essential part of this License. No use of any Covered Software is *+* authorized under this License except under this disclaimer. *+* *+************************************************************************++************************************************************************+* *+* 7. Limitation of Liability *+* -------------------------- *+* *+* Under no circumstances and under no legal theory, whether tort *+* (including negligence), contract, or otherwise, shall any *+* Contributor, or anyone who distributes Covered Software as *+* permitted above, be liable to You for any direct, indirect, *+* special, incidental, or consequential damages of any character *+* including, without limitation, damages for lost profits, loss of *+* goodwill, work stoppage, computer failure or malfunction, or any *+* and all other commercial damages or losses, even if such party *+* shall have been informed of the possibility of such damages. This *+* limitation of liability shall not apply to liability for death or *+* personal injury resulting from such party's negligence to the *+* extent applicable law prohibits such limitation. Some *+* jurisdictions do not allow the exclusion or limitation of *+* incidental or consequential damages, so this exclusion and *+* limitation may not apply to You. *+* *+************************************************************************++8. Litigation+-------------++Any litigation relating to this License may be brought only in the+courts of a jurisdiction where the defendant maintains its principal+place of business and such litigation shall be governed by laws of that+jurisdiction, without reference to its conflict-of-law provisions.+Nothing in this Section shall prevent a party's ability to bring+cross-claims or counter-claims.++9. Miscellaneous+----------------++This License represents the complete agreement concerning the subject+matter hereof. If any provision of this License is held to be+unenforceable, such provision shall be reformed only to the extent+necessary to make it enforceable. Any law or regulation which provides+that the language of a contract shall be construed against the drafter+shall not be used to construe this License against a Contributor.++10. Versions of the License+---------------------------++10.1. New Versions++Mozilla Foundation is the license steward. Except as provided in Section+10.3, no one other than the license steward has the right to modify or+publish new versions of this License. Each version will be given a+distinguishing version number.++10.2. Effect of New Versions++You may distribute the Covered Software under the terms of the version+of the License under which You originally received the Covered Software,+or under the terms of any subsequent version published by the license+steward.++10.3. Modified Versions++If you create software not governed by this License, and you want to+create a new license for such software, you may create and use a+modified version of this License if you rename the license and remove+any references to the name of the license steward (except to note that+such modified license differs from this License).++10.4. Distributing Source Code Form that is Incompatible With Secondary+Licenses++If You choose to distribute Source Code Form that is Incompatible With+Secondary Licenses under the terms of this version of the License, the+notice described in Exhibit B of this License must be attached.++Exhibit A - Source Code Form License Notice+-------------------------------------------++ This Source Code Form is subject to the terms of the Mozilla Public+ License, v. 2.0. If a copy of the MPL was not distributed with this+ file, You can obtain one at http://mozilla.org/MPL/2.0/.++If it is not possible or desirable to put the notice in a particular+file, then You may include the notice in a location (such as a LICENSE+file in a relevant directory) where a recipient would be likely to look+for such a notice.++You may add additional accurate notices of copyright ownership.++Exhibit B - "Incompatible With Secondary Licenses" Notice+---------------------------------------------------------++ This Source Code Form is "Incompatible With Secondary Licenses", as+ defined by the Mozilla Public License, v. 2.0.
+ app/Main.hs view
@@ -0,0 +1,24 @@+import Control.Concurrent+import qualified Data.Text as T+import GHC.IO.Handle+import System.Process++getFileContent :: IO T.Text+getFileContent = withCreateProcess (proc "cat" ["very-big-file.txt"]){ std_out = CreatePipe }+ \_mStdin mStdout _mStderr phandler ->+ case mStdout of+ Nothing -> error "No handler"+ Just stdout -> do+ putStrLn "Connected, getting"+ !output <- T.pack <$> hGetContents stdout+ res <- waitForProcess phandler+ putStrLn $ "Awaited: " <> show res+ putStrLn $ "Result: " <> show (T.length output)+ threadDelay 100000+ putStrLn "Waiting"+ return output++main :: IO ()+main = do+ _ <- getFileContent+ return ()
+ nyan-interpolation-core.cabal view
@@ -0,0 +1,118 @@+cabal-version: 2.0++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 4b363e6c807e291a385c97c298693896001c458a6299ea54163dc5a58a12bb27++name: nyan-interpolation-core+version: 0.9+synopsis: Customize your nyan interpolator!+description: This package to tune up your own variation of interpolator. Declare new rendering modes, set desired switches defaults and more.+category: Interpolation, Text+homepage: https://github.com/serokell/nyan-interpolation#readme+bug-reports: https://github.com/serokell/nyan-interpolation/issues+author: Serokell+maintainer: Serokell <hi@serokell.io>+copyright: 2022 Serokell <https://serokell.io>+license: MPL-2.0+license-file: LICENSE+build-type: Simple+extra-source-files:+ CHANGES.md++source-repository head+ type: git+ location: https://github.com/serokell/nyan-interpolation++library+ exposed-modules:+ Text.Interpolation.Nyan.Core+ Text.Interpolation.Nyan.Core.Internal.Base+ Text.Interpolation.Nyan.Core.Internal.Parser+ Text.Interpolation.Nyan.Core.Internal.Processor+ Text.Interpolation.Nyan.Core.Internal.RMode+ Text.Interpolation.Nyan.Core.Internal.Splice+ Text.Interpolation.Nyan.RModes.Buildable+ Text.Interpolation.Nyan.RModes.CommonExtra+ Text.Interpolation.Nyan.RModes.Show+ other-modules:+ Paths_nyan_interpolation_core+ autogen-modules:+ Paths_nyan_interpolation_core+ hs-source-dirs:+ src+ default-extensions: AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric DerivingStrategies FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies UndecidableInstances ViewPatterns TypeApplications TypeOperators QuasiQuotes+ ghc-options: -Weverything -Wno-missing-export-lists -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages+ build-depends:+ base <4.15+ , fmt+ , megaparsec+ , mtl+ , process+ , template-haskell+ , text+ , vector+ default-language: Haskell2010++executable nyan-interpolation-try+ main-is: Main.hs+ other-modules:+ Paths_nyan_interpolation_core+ hs-source-dirs:+ app+ default-extensions: AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric DerivingStrategies FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies UndecidableInstances ViewPatterns TypeApplications TypeOperators QuasiQuotes+ ghc-options: -Weverything -Wno-missing-export-lists -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages+ build-depends:+ base <4.15+ , fmt+ , megaparsec+ , mtl+ , nyan-interpolation-core+ , process+ , template-haskell+ , text+ , vector+ default-language: Haskell2010++test-suite nyan-interpolation-core-tests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Test.Customization+ Test.Interpolator+ Test.Parser+ Test.Processor+ Test.Util+ Test.ValueInterpolators+ Tree+ Paths_nyan_interpolation_core+ hs-source-dirs:+ tests+ default-extensions: AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric DerivingStrategies FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies UndecidableInstances ViewPatterns TypeApplications TypeOperators QuasiQuotes+ ghc-options: -Weverything -Wno-missing-export-lists -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages+ build-tool-depends:+ tasty-discover:tasty-discover+ build-depends:+ HUnit+ , base <4.15+ , fmt+ , megaparsec+ , mtl+ , nyan-interpolation-core+ , process+ , tasty+ , tasty-hunit-compat+ , template-haskell+ , text+ , vector+ default-language: Haskell2010++test-suite doctests+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: doctests.hs+ ghc-options: -threaded+ build-depends: base, nyan-interpolation-core, doctest-parallel >= 0.1+ default-language: Haskell2010
+ src/Text/Interpolation/Nyan/Core.hs view
@@ -0,0 +1,119 @@+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>+--+-- SPDX-License-Identifier: MPL-2.0++{- | Core of the @nyan-interpolation@ library.++Use it to define your own variation of the interpolator,+customizing the default switches and other parameters to your preferences.++@+int :: QuasiQuoter+int = mkInt defaultInterpolatorOptions+ { defaultSwitchesOptions = recommendedDefaultSwitchesOptions+ { defSpacesTrimming = Just True+ }+ }+@++-}+module Text.Interpolation.Nyan.Core+ ( -- * Interpolator+ mkInt+ -- * Interpolator options+ , InterpolatorOptions+ , defaultInterpolatorOptions+ -- ** Field accessors for interpolator options+ , defaultSwitchesOptions+ , valueInterpolator+ , invisibleCharsPreview+ -- * Default switches options+ , DefaultSwitchesOptions+ , basicDefaultSwitchesOptions+ , recommendedDefaultSwitchesOptions+ -- ** Field accessors for default switches options+ , defSpacesTrimming+ , defIndentationStripping+ , defLeadingNewlineStripping+ , defTrailingSpacesStripping+ , defReducedNewlines+ , defReturnType+ , defMonadic++ -- * Value interpolators+ , ValueInterpolator (..)+ , simpleValueInterpolator+ , tickedValueInterpolator++ -- * Adjusting preview+ , InvisibleCharsPreview (..)+ , simpleInvisibleCharsPreview++ -- * Rendering modes+ , RMode (..)++ -- * Re-exports+ , TH.QuasiQuoter++ , nyan+ ) where++import qualified Data.Text as T+import qualified Language.Haskell.TH.Quote as TH++import Text.Interpolation.Nyan.Core.Internal.Base+import Text.Interpolation.Nyan.Core.Internal.Parser+import Text.Interpolation.Nyan.Core.Internal.Processor+import Text.Interpolation.Nyan.Core.Internal.RMode+import Text.Interpolation.Nyan.Core.Internal.Splice++import Control.Concurrent+import qualified Data.Text as T+import GHC.IO.Handle+import System.Process++-- | Construct an interpolator.+--+-- Usually you pass some options here that you consider canonical and use+-- the resulting interolator throughout your project.+mkInt :: InterpolatorOptions -> TH.QuasiQuoter+mkInt iopts = TH.QuasiQuoter+ { TH.quoteExp = \s -> do+ (sopts, sint) <-+ either fail pure $+ parseIntString (defaultSwitchesOptions iopts) (T.pack s)+ let sint' = processIntString sopts sint+ intSplice iopts (sopts, sint')+ , TH.quotePat = \_ ->+ fail "Cannot interpolate at pattern position"+ , TH.quoteType = \_ ->+ fail "Cannot interpolate at type position"+ , TH.quoteDec = \_ ->+ fail "Cannot interpolate at declaration position"+ }++-- | The most interpolator options.+--+-- * Tries to keep the text as much unchanged as possible.+-- * Interpolates only variables.+defaultInterpolatorOptions :: InterpolatorOptions+defaultInterpolatorOptions = InterpolatorOptions+ { defaultSwitchesOptions = basicDefaultSwitchesOptions+ , valueInterpolator = simpleValueInterpolator+ , invisibleCharsPreview = simpleInvisibleCharsPreview+ }++nyan :: IO T.Text+nyan = withCreateProcess (proc "cat" ["kek.txt"]){ std_out = CreatePipe }+ \_mStdin mStdout _mStderr phandler ->+ case mStdout of+ Nothing -> error "No handler"+ Just stdout -> do+ putStrLn "Connected, getting"+ !output <- T.pack <$> hGetContents stdout+ res <- waitForProcess phandler+ putStrLn $ "Awaited: " <> show res+ putStrLn $ "Result: " <> show (T.length output)+ threadDelay 100000+ putStrLn "Waiting"+ return output
+ src/Text/Interpolation/Nyan/Core/Internal/Base.hs view
@@ -0,0 +1,177 @@+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>+--+-- SPDX-License-Identifier: MPL-2.0++{-# LANGUAGE DerivingVia #-}++module Text.Interpolation.Nyan.Core.Internal.Base where++import Data.Monoid (Endo (..))+import Data.Text (Text)+import Language.Haskell.TH (ExpQ)++{- $setup++> import Data.Text+> import Data.Text.Lazy+-}+++-- * Interpolation data++-- | Information about single piece that is to be interpolated.+data IntData = IntData+ { idMode :: Text+ -- ^ How to use the value in the braces.+ -- This is some text before the brances, usually one letter or nothing.+ , idCode :: Text+ -- ^ The inserted code. This is what appears in braces.+ } deriving stock (Show, Eq)++-- | Piece of interpolation string.+data ParsedIntPiece+ = PipString Text+ -- ^ Mere text.+ | PipNewline Text+ -- ^ Some line feed.+ -- This must be preferred over 'PipString'.+ | PipLeadingWs Word+ -- ^ Whitespaces at the beginning of the line.+ -- This must be preferred over 'PipString'.+ | PipEmptyLine+ -- ^ Line without any text. The line feed is not included here.+ -- This must be preferred over 'PipLeadingWs'.+ | PipInt IntData+ -- ^ Interpolator piece.+ deriving stock (Show, Eq)++type ParsedInterpolatedString = [ParsedIntPiece]++-- | Finalized piece of interpolation string.+data IntPiece+ = IpString Text+ -- ^ Mere text.+ | IpInt IntData+ -- ^ Interpolator piece.+ deriving stock (Show, Eq)++type InterpolatedString = [IntPiece]++-- * Switches++-- | Return type of the interpolator.+data ReturnType+ = AnyFromBuilder+ -- ^ @FromBuilder a => a@+ | ConcreteText+ -- ^ 'Data.Text.Text'+ | ConcreteLText+ -- ^ 'Data.Text.Lazy.Text'+ | ConcreteBuilder+ -- ^ 'Data.Text.Lazy.Builder.Builder'+ deriving stock (Show, Eq)++-- | Requested preview level.+data PreviewLevel+ = PreviewNone+ -- ^ Do nothing special.+ | PreviewExact+ -- ^ Print the resulting text as-is (without substitutions).+ | PreviewInvisible+ -- ^ Print the text, replacing invisible characters with special symbols.+ deriving stock (Show, Eq, Enum, Bounded)++-- | All switches options.+data SwitchesOptions = SwitchesOptions+ { spacesTrimming :: Bool+ , indentationStripping :: Bool+ , leadingNewlineStripping :: Bool+ , trailingSpacesStripping :: Bool+ , returnType :: ReturnType+ , reducedNewlines :: Bool+ , monadic :: Bool+ , previewLevel :: PreviewLevel+ } deriving stock (Show, Eq)++-- | Default switches options set in the interpolator, those that are used+-- in @[int||...|]@.+--+-- When no default value for a switch is specified, this switch is left+-- mandatory for specifying in the interpolator.+data DefaultSwitchesOptions = DefaultSwitchesOptions+ { defSpacesTrimming :: Maybe Bool+ , defIndentationStripping :: Maybe Bool+ , defLeadingNewlineStripping :: Maybe Bool+ , defTrailingSpacesStripping :: Maybe Bool+ , defReducedNewlines :: Maybe Bool+ , defReturnType :: Maybe ReturnType+ , defMonadic :: Maybe Bool+ } deriving stock (Show)++-- | Default 'DefaultSwitchesOptions'.+--+-- This set of switches tries to leave the text as much unmodified as possible.+--+-- It does __not__ define default switches used by @Text.Interpolation.Nyan@+-- module, and you will likely want to enable at least some options here.+basicDefaultSwitchesOptions :: DefaultSwitchesOptions+basicDefaultSwitchesOptions = DefaultSwitchesOptions+ { defSpacesTrimming = Just False+ , defIndentationStripping = Just False+ , defLeadingNewlineStripping = Just False+ , defTrailingSpacesStripping = Just False+ , defReturnType = Just AnyFromBuilder+ , defReducedNewlines = Just False+ , defMonadic = Just False+ }++-- | 'DefaultSwitchesOptions' used in the @Text.Interpolation.Nyan@ module+-- in the default interpolator.+recommendedDefaultSwitchesOptions :: DefaultSwitchesOptions+recommendedDefaultSwitchesOptions = DefaultSwitchesOptions+ { defSpacesTrimming = Just False+ , defIndentationStripping = Just True+ , defLeadingNewlineStripping = Just True+ , defTrailingSpacesStripping = Just True+ , defReturnType = Just AnyFromBuilder+ , defReducedNewlines = Just False+ , defMonadic = Just False+ }++-- | How to expand values in @#{}@ into Haskell AST.+newtype ValueInterpolator = ValueInterpolator+ { runValueInterpolator :: Text -> ExpQ+ }++-- | Transformation that describes how to mark the invisible characters.+--+-- Use 'Monoid' instance to sequence multiple such transformations.+newtype InvisibleCharsPreview = InvisibleCharsPreview+ { replaceInvisibleChars :: String -> String+ } deriving Semigroup via (Endo String)+ deriving Monoid via (Endo String)++-- | Options set when creating an interpolator.+data InterpolatorOptions = InterpolatorOptions+ { defaultSwitchesOptions :: DefaultSwitchesOptions+ -- ^ Default switches options.++ , valueInterpolator :: ValueInterpolator+ -- ^ Expands text in @#{}@ into AST.+ --+ -- We have to leave this changeable because there is no "perfect" expander.+ -- Using the most appropriate one would require relying on @haskell-src-exts@+ -- package which is quite a heavy-weight dependency.+ -- Some users would prefer a simpler solution which would only allow+ -- variables in @#{}@.+ --+ -- Interpreting the passed text in tricky ways is valid.+ -- For instance, for specialized interpolators @#{var}@+ -- could be expanded to @local'var@, @view varLens@, or more complex+ -- Haskell code.++ , invisibleCharsPreview :: InvisibleCharsPreview+ -- ^ In case, when the switches are set to preview the resulting text+ -- with invisibles being marked specially (@!!@), how to update the pieces+ -- of text.+ }
+ src/Text/Interpolation/Nyan/Core/Internal/Parser.hs view
@@ -0,0 +1,348 @@+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>+--+-- SPDX-License-Identifier: MPL-2.0++module Text.Interpolation.Nyan.Core.Internal.Parser where++import Control.Applicative (many, optional)+import Control.Monad (guard, when, (<=<))+import Control.Monad.State (MonadState, execStateT, get, put)+import Data.Bifunctor (first)+import Data.Char (isAlphaNum, isSpace)+import Data.Foldable (asum)+import Data.Functor (($>))+import Data.Text (Text)+import qualified Data.Text as T+import Fmt (Builder, build, fmt)+import Text.Interpolation.Nyan.Core.Internal.Base+import Text.Megaparsec (Parsec, customFailure, eof, errorBundlePretty, label, lookAhead, parse,+ single, takeWhile1P, takeWhileP)+import Text.Megaparsec.Error (ShowErrorComponent (..))++newtype OptionChanged = OptionChanged Bool+ deriving stock (Show, Eq)++-- | An accumulator for switch options during parsing.+data SwitchesOptionsBuilder = SwitchesOptionsBuilder+ { spacesTrimmingB :: (OptionChanged, Maybe Bool)+ , indentationStrippingB :: (OptionChanged, Maybe Bool)+ , leadingNewlineStrippingB :: (OptionChanged, Maybe Bool)+ , trailingSpacesStrippingB :: (OptionChanged, Maybe Bool)+ , returnTypeB :: (OptionChanged, Maybe ReturnType)+ , reducedNewlinesB :: (OptionChanged, Maybe Bool)+ , monadicB :: (OptionChanged, Maybe Bool)+ , previewLevelB :: PreviewLevel+ }++toSwitchesOptionsBuilder :: DefaultSwitchesOptions -> SwitchesOptionsBuilder+toSwitchesOptionsBuilder DefaultSwitchesOptions{..} =+ SwitchesOptionsBuilder+ { spacesTrimmingB = (OptionChanged False, defSpacesTrimming)+ , indentationStrippingB = (OptionChanged False, defIndentationStripping)+ , leadingNewlineStrippingB = (OptionChanged False, defLeadingNewlineStripping)+ , trailingSpacesStrippingB = (OptionChanged False, defTrailingSpacesStripping)+ , returnTypeB = (OptionChanged False, defReturnType)+ , reducedNewlinesB = (OptionChanged False, defMonadic)+ , monadicB = (OptionChanged False, defMonadic)+ , previewLevelB = PreviewNone+ }++finalizeSwitchesOptions :: MonadFail m => SwitchesOptionsBuilder -> m SwitchesOptions+finalizeSwitchesOptions SwitchesOptionsBuilder{..} = do+ spacesTrimming <- fromOptional "spaces trimming" spacesTrimmingB+ indentationStripping <- fromOptional "indentation stripping" indentationStrippingB+ leadingNewlineStripping <- fromOptional "leading newline stripping" leadingNewlineStrippingB+ trailingSpacesStripping <- fromOptional "trailing spaces stripping" trailingSpacesStrippingB+ returnType <- fromOptional "return type" returnTypeB+ reducedNewlines <- fromOptional "reduced newlines" reducedNewlinesB+ monadic <- fromOptional "monadic" monadicB+ let previewLevel = previewLevelB+ return SwitchesOptions{..}+ where+ fromOptional desc (_, mval) = case mval of+ Nothing -> fail $ "Switch for " <> desc <> " must be specified"+ Just val -> pure val++type SwitchesOptionsSetter m = (MonadState SwitchesOptionsBuilder m, MonadFail m)++setIfNew+ :: (MonadFail m, Eq a)+ => String -> a -> (OptionChanged, Maybe a) -> m (OptionChanged, Maybe a)+setIfNew desc new (OptionChanged ch, old)+ | ch = fail $ "Modifying `" <> desc <> "` option for the second time"+ | old == Just new = fail $ "Switch option `" <> desc <> "` is set redundantly"+ | otherwise = return (OptionChanged True, Just new)++setSpacesTrimming :: SwitchesOptionsSetter m => Bool -> m ()+setSpacesTrimming enable = do+ opts <- get+ res <- setIfNew "spaces trimming" enable (spacesTrimmingB opts)+ put opts{ spacesTrimmingB = res }++setIndentationStripping :: SwitchesOptionsSetter m => Bool -> m ()+setIndentationStripping enable = do+ opts <- get+ res <- setIfNew "indentation stripping" enable (indentationStrippingB opts)+ put opts{ indentationStrippingB = res }++setLeadingNewlineStripping :: SwitchesOptionsSetter m => Bool -> m ()+setLeadingNewlineStripping enable = do+ opts <- get+ res <- setIfNew "leading newline stripping" enable (leadingNewlineStrippingB opts)+ put opts{ leadingNewlineStrippingB = res }++setTrailingSpacesStripping :: SwitchesOptionsSetter m => Bool -> m ()+setTrailingSpacesStripping enable = do+ opts <- get+ res <- setIfNew "trailing spaces stripping" enable (trailingSpacesStrippingB opts)+ put opts{ trailingSpacesStrippingB = res }++setReducedNewlines :: SwitchesOptionsSetter m => Bool -> m ()+setReducedNewlines enable = do+ opts <- get+ res <- setIfNew "reduced newlines" enable (reducedNewlinesB opts)+ put opts{ reducedNewlinesB = res }++setMonadic :: SwitchesOptionsSetter m => Bool -> m ()+setMonadic enable = do+ opts <- get+ res <- setIfNew "monadic" enable (monadicB opts)+ put opts{ monadicB = res }++setReturnType :: SwitchesOptionsSetter m => ReturnType -> m ()+setReturnType ty = do+ opts <- get+ res <- setIfNew "return type" ty (returnTypeB opts)+ put opts{ returnTypeB = res }++accountPreview :: SwitchesOptionsSetter m => m ()+accountPreview = do+ opts <- get+ when (previewLevelB opts == maxBound) $+ fail "Too high preview level"+ put opts{ previewLevelB = toEnum $ fromEnum (previewLevelB opts) + 1 }++notAnyOf :: [Char -> Bool] -> Char -> Bool+notAnyOf ps c = not $ or (sequence ps c)++one :: a -> [a]+one = (: [])++data CustomParserFailure+ = SwitchesHelpRequested DefaultSwitchesOptions++-- These instances are necessary for megaparsec+instance Eq CustomParserFailure where+ a == b = compare a b == EQ+instance Ord CustomParserFailure where+ SwitchesHelpRequested{} `compare` SwitchesHelpRequested{} = EQ++instance ShowErrorComponent CustomParserFailure where+ showErrorComponent = \case+ SwitchesHelpRequested defSOpts -> fmt $ switchesHelpMessage defSOpts++switchesSectionP :: DefaultSwitchesOptions -> Parsec CustomParserFailure Text SwitchesOptions+switchesSectionP defSOpts =+ finalizeSwitchesOptions <=<+ flip execStateT (toSwitchesOptionsBuilder defSOpts) $ many $ label switchLabel $ asum+ [ asum+ [ single 's' $> True+ , single 'S' $> False+ ] >>= setSpacesTrimming++ , asum+ [ single 'd' $> True+ , single 'D' $> False+ ] >>= setIndentationStripping++ , asum+ [ single 'a' $> True+ , single 'A' $> False+ ] >>= setLeadingNewlineStripping++ , asum+ [ single 'z' $> True+ , single 'Z' $> False+ ] >>= setTrailingSpacesStripping++ , asum+ [ single 'n' $> True+ , single 'N' $> False+ ] >>= setReducedNewlines++ , asum+ [ single 'm' $> True+ , single 'M' $> False+ ] >>= setMonadic++ , asum+ [ single 'B' $> AnyFromBuilder+ , single 'b' $> ConcreteBuilder+ , single 't' $> ConcreteText+ , single 'T' $> ConcreteLText+ ] >>= setReturnType++ , single '!' >> accountPreview++ , single '?' >> customFailure (SwitchesHelpRequested defSOpts)++ ]+ where+ switchLabel = "switch option (type '?' here for help)"++switchesHelpMessage :: DefaultSwitchesOptions -> Builder+switchesHelpMessage sopts =+ let _exhaustivnessCheck :: SwitchesOptions = SwitchesOptions+ (error "")+ (error "")+ (error "")+ (error "")+ (error "")+ (error "")+ (error "")+ (error "")+ -- ↑ Note: If you edit this, you may also need to update+ -- the help messages below.+ in mconcat+ [ "\nHelp on switches:\n"+ , helpOnOptions (defSpacesTrimming sopts)+ [ ("s", "enable spaces trimming", Just True)+ , ("S", "disable spaces trimming", Just False)+ ]++ , helpOnOptions (defIndentationStripping sopts)+ [ ("d", "enable indentation stripping", Just True)+ , ("D", "disable indentation stripping", Just False)+ ]++ , helpOnOptions (defLeadingNewlineStripping sopts)+ [ ("a", "enable leading newline stripping", Just True)+ , ("A", "disable leading newline stripping", Just False)+ ]++ , helpOnOptions (defTrailingSpacesStripping sopts)+ [ ("z", "enable trailing spaces stripping", Just True)+ , ("Z", "disable trailing spaces stripping", Just False)+ ]++ , helpOnOptions (defReducedNewlines sopts)+ [ ("n", "enable newlines reducing", Just True)+ , ("N", "disable newlines reducing", Just False)+ ]++ , helpOnOptions (defMonadic sopts)+ [ ("m", "enable monadic interpolated values", Just True)+ , ("M", "disable monadic interpolated values", Just False)+ ]++ , helpOnOptions (defReturnType sopts)+ [ ("t", "return `Text`", Just ConcreteText)+ , ("T", "return lazy `Text`", Just ConcreteLText)+ , ("b", "return `Builder`", Just ConcreteBuilder)+ , ("B", "return any text-like type (`FromBuilder a => a`)", Just AnyFromBuilder)+ ]++ , helpOnOptions PreviewNone+ [ ("!", "show rendered text (without substitutions) as a warning", PreviewExact)+ , ("!!", "like ! but also marks invisible characters like spaces", PreviewInvisible)+ ]+ ]+ where+ helpOnOptions defVal available = mconcat+ [ "· " <> build @Text switch <> " - " <> help <> "\n"+ | (switch, help, val) <- available+ , val /= defVal+ ]++intPieceP :: Ord e => Parsec e Text [ParsedIntPiece]+intPieceP = asum+ [+ -- consume normal text+ one . PipString <$> takeWhile1P Nothing (notAnyOf [(== '\\'), (== '#'), isSpace])++ -- potentially interpolator case+ , single '#' *> do+ mode <- takeWhileP Nothing \c ->+ isAlphaNum c || c == '_'+ asum+ [ do+ -- interpolator+ _ <- single '{'+ intTxt <- many $ asum+ [ takeWhile1P (Just "interpolated piece") $ notAnyOf [(== '\\'), (== '}')]+ , single '\\' >> T.singleton <$> asum+ [ single '\\'+ , single '}'+ ]+ ]+ _ <- single '}'++ return . one $ PipInt IntData+ { idMode = mode+ , idCode = mconcat intTxt+ }++ -- just plain text+ , return $ one . PipString $ "#" <> mode+ ]++ -- escaped text+ , single '\\' *> asum+ [ one . PipString . T.singleton <$> single '\\'+ , one . PipString . T.singleton <$> single '#'+ -- trailing '\' cancels newline feed+ , newline *> lineStart+ ]++ -- newline+ , (:) <$> newline <*> lineStart++ -- fast spacing+ , one . PipString <$> takeWhile1P Nothing isNonNewlineSpace++ , fail "Unexpected: failed to consume some input"++ ]+ where+ newline = PipNewline . mconcat <$> sequence+ [ maybe "" T.singleton <$> optional (single '\r')+ , T.singleton <$> single '\n'+ ]+ isNonNewlineSpace c = isSpace c && c /= '\n' && c /= '\r'++ -- Parse indentation+ lineStart = asum+ [ lookAhead newline $> [PipEmptyLine]+ , do+ wss <- fromIntegral @Int @Word . T.length <$>+ takeWhileP Nothing isNonNewlineSpace+ return $ guard (wss > 0) $> PipLeadingWs wss+ ]++-- | Since the parser may produce several 'PipString' with different kind of+-- content (e.g. spaces and words), we would like to glue those before passing+-- the interpolated string to the next stage.+glueParsedStrings :: ParsedInterpolatedString -> ParsedInterpolatedString+glueParsedStrings = \case+ [] -> []+ -- TODO: use Builder here+ PipString s1 : PipString s2 : ps -> glueParsedStrings (PipString (s1 <> s2) : ps)+ p : ps -> p : glueParsedStrings ps++intStringP+ :: DefaultSwitchesOptions+ -> Parsec CustomParserFailure Text (SwitchesOptions, ParsedInterpolatedString)+intStringP sopts = do+ switches <- switchesSectionP sopts+ _ <- single '|'+ pieces <- glueParsedStrings . concat <$> many intPieceP+ eof+ return (switches, pieces)++parseIntString+ :: DefaultSwitchesOptions+ -> Text+ -> Either String (SwitchesOptions, ParsedInterpolatedString)+parseIntString defSOpts txt =+ first errorBundlePretty $+ parse (intStringP defSOpts) "int QQ" txt
+ src/Text/Interpolation/Nyan/Core/Internal/Processor.hs view
@@ -0,0 +1,122 @@+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>+--+-- SPDX-License-Identifier: MPL-2.0++module Text.Interpolation.Nyan.Core.Internal.Processor where++import Control.Monad (guard)+import Data.Functor (($>))+import Data.Maybe (mapMaybe)+import qualified Data.Text as T+import qualified Data.Vector as V+import Text.Interpolation.Nyan.Core.Internal.Base++-- | Applies the transformations like spaces stripping.+processIntString :: SwitchesOptions -> ParsedInterpolatedString -> InterpolatedString+processIntString sopts istr = istr+ & V.fromList+ & do if leadingNewlineStripping sopts then stripLeadingNewline else id+ & do if trailingSpacesStripping sopts then stripTrailingLeadingWs else id+ & do if indentationStripping sopts then stripCommonIndentation else id+ & V.toList+ & do if reducedNewlines sopts then reduceNewlines else id+ & V.fromList+ & do if spacesTrimming sopts then trimLeftSpaces . trimRightSpaces else id+ & V.toList+ -- We don't need the information about trailing whitespaces anymore+ & unfoldWsData+ -- Glue strings, as the previous stage put texts and whitespaces separately+ & glueStrings+ where+ (&) = flip ($)++ stripLeadingNewline ps = case V.uncons ps of+ Just (PipNewline _, ps') -> ps'+ _ -> ps++ stripTrailingLeadingWs ps = case V.unsnoc ps of+ Just (ps', PipLeadingWs _) -> ps'+ _ -> ps++ trimSpacesInPiece trimText = \case+ PipNewline _ -> Nothing+ PipLeadingWs _ -> Nothing+ PipEmptyLine -> Nothing+ PipString s ->+ let s' = trimText s+ in if T.null s' then Nothing else Just (PipString s')+ p@PipInt{} -> Just p++ trimLeftSpaces ps = case V.uncons ps of+ Nothing -> mempty+ Just (p, ps') -> case trimSpacesInPiece T.stripStart p of+ Nothing -> trimLeftSpaces ps'+ Just p' -> V.cons p' ps'++ trimRightSpaces ps = case V.unsnoc ps of+ Nothing -> mempty+ Just (ps', p) -> case trimSpacesInPiece T.stripEnd p of+ Nothing -> trimRightSpaces ps'+ Just p' -> V.snoc ps' p'++ stripCommonIndentation ps =+ let+ interestingIndent piece = do+ PipLeadingWs ws <- pure piece+ -- Lines without payload will likely be completely empty+ -- which is forced by trailing newline stripping+ -- So a line with 0 leading spaces won't not affect anything+ guard (ws /= 0)+ Just ws+ minIndent = case mapMaybe interestingIndent (V.toList ps) of+ [] -> error "min indent requested unnecessarily"+ res -> minimum res+ in flip V.mapMaybe ps \case+ PipLeadingWs ws ->+ guard (ws > minIndent) $> PipLeadingWs (ws - minIndent)+ other -> Just other++ reduceNewlines = \case+ -- The initial case is special - we just want to remove the leading newline+ PipNewline{} : l -> skipNext l+ p : l -> p : reduceNext l+ [] -> []+ where+ -- Reduce the next encountered newline+ reduceNext = \case+ PipNewline{} : p : l -> case p of+ -- Multiple newlines in a row are just reduced+ PipEmptyLine{} -> p : skipNext l+ -- Otherwise we see two adjacent non-empty lines+ _ -> PipString " " : skipNext (p : l)+ [PipNewline{}] -> []+ p : l -> p : reduceNext l+ [] -> []++ -- Skip all the next newlines as-is+ skipNext = \case+ p@PipNewline{} : l -> p : skipNext l+ p@PipEmptyLine{} : l -> p : skipNext l+ -- This case is questionable.+ -- Let's assume, that those who think that invisible spaces should not+ -- affect newlines reduction, also have trailing spaces cleanup in IDE.+ -- And there might be people who want special tuning and make+ -- invisible spaces to break the newlines sequence.+ p@PipLeadingWs{} : l -> p : skipNext l+ p@PipString{} : l -> p : reduceNext l+ p@PipInt{} : l -> p : reduceNext l+ [] -> []++ unfoldWsData :: ParsedInterpolatedString -> InterpolatedString+ unfoldWsData = map \case+ PipString s -> IpString s+ PipNewline nl -> IpString nl+ PipLeadingWs n -> IpString . mconcat $ replicate (fromIntegral n) " "+ PipEmptyLine -> IpString mempty+ PipInt i -> IpInt i++ glueStrings :: InterpolatedString -> InterpolatedString+ glueStrings = \case+ [] -> []+ IpString s1 : IpString s2 : ps -> glueStrings (IpString (s1 <> s2) : ps)+ p : ps -> p : glueStrings ps
+ src/Text/Interpolation/Nyan/Core/Internal/RMode.hs view
@@ -0,0 +1,33 @@+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>+--+-- SPDX-License-Identifier: MPL-2.0++module Text.Interpolation.Nyan.Core.Internal.RMode+ ( RMode(..)+ ) where++import Fmt (Builder)++{- | Type that describes rendering modes.++An interpolator that has @rmode'xxx :: RMode t@ variable available in scope+will be able to use @xxx@ rendering mode.++More precisely, any @#xxx{expr}@ in interpolator will be expanded to+@renderWithMode rmode'xxx (expr)@ Haskell code+(some switches may slightly change this behaviour though).++>>> import Fmt (build)+>>> let rmode's :: Show a => RMode a; rmode's = RMode (build . show)+>>>+>>> [int||Value is #s{5}|]+"Value is 5"++>>> rmode'hex :: RMode Word+>>> rmode'hex = RMode Fmt.hexF+>>>+>>> [int||Value is #hex{32}]+"Value is 0x20"++-}+newtype RMode a = RMode { renderWithMode :: a -> Builder }
+ src/Text/Interpolation/Nyan/Core/Internal/Splice.hs view
@@ -0,0 +1,184 @@+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>+--+-- SPDX-License-Identifier: MPL-2.0++-- | Producing TH splices for interpolation.+module Text.Interpolation.Nyan.Core.Internal.Splice where++import Control.Monad (forM, unless, when)+import Data.Char (isSpace)+import Data.String (fromString)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import Fmt (Builder, fmt)+import Language.Haskell.TH++import Text.Interpolation.Nyan.Core.Internal.Base+import Text.Interpolation.Nyan.Core.Internal.RMode++-- | Expression result of which can yet be somehow extended.+type ExtendableRes = (ExpQ -> ExpQ) -> ExpQ++-- | Build interpolated string into TH splice.++-- Note: one of things we aim at is concise produced code, as the user may+-- sometimes need to read what is being generated.+intSplice+ :: InterpolatorOptions+ -> (SwitchesOptions, InterpolatedString)+ -> ExpQ+intSplice iopts (sopts, istr) = do+ invokePreview+ if not (monadic sopts)+ then+ [| $finalConvertFuncQ $ mconcat+ $(ListE <$> forM istr \case+ IpString txt ->+ mkStrLiteralQ txt+ IpInt IntData{..} -> do+ [|$(renderFuncQ idMode)+ $(runValueInterpolator (valueInterpolator iopts) idCode)+ |]+ )+ |]+ else+ [| $finalConvertFuncQ . mconcat <$> sequenceA+ $(ListE <$> forM istr \case+ IpString txt ->+ [|pure $(mkStrLiteralQ txt)|]+ IpInt IntData{..} -> do+ [|$(renderFuncQ idMode) <$>+ $(runValueInterpolator (valueInterpolator iopts) idCode)+ |]+ )+ |]+ where+ -- Contains: render rmode'xxx+ renderFuncQ :: Text -> ExpQ+ renderFuncQ mode =+ return $+ VarE 'renderWithMode+ `AppE`+ VarE (mkName $ "rmode'" <> T.unpack mode)++ -- Contains: fmt @Builder @ret+ finalConvertFuncQ :: ExpQ+ finalConvertFuncQ = return $ case returnType sopts of+ AnyFromBuilder -> fmtE+ ConcreteText -> fmtE `AppTypeE` ConT ''Text+ ConcreteLText -> fmtE `AppTypeE` ConT ''LT.Text+ ConcreteBuilder -> VarE 'id `AppTypeE` ConT ''Builder+ where+ fmtE = VarE 'fmt++ mkStrLiteralQ :: Text -> ExpQ+ mkStrLiteralQ str = do+ haveOverloadedStrings <- isExtEnabled OverloadedStrings+ let fromStringF+ | haveOverloadedStrings = Nothing+ | otherwise = Just (VarE 'fromString)+ return $ maybe id AppE fromStringF (LitE . StringL $ T.unpack str)++ invokePreview :: Q ()+ invokePreview = do+ let msg = case previewLevel sopts of+ PreviewNone -> Nothing+ PreviewExact -> Just $ mconcat+ [ "Interpolated text will look like:\n"+ , flip foldMap istr \case+ IpString txt -> txt+ IpInt _ -> "..."+ , "\n"+ ]+ PreviewInvisible -> Just $ mconcat+ [ "Interpolated text will look like:\n"+ , let showInvisibles = replaceInvisibleChars (invisibleCharsPreview iopts)+ in flip foldMap istr \case+ IpString txt -> T.pack $ showInvisibles (T.unpack txt)+ IpInt _ -> "..."+ , "<end>\n"+ ]++ -- We report as an error, not as a warning, because+ -- in normal circumstances the user wants to disable+ -- the preview immediately after checking, he/she+ -- probably do not want to build half of the project and+ -- then build it again after disabling the preview.+ --+ -- So we want to build the entire module, but do not go further.+ mapM_ (reportError . T.unpack) msg++{- | Interpolates only strings containing single variable.++This allows for @{var}@-like interpolated values, no applications,+operators or other constructions are allowed.++-}+simpleValueInterpolator :: ValueInterpolator+simpleValueInterpolator = ValueInterpolator \txt -> do+ let varNameTxt = T.strip txt+ unless (T.all isAllowedChar varNameTxt) $+ fail "Only passing sole variables is allowed by this interpolator"+ when (T.null varNameTxt) $+ fail "Empty placeholder"+ lookupValueName (T.unpack varNameTxt) >>= \case+ Nothing -> fail $ "Variable '" <> T.unpack varNameTxt <> "' is not in scope"+ Just varName -> return (VarE varName)+ where+ isAllowedChar c =+ -- handling the most common things to remind the user that only variables+ -- are allowed;+ -- want to rather be too permissive than too restrictive+ not (isSpace c) && c /= '$' && c /= '.'++{- | This is a variation of 'simpleValueInterpolator' that requires all the+referred variables to start from a special @i'@ prefix.++One major issue with 'simpleValueInterpolator' is that, with it the user can+mistakenly pick a value from the wrong scope, for instance, a global value+instead of a local one.+This value interpolator tries to solve the issue by bringing the practice+to call the interpolator like++@+let renderedText =+ let i'value1 = ...+ i'value2 = ...+ in [int||Values are {value1} and {value2}]+@++and so interpolating only local declarations.++-}+tickedValueInterpolator :: ValueInterpolator+tickedValueInterpolator = ValueInterpolator+ \txt -> runValueInterpolator simpleValueInterpolator ("i'" <> txt)++-- | Marks the most common space-like characters.+simpleInvisibleCharsPreview :: InvisibleCharsPreview+simpleInvisibleCharsPreview = InvisibleCharsPreview go+ where+ go = \case+ ' ' : s ->+ '·' : go s+ '\r' : '\n' : s ->+ '⤶' : '\r' : '\n' : go s+ '\r' : s ->+ '⤶' : '\r' : go s+ '\n' : s ->+ '⤶' : '\n' : go s++ -- It's a good question how to render tab.+ -- It may look like 2 spaces, or 8 spaces, depending on+ -- the machine where it is rendered.+ -- So my stance is that using Tab for text alignment should be avoided,+ -- and we better choose some symbol that /does not/ reflect the space+ -- potentially occupied by a tab.+ -- A use case that we aim at is e.g. using Tab in CSV; there we would+ -- just want to know that Tab is present, we don't care how Tab+ -- character affects the text appearance.+ '\t' : s -> '→' : go s++ c : s -> c : go s+ [] -> []
+ src/Text/Interpolation/Nyan/RModes/Buildable.hs view
@@ -0,0 +1,23 @@+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>+--+-- SPDX-License-Identifier: MPL-2.0++-- | Set of basic rendering modes, where 'Buildable' is treated as+-- the primary way to render data.+module Text.Interpolation.Nyan.RModes.Buildable where++import Fmt (Buildable (..), Builder)++import Text.Interpolation.Nyan.Core++-- | Default render mode.+rmode' :: Buildable a => RMode a+rmode' = RMode build++-- | Render via 'Show'.+rmode's :: Show a => RMode a+rmode's = RMode $ build . show++-- | Rendering mode for 'Builder'.+rmode'b :: RMode Builder+rmode'b = RMode id
+ src/Text/Interpolation/Nyan/RModes/CommonExtra.hs view
@@ -0,0 +1,32 @@+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>+--+-- SPDX-License-Identifier: MPL-2.0++-- | Common additional rendering modes like the ones for numbers.+module Text.Interpolation.Nyan.RModes.CommonExtra where++import Fmt (Builder)++import Text.Interpolation.Nyan.Core+import Text.Interpolation.Nyan.RModes.Buildable (rmode')++-- * Literals++-- One can say these are useful only for toy examples, but there are+-- actual real-life cases when literals are needed. For instance:+--+-- [int||Switch is #l{ if isEnabled then "enabled" else "disabled" }|]++-- | Rendering mode for string literals when @-XOverloadedStrings@ extension+-- is enabled.+rmode'l :: RMode Builder+rmode'l = RMode id++-- | Render mode for decimal number literals.+rmode'd :: RMode Integer+rmode'd = rmode'++-- | Render mode for decimal number literals.+-- Alias for 'rmode'd'.+rmode'n :: RMode Integer+rmode'n = rmode'd
+ src/Text/Interpolation/Nyan/RModes/Show.hs view
@@ -0,0 +1,15 @@+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>+--+-- SPDX-License-Identifier: MPL-2.0++-- | Set of basic rendering modes, where 'Show' is treated as+-- the primary way to render data.+module Text.Interpolation.Nyan.RModes.Show where++import Fmt (build)++import Text.Interpolation.Nyan.Core++-- | Default render mode.+rmode' :: Show a => RMode a+rmode' = RMode $ build . show
+ tests/Main.hs view
@@ -0,0 +1,14 @@+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>+--+-- SPDX-License-Identifier: MPL-2.0++module Main+ ( main+ ) where++import Test.Tasty (defaultMain)++import Tree (tests)++main :: IO ()+main = defaultMain =<< tests
+ tests/Test/Customization.hs view
@@ -0,0 +1,41 @@+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>+--+-- SPDX-License-Identifier: MPL-2.0++module Test.Customization () where++import Text.Interpolation.Nyan.Core+import qualified Text.Interpolation.Nyan.Core.Internal.Base as Internal++-- | We have to make sure that all available options can be tuned, i.e.+-- all the record field selectors are exported (while the constructor is not).+_AllFieldsAreExported :: QuasiQuoter+_AllFieldsAreExported =+ let _ioptsExhaustive :: InterpolatorOptions = Internal.InterpolatorOptions+ (error "")+ (error "")+ (error "")+ -- ↑ if you change this, also add a field to the record below+ in mkInt defaultInterpolatorOptions+ { valueInterpolator = ValueInterpolator $ error ""+ , invisibleCharsPreview = InvisibleCharsPreview $ error ""+ , defaultSwitchesOptions =+ let _dsopts :: DefaultSwitchesOptions = Internal.DefaultSwitchesOptions+ (error "")+ (error "")+ (error "")+ (error "")+ (error "")+ (error "")+ (error "")+ -- ↑ if you change this, also add a field to the record below+ in basicDefaultSwitchesOptions+ { defIndentationStripping = Nothing+ , defSpacesTrimming = Nothing+ , defLeadingNewlineStripping = Nothing+ , defTrailingSpacesStripping = Nothing+ , defReducedNewlines = Nothing+ , defReturnType = Nothing+ , defMonadic = Nothing+ }+ }
+ tests/Test/Interpolator.hs view
@@ -0,0 +1,314 @@+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>+--+-- SPDX-License-Identifier: MPL-2.0++-- | Tests on the interpolator in overall.+module Test.Interpolator where++import Control.Monad.Reader (ask, runReader)+import Data.Functor.Identity (Identity (..))+import Data.Text (Text)+import qualified Data.Text.Lazy as LT+import Fmt (Buildable (..), Builder)+import Test.HUnit ((@?=))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)++import Text.Interpolation.Nyan.RModes.Buildable+import Text.Interpolation.Nyan.RModes.CommonExtra++import Test.Util+import Text.Interpolation.Nyan.Core++newtype PrintedValue = PrintedValue Int+ deriving stock (Show)++instance Buildable PrintedValue where+ build (PrintedValue a) = "v = " <> build a++-- | Verifies that two types are equal without trying to make types+-- more concrete. I.e. some polymorphic type won't be equal to a concrete type.+class TypeEq a b where+ cast :: a -> b+instance TypeEq a a where+ cast = id++rmode'mega :: RMode Builder+rmode'mega = RMode \t -> "mega " <> t++test_DefaultInterpolator :: TestTree+test_DefaultInterpolator = testGroup "Default interpolator"+ [ testCase "Empty text" do+ [int|t||]+ @?= ""++ , testCase "Simple text" do+ [int|t|Abc def|]+ @?= "Abc def"++ , testGroup "Interpolation"+ [ testCase "Simple case" do+ let a = "X" :: Text+ [int|t|Value: #{a}|]+ @?= "Value: X"++ , testCase "Several interpolators" do+ let a = "X" :: Text+ let b = "Y" :: Text+ let c = "Z" :: Text+ [int|t|Values: {#{a}, #{b}} and #{c}|]+ @?= "Values: {X, Y} and Z"++ , testCase "Rendering modes" do+ let a = PrintedValue 1+ let n = 5+ let s = "string"+ [int|t|#{a}, #s{a}, #d{n}, #l{s}|]+ @?= "v = 1, PrintedValue 1, 5, string"++ , testCase "Locally defined rendering mode" do+ let s = "nyan"+ [int|t|#mega{s}|]+ @?= "mega nyan"++ , testCase "Spaces in {}" do+ let a = 5+ let s = "string"+ [int|t|#d{ a }, #l{ s }|]+ @?= "5, string"++ ]++ , testGroup "Escaping"+ [ testCase "Newline" do+ [int|t|+ x = 1, \+ y = 2+ |] @?= "x = 1, y = 2\n"++ , testCase "Space" do+ let n = 5+ [int|t|Value: #d{n}|]+ @?= "Value: 5"++ , testCase "Slash" do+ [int|t|a \\ b|]+ @?= "a \\ b"++ , testCase "Hash" do+ [int|t|a \#{ .. }|]+ @?= "a #{ .. }"++ ]++ -------------------------------------------------------------------+ , testGroup "Switches behaviour"++ ----------------------------------+ [ testGroup "Spaces trimming"++ [ testCase "Simple test" do+ [int|ts| abc |]+ @?= "abc"++ , testCase "Multiline text" do+ [int|ts|++ abc++ sdf++ |]+ @?= "abc\n\nsdf"++ , testCase "Interpolator" do+ let n = 5+ [int|ts| #d{n} |]+ @?= "5"++ ]++ , ----------------------------------+ testGroup "Indentation stripping"++ [ testCase "Basic case" do+ [int|t|+ abc+ kek+ def+ |] @?= "abc\n kek\ndef\n"++ , testCase "The first line does not break IS" do+ [int|t|abc+ kek+ def+ |] @?= "abc\n kek\ndef\n"++ , testCase "Putting quoter end eariler does not affect IS" do+ [int|t|+ abc+ kek+ def+ |] @?= "abc\n kek\ndef\n"+++ , testCase "Putting quoter end later does not affect IS" do+ [int|t|+ abc+ kek+ def+ |] @?= "abc\n kek\ndef\n"++ , testCase "Indentation stripping disabling works" do+ [int|tD|+ abc+ kek+ def+ |]+ @?= " abc\n kek\n def\n"++ ]++ ----------------------------------+ , testGroup "Leading newline stripping"++ [ testCase "Simple multiline text" do+ [int|tA|+ Abc+ def+ |]+ @?= "\nAbc\ndef\n"+++ , testCase "The first non-empty line affects indentation of other text" do+ [int|tA|+ Abc+ def+ |]+ @?= "\nAbc\n def\n"++ ]+++ ----------------------------------+ , testGroup "Trailing spaces stripping"++ [ testCase "Simple multiline text" do+ [int|tZ|+ Abc+ |]+ @?= "Abc\n"++ , testCase "Extra spaces at end" do+ [int|tZ|+ Abc+ |]+ @?= "Abc\n "++ , testCase "Affects indentation of other text" do+ [int|tZ|+ Abc+ |]+ @?= " Abc\n"++ ]++ ----------------------------------+ , testGroup "Newlines reduction"++ [ testCase "Basic case" do+ let theVeryLongVariableNoOneKnowsWhyButWhyNot = "a"+ let anotherVeryLongVariableIsThereAReasonToGoLikeThisMmm = "b"+ [int|tn|+ X=#l{theVeryLongVariableNoOneKnowsWhyButWhyNot},+ x=#l{anotherVeryLongVariableIsThereAReasonToGoLikeThisMmm}++ Yyy++++ Zzzz+ |] @?= "X=a, x=b\nYyy\n\n\nZzzz"++ , testCase "Multiline code" do+ let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = "a"+ [int|tn|+ X = #l{+ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa+ }+ yep.++ |] @?= "X = a yep.\n"++ , testCase "No surrounding newlines" do+ [int|tn|Abc++ def|] @?= "Abc\ndef"++ ]++ ----------------------------------+ , testGroup "Monadic"++ [ testCase "Arrow monad" do+ [int|tm|(#d{fst}, #d{snd})|] (1, 2)+ @?= "(1, 2)"++ , testCase "Reader monad" do+ [int|tm|Env: #d{ask}|] `runReader` 1+ @?= "Env: 1"++ , testCase "No interpolated values" do+ [int|tm|Abc|]+ @?= Identity "Abc"++ ]++ ----------------------------------+ , testGroup "Return type"++ [ testCase "Polymorphic" do+ [int||Abc|]+ @?= ("Abc" :: Text)++ , testCase "Text" do+ cast [int|t|Abc|]+ @?= ("Abc" :: Text)++ , testCase "Lazy text" do+ cast [int|T|Abc|]+ @?= ("Abc" :: LT.Text)++ , testCase "Text" do+ cast [int|b|Abc|]+ @?= ("Abc" :: Builder)++ , testCase "String (via polymorphic)" do+ [int||Abc|]+ @?= ("Abc" :: String)++ ]++ ]++ ]++-- test_ManagingDefaultSwitches :: TestTree+-- test_ManagingDefaultSwitches = testGroup "Managing default switches"+-- [ testCase "Spacing enabled by default" do+-- let dsopts = defaultInterpolatorOptions+-- { defaultSwitchesOptions = basicDefaultSwitchesOptions+-- { defSpacesTrimming = Just True+-- }+-- }+-- let intc = mkInt dsOpts+-- [intc|ts| abc |] @?= "abc"+-- ]++test_HaskellEnvironment :: TestTree+test_HaskellEnvironment = testGroup "Haskell environment"+ [ testGroup "Overloaded labels"+ [ -- TODO+ ]++ ]
+ tests/Test/Parser.hs view
@@ -0,0 +1,139 @@+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>+--+-- SPDX-License-Identifier: MPL-2.0++-- | Tests on the parser.+module Test.Parser where++import Control.Monad (forM_)+import Data.Either (isLeft)+import qualified Data.Text as T+import Test.HUnit ((@?=))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)++import Text.Interpolation.Nyan.Core.Internal.Base+import Text.Interpolation.Nyan.Core.Internal.Parser++import Test.Util++test_TextParser :: TestTree+test_TextParser = testGroup "Main text parser"+ let parse txt =+ fmap snd $ parseIntString basicDefaultSwitchesOptions ("|" <> txt)+ in++ [ testCase "Simple text" do+ parse "abc"+ @?= Right [PipString "abc"]++ , testGroup "Interpolators"+ [ testCase "Several interpolators" do+ parse "abc #{x1} dsf #{x2}"+ @?= Right+ [ PipString "abc "+ , PipInt IntData{ idMode = "", idCode = "x1" }+ , PipString " dsf "+ , PipInt IntData{ idMode = "", idCode = "x2" }+ ]++ , testCase "Interpolator at start" do+ parse "#{a}"+ @?= Right+ [ PipInt IntData{ idMode = "", idCode = "a" }+ ]++ , testCase "Interpolator mode" do+ parse "X #a{x1} #b_1{x2} "+ @?= Right+ [ PipString "X "+ , PipInt IntData{ idMode = "a", idCode = "x1" }+ , PipString " "+ , PipInt IntData{ idMode = "b_1", idCode = "x2" }+ , PipString " "+ ]++ , testCase "Adjacent interpolators" do+ parse "A#a{x1}#b{x2}Z"+ @?= Right+ [ PipString "A"+ , PipInt IntData{ idMode = "a", idCode = "x1" }+ , PipInt IntData{ idMode = "b", idCode = "x2" }+ , PipString "Z"+ ]++ , testGroup "Should not recognize as interpolator" $+ let assertRecognizedAsString txt =+ parse txt @?= Right [PipString txt]+ in+ [ testCase "Space after #" do+ assertRecognizedAsString "A # {val}"++ , testCase "Trailing #" do+ assertRecognizedAsString "Text #"++ , testCase "Trailing # with text" do+ assertRecognizedAsString "Text #abc"++ , testCase "Punctuation after #" do+ forM_ ['(', ',', '.', '%'] \c ->+ assertRecognizedAsString ("Val #a" <> T.singleton c <> "q{value}")++ ]++ , testCase "Multiple #" do+ parse "##{a}"+ @?= Right+ [ PipString "#"+ , PipInt IntData{ idMode = "", idCode = "a" }+ ]++ , testCase "Escaped }" do+ parse "Value #{ abc \\} def }"+ @?= Right+ [ PipString "Value "+ , PipInt IntData{ idMode = "", idCode = " abc } def " }+ ]++ , testCase "Escaped slash before interpolator" do+ parse "\\\\#{code}"+ @?= Right+ [ PipString "\\"+ , PipInt IntData{ idMode = "", idCode = "code" }+ ]++ , testCase "No enclosing }" do+ parse "Value #{ abc "+ @? isLeft+ ]++ , testCase "Leading newline" do+ parse "\nabc"+ @?= Right+ [ PipNewline "\n"+ , PipString "abc"+ ]++ ]++-- TODO: spaces stripping is very interesting+++basicSwitchesOptions :: SwitchesOptions+basicSwitchesOptions =+ SwitchesOptions False False False False AnyFromBuilder False False PreviewNone++test_SwitchesParser :: TestTree+test_SwitchesParser = testGroup "Switches parser"+ let parse switchesTxt defSOpts =+ fmap fst $ parseIntString defSOpts (switchesTxt <> "|")+ in++ [ testCase "No switches" do+ parse ""+ basicDefaultSwitchesOptions+ @?=+ Right basicSwitchesOptions+++ ]
+ tests/Test/Processor.hs view
@@ -0,0 +1,33 @@+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>+--+-- SPDX-License-Identifier: MPL-2.0++-- | Tests on the processor stage.+module Test.Processor where++import Test.HUnit ((@?=))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)++import Text.Interpolation.Nyan.Core.Internal.Base+import Text.Interpolation.Nyan.Core.Internal.Parser+import Text.Interpolation.Nyan.Core.Internal.Processor++test_Processed :: TestTree+test_Processed = testGroup "Parsed + processed text"+ let handle txt defSOpts = do+ (sopts, istr) <- parseIntString defSOpts txt+ return $ processIntString sopts istr+ in++ [ testCase "Empty text" do+ handle "|"+ basicDefaultSwitchesOptions+ @?= Right []++ , testCase "Simple text" do+ handle "|abc"+ basicDefaultSwitchesOptions+ @?= Right [IpString "abc"]++ ]
+ tests/Test/Util.hs view
@@ -0,0 +1,100 @@+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>+--+-- SPDX-License-Identifier: MPL-2.0++module Test.Util where++import Control.Monad (guard)+import Control.Monad.Except (ExceptT, runExceptT, throwError)+import Control.Monad.Reader (ReaderT, asks, runReaderT)+import Control.Monad.Trans (MonadIO, lift)+import Control.Monad.Writer (WriterT, runWriterT, tell)+import Data.Functor (($>))+import Data.Text (Text)+import qualified Data.Text as T+import Data.Tuple (swap)+import GHC.Stack (HasCallStack)+import Language.Haskell.TH.Syntax (Extension (..), Quasi (..), mkName)+import Test.HUnit (Assertion, assertFailure)++import Text.Interpolation.Nyan.Core++-- * HUnit helpers++(@?) :: HasCallStack => a -> (a -> Bool) -> Assertion+(@?) r p = if p r then pure () else assertFailure "Predicate does not hold"++-- * Working with Q monad++data QReport+ = QRWarning String+ | QRError String+ deriving stock (Show, Eq)++data QOpts = QOpts+ { qoOverloadedStringsEnabled :: Bool+ , qoAvailableVariables :: [Text]+ }++defQOpts :: QOpts+defQOpts = QOpts+ { qoOverloadedStringsEnabled = True+ , qoAvailableVariables = mempty+ }++newtype TestQ a = TestQ { unTestQ :: ReaderT QOpts (ExceptT String (WriterT [QReport] IO)) a }+ deriving newtype (Functor, Applicative, Monad, MonadIO)++runTestQ' :: QOpts -> TestQ a -> IO ([QReport], Either String a)+runTestQ' qopts = fmap swap . runWriterT . runExceptT . flip runReaderT qopts . unTestQ++runTestQ :: TestQ a -> IO (Either String a)+runTestQ = fmap snd . runTestQ' defQOpts++instance MonadFail TestQ where+ fail = TestQ . throwError++liftToTestQ :: IO a -> TestQ a+liftToTestQ = TestQ . lift . lift . lift++instance Quasi TestQ where+ qReport True msg = TestQ $ tell [QRError msg]+ qReport False msg = TestQ $ tell [QRWarning msg]++ qRecover = error "not implemented"++ qIsExtEnabled = \case+ OverloadedStrings -> TestQ $ asks qoOverloadedStringsEnabled+ other -> error $ "Asked for extension " <> show other+ qExtsEnabled = error "not implemented"++ qLookupName _cond name = TestQ do+ vars <- asks qoAvailableVariables+ return $ guard (T.pack name `elem` vars) $> mkName name++ qNewName a = liftToTestQ $ qNewName a+ qReify a = liftToTestQ $ qReify a+ qReifyFixity a = liftToTestQ $ qReifyFixity a+ qReifyType a = liftToTestQ $ qReifyType a+ qReifyInstances a b = liftToTestQ $ qReifyInstances a b+ qReifyRoles a = liftToTestQ $ qReifyRoles a+ qReifyAnnotations a = liftToTestQ $ qReifyAnnotations a+ qReifyModule a = liftToTestQ $ qReifyModule a+ qReifyConStrictness a = liftToTestQ $ qReifyConStrictness a+ qLocation = liftToTestQ qLocation+ qRunIO a = liftToTestQ $ qRunIO a+ qAddDependentFile a = liftToTestQ $ qAddDependentFile a+ qAddTempFile a = liftToTestQ $ qAddTempFile a+ qAddTopDecls a = liftToTestQ $ qAddTopDecls a+ qAddForeignFilePath a b = liftToTestQ $ qAddForeignFilePath a b+ qAddModFinalizer a = liftToTestQ $ qAddModFinalizer a+ qAddCorePlugin a = liftToTestQ $ qAddCorePlugin a+ qGetQ = liftToTestQ qGetQ+ qPutQ a = liftToTestQ $ qPutQ a++-- * Interpolators++int :: QuasiQuoter+int = mkInt defaultInterpolatorOptions+ { defaultSwitchesOptions = recommendedDefaultSwitchesOptions+ }
+ tests/Test/ValueInterpolators.hs view
@@ -0,0 +1,51 @@+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>+--+-- SPDX-License-Identifier: MPL-2.0++module Test.ValueInterpolators where++import Data.Either (isRight)+import Data.Text (Text)+import Language.Haskell.TH (runQ)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Test.Util+import Text.Interpolation.Nyan.Core++tryValueInterpolator :: ValueInterpolator -> [Text] -> Text -> IO (Bool, [QReport])+tryValueInterpolator vint varsInScope txt = do+ (reports, res) <-+ runTestQ' defQOpts{ qoAvailableVariables = varsInScope } . runQ $+ runValueInterpolator vint txt+ return (isRight res, reports)++test_SimpleValueInterpolator :: TestTree+test_SimpleValueInterpolator = testGroup "simpleValueInterpolator"+ let check = tryValueInterpolator simpleValueInterpolator+ in+ [ testCase "Simple value" do+ res <- check ["value"] "value"+ res @?= (True, [])++ ,testCase "Value not in scope" do+ res <- check [] "value"+ res @?= (False, [QRError "Variable 'value' is not in scope"])++ , testCase "Value with valid variable chars" do+ res <- check ["value12'_asd"] "value12'_asd"+ res @?= (True, [])++ , testCase "Value surrounded by spaces" do+ res <- check ["value"] " value "+ res @?= (True, [])++ , testCase "Several values" do+ res <- check ["value1", "value2"] "value1 value2"+ res @?= (False, [QRError "Only passing sole variables is allowed by this interpolator"])++ , testCase "Use of $" do+ res <- check ["f", "value2"] "f $ value2"+ res @?= (False, [QRError "Only passing sole variables is allowed by this interpolator"])++ ]
+ tests/Tree.hs view
@@ -0,0 +1,5 @@+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>+--+-- SPDX-License-Identifier: MPL-2.0++{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display -optF --generated-module -optF Tree #-}
+ tests/doctests.hs view
@@ -0,0 +1,7 @@+module Main where++import System.Environment (getArgs)+import Test.DocTest (mainFromCabal)++main :: IO ()+main = mainFromCabal "nyan-interpolation-core" =<< getArgs