├── Setup.hs ├── cabal.project ├── .gitignore ├── cabal.haskell-ci ├── src ├── Data │ ├── DList.hs │ ├── YAML │ │ ├── Schema.hs │ │ ├── Pos.hs │ │ ├── Internal.hs │ │ ├── Dumper.hs │ │ ├── Event │ │ │ ├── Internal.hs │ │ │ └── Writer.hs │ │ ├── Loader.hs │ │ ├── Token │ │ │ └── Encoding.hs │ │ └── Schema │ │ │ └── Internal.hs │ └── YAML.hs └── Util.hs ├── README.md ├── CONTRIBUTING.md ├── .github └── workflows │ ├── stack.yml │ └── haskell-ci.yml ├── tests └── Tests.hs ├── ChangeLog.md ├── HsYAML.cabal ├── src-test ├── TML.hs └── Main.hs └── LICENSE.GPLv2 /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | package HsYAML 4 | flags: +exe 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /dist/ 2 | /dist-newstyle/ 3 | /.ghc.environment.* 4 | /.stack-work/ 5 | /stack*.yaml.lock 6 | *~ 7 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | branches: master 2 | installed: +all 3 | 4 | constraint-set containers-0.8 5 | ghc: >= 8.2 6 | constraints: containers ^>=0.8 7 | tests: True 8 | run-tests: True 9 | 10 | raw-project 11 | allow-newer: containers 12 | -------------------------------------------------------------------------------- /src/Data/DList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | -- | 4 | -- Copyright: © Herbert Valerio Riedel 2018 5 | -- SPDX-License-Identifier: GPL-2.0-or-later 6 | -- 7 | -- Minimal API-compatible rip-off of @Data.DList@ 8 | module Data.DList 9 | ( DList 10 | , empty 11 | , singleton 12 | , append 13 | , toList 14 | ) where 15 | 16 | -- | A difference list is a function that, given a list, returns the original 17 | -- contents of the difference list prepended to the given list. 18 | newtype DList a = DList ([a] -> [a]) 19 | 20 | -- | Convert a dlist to a list 21 | toList :: DList a -> [a] 22 | toList (DList dl) = dl [] 23 | 24 | -- | Create dlist with a single element 25 | singleton :: a -> DList a 26 | singleton x = DList (x:) 27 | 28 | -- | Create a dlist containing no elements 29 | empty :: DList a 30 | empty = DList id 31 | 32 | -- | O(1). Append dlists 33 | append :: DList a -> DList a -> DList a 34 | append (DList xs) (DList ys) = DList (xs . ys) 35 | -------------------------------------------------------------------------------- /src/Data/YAML/Schema.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE Safe #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | -- | 7 | -- Copyright: © Herbert Valerio Riedel 2015-2018 8 | -- SPDX-License-Identifier: GPL-2.0-or-later 9 | -- 10 | -- Predefined YAML 1.2 Schema resolvers and encoders as well as support for defining custom resolvers and encoders. 11 | -- 12 | -- @since 0.2.0.0 13 | module Data.YAML.Schema 14 | ( -- * Schema resolvers 15 | -- ** YAML 1.2 Schema resolvers 16 | SchemaResolver(..) 17 | , failsafeSchemaResolver 18 | , jsonSchemaResolver 19 | , coreSchemaResolver 20 | 21 | -- * Schema encoders 22 | -- ** YAML 1.2 Schema encoders 23 | , SchemaEncoder(..) 24 | , failsafeSchemaEncoder 25 | , jsonSchemaEncoder 26 | , coreSchemaEncoder 27 | 28 | -- ** Custom Schema encoding 29 | -- 30 | -- | According to YAML 1.2 the recommended default 'SchemaEncoder' is 'coreSchemaEncoder' under which 'Scalar's are encoded as follows: 31 | -- 32 | -- * String which are made of Plain Characters (see 'isPlainChar'), unambiguous (see 'isAmbiguous') and do not contain any leading/trailing spaces are encoded as 'Data.YAML.Event.Plain' 'Scalar'. 33 | -- 34 | -- * Rest of the strings are encoded in DoubleQuotes 35 | -- 36 | -- * Booleans are encoded using 'encodeBool' 37 | -- 38 | -- * Double values are encoded using 'encodeDouble' 39 | -- 40 | -- * Integral values are encoded using 'encodeInt' 41 | -- 42 | , setScalarStyle 43 | , isPlainChar 44 | , isAmbiguous 45 | , encodeDouble 46 | , encodeBool 47 | , encodeInt 48 | ) where 49 | 50 | import Data.YAML.Schema.Internal 51 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Hackage](https://img.shields.io/hackage/v/HsYAML.svg?label=Hackage&color=informational)](https://hackage.haskell.org/package/HsYAML) 2 | [![Cabal build](https://github.com/haskell-hvr/HsYAML/workflows/Haskell-CI/badge.svg)](https://github.com/haskell-hvr/HsYAML/actions) 3 | 4 | # `HsYAML`: A Pure Haskell YAML 1.2 processor 5 | 6 | ## About 7 | 8 | * HsYAML is a [YAML 1.2](https://yaml.org/spec/1.2/spec.html) processor implementation for Haskell. 9 | * It is in strict compliance with [YAML 1.2](https://yaml.org/spec/1.2/spec.html) grammer rules. 10 | * HsYAML is tested using [YAML-Test-Suite](https://github.com/yaml/yaml-test-suite) and some other tests which can be found [here](https://github.com/haskell-hvr/HsYAML/tree/0.2/tests). 11 | * See HsYAML's performance on [YAML-Test-Matrix](https://matrix.yaml.io) which combines all tests from [YAML-Test-Suite](https://github.com/yaml/yaml-test-suite) and performance of all processors from [yaml-editor](https://github.com/yaml/yaml-editor). 12 | * See what's changed in recent (and upcoming) releases [here](https://github.com/haskell-hvr/HsYAML/blob/0.2/ChangeLog.md). 13 | 14 | ## Documentation 15 | The primary API documentation for `HsYAML` is its Haddock documentation which can be found [here](http://hackage.haskell.org/package/HsYAML). 16 | 17 | ## Installation 18 | 19 | Install the `HsYAML` package. 20 | ``` 21 | cabal install HsYAML 22 | ``` 23 | 24 | See [dependencies](http://hackage.haskell.org/package/HsYAML). 25 | 26 | ## Contribution 27 | 28 | When contributing to this repository, please read the set of guidelines mentioned in [CONTRIBUTING.md](CONTRIBUTING.md). 29 | Feel free to report bugs, documentation enhancements, and other improvements. 30 | 31 | ## Developers and Maintainers 32 | 33 | The library is developed and maintained by [Herbert Valerio Riedel](https://github.com/hvr) 34 | 35 | # License 36 | 37 | This project is licensed under X-SPDX-License-Identifier: [GPL-2.0-or-later](https://spdx.org/licenses/GPL-2.0-or-later.html) 38 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contribution Guidelines 2 | 3 | ## Issue Tracker & Bug Reporting 4 | 5 | - Try to provide simple examples demonstrating the issue at hand; describe what happened as well as what you would have expected to happen instead. 6 | 7 | - Reproduction-instructions shall be expressed in terms of Haskell.org's standard tooling (i.e. `cabal`). 8 | 9 | - Be aware this is a F/OSS project; the software is provided "as is" for no charge and you're entitled in terms of support to what you payed for. 10 | 11 | ## Coding Guidelines 12 | 13 | - Try to follow the pre-existing indentation style; avoid tabs for indentation; avoid trailing whitespace; if in doubt, try to follow [this style guide](https://github.com/hvr/haskell-style-guide/blob/master/haskell-style.md) 14 | 15 | - Development & support is done primarily using Haskell.org's standard tooling, i.e. `cabal`; we don't have time & energy to support everyone's favourite third-party tooling. 16 | 17 | - Haskell packages are subject to the [Haskell Package Versioning Policy](https://pvp.haskell.org/) which governs both the API versioning as well as the specification of dependency versions. 18 | 19 | - Generally, only properly released major versions of tools and libraries are actively supported in Hackage releases; this is reflected in the dependency version constraints (see also previous item). 20 | 21 | - When relaxing upper bounds for dependencies in order to declare compatibility with new major versions, it's **not** sufficient to merely rely on CI; make sure to review the API changes prompting the major version increment to ensure that the version relaxation is indeed safe/sound. 22 | 23 | ## Pull Request Process 24 | 25 | ### We Use [Github Flow](https://guides.github.com/introduction/flow/index.html), So All Code Changes Happen Through Pull Requests 26 | 27 | Pull requests are the best way to propose changes to the codebase. 28 | We actively welcome your pull requests: 29 | 30 | 1. Fork the repo and create your branch from `master`. 31 | 2. If you've changed APIs, update the documentation. 32 | 3. Ensure the test suite passes. See the testing-process below. 33 | 4. Issue that pull request! 34 | 35 | ### Testing 36 | 37 | Browse to the directory where all the files of this repository are located. 38 | Run the following command to see if the changes satisfy the tests. 39 | 40 | ```cabal test``` 41 | 42 | HsYAML is also tested using [YAML-Test-Suite](https://github.com/yaml/yaml-test-suite). 43 | Run the following list of commands to see the updated performance on YAML-Test-Suite and mention the results in the pull request. 44 | 45 | * Download/Clone the [YAML-Test-Suite](https://github.com/yaml/yaml-test-suite) repository. 46 | ``` 47 | git clone https://github.com/yaml/yaml-test-suite.git 48 | ``` 49 | * Run the following commands to see the updated results 50 | ``` 51 | cabal run yaml-test run-tml yaml-test-suite/test/*.tml 52 | ``` 53 | You will see some output like 54 | ``` 55 | done -- passed: 316 (ev: 32, ev+json: 93, ev+json+yaml: 120, err: 71) / failed: 2 (err: 2, ev:0, json:0, yaml:0, ok:0) 56 | ``` -------------------------------------------------------------------------------- /.github/workflows/stack.yml: -------------------------------------------------------------------------------- 1 | name: Stack build 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | pull_request: 8 | branches: 9 | - master 10 | 11 | defaults: 12 | run: 13 | shell: bash 14 | 15 | jobs: 16 | stack: 17 | name: ${{ matrix.os }} Stack ${{ matrix.plan.resolver }} / ${{ matrix.plan.ghc }} 18 | strategy: 19 | fail-fast: false 20 | matrix: 21 | os: [ubuntu-latest] 22 | plan: 23 | - ghc: '9.10.2' 24 | resolver: 'nightly-2025-06-18' 25 | - ghc: '9.8.4' 26 | resolver: 'lts-23.25' 27 | - ghc: '9.6.7' 28 | resolver: 'lts-22.44' 29 | - ghc: '9.4.8' 30 | resolver: 'lts-21.25' 31 | - ghc: '9.2.8' 32 | resolver: 'lts-20.26' 33 | - ghc: '9.0.2' 34 | resolver: 'lts-19.33' 35 | - ghc: '8.10.7' 36 | resolver: 'lts-18.28' 37 | - ghc: '8.8.4' 38 | resolver: 'lts-16.31' 39 | - ghc: '8.6.5' 40 | resolver: 'lts-14.27' 41 | - ghc: '8.4.4' 42 | resolver: 'lts-12.26' 43 | # Stack 3 dropped support for GHC 8.2 44 | # - ghc: '8.2.2' 45 | # resolver: 'lts-11.22' 46 | # LTS 9.21 does not have recent enough parsec and test 47 | # - ghc: '8.0.2' 48 | # resolver: 'lts-9.21' 49 | 50 | include: 51 | - os: windows-latest 52 | plan: 53 | ghc: '9.10.2' 54 | resolver: 'nightly-2025-06-18' 55 | 56 | - os: macos-latest 57 | plan: 58 | ghc: '9.10.2' 59 | resolver: 'nightly-2025-06-18' 60 | 61 | runs-on: ${{ matrix.os }} 62 | env: 63 | STACK: stack --system-ghc --no-terminal --resolver ${{ matrix.plan.resolver }} 64 | 65 | steps: 66 | - uses: actions/checkout@v4 67 | 68 | - uses: haskell-actions/setup@latest 69 | id: setup 70 | with: 71 | ghc-version: ${{ matrix.plan.ghc }} 72 | enable-stack: true 73 | cabal-update: false 74 | 75 | - uses: actions/cache/restore@v4 76 | id: cache 77 | env: 78 | key: ${{ runner.os }}-stack-${{ steps.setup.outputs.stack-version }}-ghc-${{ steps.setup.outputs.ghc-version }} 79 | with: 80 | path: ${{ steps.setup.outputs.stack-root }} 81 | key: ${{ env.key }}-${{ github.sha }} 82 | restore-keys: ${{ env.key }}- 83 | 84 | - name: Configure 85 | run: $STACK init 86 | 87 | - name: Install dependencies 88 | run: $STACK test --only-dependencies 89 | 90 | - name: Build 91 | run: $STACK test --haddock --no-haddock-deps --no-run-tests 92 | 93 | - name: Test 94 | run: $STACK -j 1 test --haddock --no-haddock-deps 95 | 96 | - uses: actions/cache/save@v4 97 | if: always() && steps.cache.outputs.cache-hit != 'true' 98 | with: 99 | path: ${{ steps.setup.outputs.stack-root }} 100 | key: ${{ steps.cache.outputs.cache-primary-key }} 101 | -------------------------------------------------------------------------------- /src/Data/YAML/Pos.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE Safe #-} 6 | 7 | -- | 8 | -- Copyright: © Herbert Valerio Riedel 2015-2018 9 | -- SPDX-License-Identifier: GPL-2.0-or-later 10 | -- 11 | module Data.YAML.Pos 12 | ( Pos(..) 13 | , prettyPosWithSource 14 | ) where 15 | 16 | import qualified Data.ByteString.Lazy as BL 17 | import qualified Data.YAML.Token.Encoding as Enc 18 | import Util 19 | 20 | -- | Position in parsed YAML source 21 | -- 22 | -- See also 'prettyPosWithSource'. 23 | -- 24 | -- __NOTE__: if 'posCharOffset' is negative the 'Pos' value doesn't refer to a proper location; this may be emitted in corner cases when no proper location can be inferred. 25 | data Pos = Pos 26 | { posByteOffset :: !Int -- ^ 0-based byte offset 27 | , posCharOffset :: !Int -- ^ 0-based character (Unicode code-point) offset 28 | , posLine :: !Int -- ^ 1-based line number 29 | , posColumn :: !Int -- ^ 0-based character (Unicode code-point) column number 30 | } deriving (Eq, Show, Generic) 31 | 32 | -- | @since 0.2.0 33 | instance NFData Pos where rnf !_ = () 34 | 35 | -- | Pretty prints a 'Pos' together with the line the 'Pos' refers and the column position. 36 | -- 37 | -- The input 'BL.ByteString' must be the same that was passed to the 38 | -- YAML decoding function that produced the 'Pos' value. The 'String' 39 | -- argument is inserted right after the @::@ in the 40 | -- first line. The pretty-printed position result 'String' will be 41 | -- terminated by a trailing newline. 42 | -- 43 | -- For instance, 44 | -- 45 | -- @ 46 | -- 'prettyPosWithSource' somePos someInput " error" ++ "unexpected character\\n" 47 | -- @ results in 48 | -- 49 | -- > 11:7: error 50 | -- > | 51 | -- > 11 | foo: | bar 52 | -- > | ^ 53 | -- > unexpected character 54 | -- 55 | -- @since 0.2.1 56 | prettyPosWithSource :: Pos -> BL.ByteString -> String -> String 57 | prettyPosWithSource Pos{..} source msg 58 | | posCharOffset < 0 || posByteOffset < 0 = "0:0:" ++ msg ++ "\n" -- unproper location 59 | | otherwise = unlines 60 | [ show posLine ++ ":" ++ show posColumn ++ ":" ++ msg 61 | , lpfx 62 | , lnostr ++ "| " ++ line 63 | , lpfx ++ replicate posColumn ' ' ++ "^" 64 | ] 65 | 66 | where 67 | lnostr = " " ++ show posLine ++ " " 68 | lpfx = (' ' <$ lnostr) ++ "| " 69 | 70 | (_,lstart) = findLineStartByByteOffset posByteOffset source 71 | line = map snd $ takeWhile (not . isNL . snd) lstart 72 | 73 | isNL c = c == '\r' || c == '\n' 74 | 75 | findLineStartByByteOffset :: Int -> BL.ByteString -> (Int,[(Int,Char)]) 76 | findLineStartByByteOffset bofs0 input = go 0 inputChars inputChars 77 | where 78 | (_,inputChars) = Enc.decode input 79 | 80 | go lsOfs lsChars [] = (lsOfs,lsChars) 81 | go lsOfs lsChars ((ofs',_):_) 82 | | bofs0 < ofs' = (lsOfs,lsChars) 83 | 84 | go _ _ ((_,'\r'):(ofs','\n'):rest) = go ofs' rest rest 85 | go _ _ ((ofs','\r'):rest) = go ofs' rest rest 86 | go _ _ ((ofs','\n'):rest) = go ofs' rest rest 87 | go lsOfs lsChars (_:rest) = go lsOfs lsChars rest 88 | -------------------------------------------------------------------------------- /src/Data/YAML/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE Safe #-} 3 | 4 | -- | 5 | -- Copyright: © Herbert Valerio Riedel 2015-2018 6 | -- SPDX-License-Identifier: GPL-2.0-or-later 7 | -- 8 | module Data.YAML.Internal 9 | ( Node(..) 10 | , nodeLoc 11 | , NodeId 12 | , Doc(..) 13 | , Mapping 14 | ) where 15 | 16 | import qualified Data.Map as Map 17 | 18 | import Data.YAML.Event (Tag) 19 | import Data.YAML.Loader (NodeId) 20 | import Data.YAML.Schema.Internal (Scalar (..)) 21 | 22 | import Util 23 | 24 | -- | YAML Document tree/graph 25 | -- 26 | -- __NOTE__: In future versions of this API meta-data about the YAML document might be included as additional fields inside 'Doc' 27 | newtype Doc n = Doc 28 | { docRoot :: n -- ^ @since 0.2.1 29 | } deriving (Eq,Ord,Show,Generic) 30 | 31 | -- | @since 0.2.0 32 | instance NFData n => NFData (Doc n) where 33 | rnf (Doc n) = rnf n 34 | 35 | -- | @since 0.2.1 36 | instance Functor Doc where 37 | fmap f (Doc n) = Doc (f n) 38 | x <$ _ = Doc x 39 | 40 | -- | YAML mapping 41 | type Mapping loc = Map (Node loc) (Node loc) 42 | 43 | -- | YAML Document node 44 | -- 45 | -- @since 0.2.0 46 | data Node loc 47 | = Scalar !loc !Scalar 48 | | Mapping !loc !Tag (Mapping loc) 49 | | Sequence !loc !Tag [Node loc] 50 | | Anchor !loc !NodeId !(Node loc) 51 | deriving (Show,Generic) 52 | 53 | nodeLoc :: Node loc -> loc 54 | nodeLoc (Scalar pos _) = pos 55 | nodeLoc (Anchor pos _ _) = pos 56 | nodeLoc (Mapping pos _ _) = pos 57 | nodeLoc (Sequence pos _ _) = pos 58 | 59 | instance Functor Node where 60 | fmap f node = case node of 61 | Scalar x scalar -> Scalar (f x) scalar 62 | Mapping x tag m -> Mapping (f x) tag (mappingFmapLoc f m) 63 | Sequence x tag s -> Sequence (f x) tag (map (fmap f) s) 64 | Anchor x n nod -> Anchor (f x) n (fmap f nod) 65 | 66 | mappingFmapLoc :: (a -> b) -> Mapping a -> Mapping b 67 | mappingFmapLoc f = Map.mapKeysMonotonic (fmap f) . Map.map (fmap f) 68 | 69 | instance Eq (Node loc) where 70 | Scalar _ a == Scalar _ a' = a == a' 71 | Mapping _ a b == Mapping _ a' b' = a == a' && b == b' 72 | Sequence _ a b == Sequence _ a' b' = a == a' && b == b' 73 | Anchor _ a b == Anchor _ a' b' = a == a' && b == b' 74 | _ == _ = False 75 | 76 | instance Ord (Node loc) where 77 | compare (Scalar _ a) (Scalar _ a') = compare a a' 78 | compare (Scalar _ _) (Mapping _ _ _) = LT 79 | compare (Scalar _ _) (Sequence _ _ _) = LT 80 | compare (Scalar _ _) (Anchor _ _ _) = LT 81 | 82 | compare (Mapping _ _ _) (Scalar _ _) = GT 83 | compare (Mapping _ a b) (Mapping _ a' b') = compare (a,b) (a',b') 84 | compare (Mapping _ _ _) (Sequence _ _ _) = LT 85 | compare (Mapping _ _ _) (Anchor _ _ _) = LT 86 | 87 | compare (Sequence _ _ _) (Scalar _ _) = GT 88 | compare (Sequence _ _ _) (Mapping _ _ _) = GT 89 | compare (Sequence _ a b) (Sequence _ a' b') = compare (a,b) (a',b') 90 | compare (Sequence _ _ _) (Anchor _ _ _) = LT 91 | 92 | compare (Anchor _ _ _) (Scalar _ _) = GT 93 | compare (Anchor _ _ _) (Mapping _ _ _) = GT 94 | compare (Anchor _ _ _) (Sequence _ _ _) = GT 95 | compare (Anchor _ a b) (Anchor _ a' b') = compare (a,b) (a',b') 96 | -------------------------------------------------------------------------------- /tests/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | import Control.Monad 5 | import Control.Applicative 6 | import Data.YAML as Y 7 | import qualified Data.Text as T 8 | import qualified Data.Map as Map 9 | import qualified Data.ByteString.Lazy.Char8 as BS.L 10 | import Test.Tasty (defaultMain, TestTree, testGroup) 11 | import Test.Tasty.QuickCheck (testProperty,Arbitrary(..)) 12 | 13 | outputStr :: ToYAML a => a -> BS.L.ByteString 14 | outputStr a = BS.L.init (encode1 a) -- TODO: remove trailing newline from Writer.hs 15 | 16 | roundTripInt :: Int -> Bool 17 | roundTripInt i = BS.L.pack (show i) == outputStr i 18 | 19 | roundTripBool :: Bool -> Bool 20 | roundTripBool b 21 | | b = "true" == outputStr b 22 | | otherwise = "false" == outputStr b 23 | 24 | roundTripDouble :: Double -> Double -> Bool 25 | roundTripDouble num denom 26 | | d /= d = ".nan" == outputStr d 27 | | d == (1/0) = ".inf" == outputStr d 28 | | d == (-1/0) = "-.inf" == outputStr d 29 | | otherwise = BS.L.pack (show d) == outputStr d 30 | where d = num / denom 31 | 32 | roundTrip :: (Eq a, FromYAML a, ToYAML a) => (a -> a -> Bool) -> a -> a -> Bool 33 | roundTrip eq _ v = 34 | case decode1 (encode1 v) :: (FromYAML a) => (Either (Pos, String) a) of 35 | Left _ -> False 36 | Right ans -> ans `eq` v 37 | 38 | approxEq :: Double -> Double -> Bool 39 | approxEq a b = a == b || d < maxAbsoluteError || d / max (abs b) (abs a) <= maxRelativeError 40 | where 41 | d = abs (a - b) 42 | maxAbsoluteError = 1e-15 43 | maxRelativeError = 1e-15 44 | 45 | roundTripEq :: (Eq a, FromYAML a, ToYAML a) => a -> a -> Bool 46 | roundTripEq x y = roundTrip (==) x y 47 | 48 | main :: IO () 49 | main = defaultMain (testGroup "tests" tests) 50 | 51 | tests :: [TestTree] 52 | tests = 53 | [ testGroup "encode" 54 | [ testProperty "encodeInt" roundTripInt 55 | , testProperty "encodeBool" roundTripBool 56 | , testProperty "encodeDouble" roundTripDouble 57 | ] 58 | , testGroup "roundTrip" 59 | [ testProperty "Bool" $ roundTripEq True 60 | , testProperty "Double" $ roundTrip approxEq (1::Double) 61 | , testProperty "Int" $ roundTripEq (1::Int) 62 | , testProperty "Integer" $ roundTripEq (1::Integer) 63 | , testProperty "Text" $ roundTripEq T.empty 64 | , testProperty "Seq" $ roundTripEq ([""]:: [T.Text]) 65 | , testProperty "Map" $ roundTripEq (undefined :: Map.Map T.Text T.Text) 66 | , testProperty "Foo" $ roundTripEq (undefined :: Foo) 67 | ] 68 | ] 69 | 70 | instance Arbitrary T.Text where 71 | arbitrary = T.pack <$> arbitrary 72 | 73 | data Foo = Foo 74 | { fooBool :: Bool 75 | , fooInt :: Int 76 | , fooTuple :: (T.Text, Int) 77 | , fooSeq :: [T.Text] 78 | , fooMap :: Map.Map T.Text T.Text 79 | } deriving (Show,Eq) 80 | 81 | instance ToYAML Foo where 82 | toYAML Foo{..} = mapping [ "fooBool" .= fooBool 83 | , "fooInt" .= fooInt 84 | , "fooTuple" .= fooTuple 85 | , "fooSeq" .= fooSeq 86 | , "fooMap" .= fooMap 87 | ] 88 | 89 | instance FromYAML Foo where 90 | parseYAML = withMap "Foo" $ \m -> Foo 91 | <$> m .: "fooBool" 92 | <*> m .: "fooInt" 93 | <*> m .: "fooTuple" 94 | <*> m .: "fooSeq" 95 | <*> m .: "fooMap" 96 | 97 | instance Arbitrary Foo where 98 | arbitrary = liftM5 Foo arbitrary arbitrary arbitrary arbitrary arbitrary -------------------------------------------------------------------------------- /src/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE Safe #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 7 | 8 | -- | 9 | -- Copyright: © Herbert Valerio Riedel 2015-2018 10 | -- SPDX-License-Identifier: GPL-2.0-or-later 11 | -- 12 | module Util 13 | ( liftEither' 14 | , readMaybe 15 | , readEither 16 | , fromIntegerMaybe 17 | , (<>) 18 | 19 | , mapFromListNoDupes 20 | , mapInsertNoDupe 21 | 22 | , bsToStrict 23 | 24 | , module X 25 | ) where 26 | 27 | import Control.Applicative as X 28 | import Control.DeepSeq as X (NFData (rnf)) 29 | import Control.Monad as X 30 | import Data.Functor as X 31 | import Data.Int as X 32 | import Data.Word as X 33 | import GHC.Generics as X (Generic) 34 | import Numeric.Natural as X (Natural) 35 | 36 | import Control.Monad.Fix as X (MonadFix) 37 | import Control.Monad.Except as X (MonadError (..)) 38 | import Control.Monad.Identity as X 39 | import Control.Monad.Trans.Except as X (ExceptT (..), runExceptT) 40 | 41 | import Data.Char as X (chr, ord) 42 | import Data.Map as X (Map) 43 | import qualified Data.Map as Map 44 | import Data.Monoid as X (Monoid (mappend, mempty)) 45 | import Data.Semigroup ((<>)) 46 | import qualified Data.ByteString as BS 47 | import qualified Data.ByteString.Lazy as BS.L 48 | import Data.Set as X (Set) 49 | import Data.Text as X (Text) 50 | 51 | import Text.ParserCombinators.ReadP as P 52 | import Text.Read 53 | 54 | -- GHC 8.4.1 shipped with a phony `mtl-2.2.2` and so we have no 55 | -- bulletproof way to know when `Control.Monad.Except` exports liftEither 56 | -- or not; after NixOS managed to break an otherwise effective workaround 57 | -- I'll just throwing my hands up in the air and will consider 58 | -- `Control.Monad.Except.liftEither` scorched earth for now. 59 | liftEither' :: MonadError e m => Either e a -> m a 60 | liftEither' = either throwError return 61 | 62 | 63 | -- | Succeeds if the 'Integral' value is in the bounds of the given Data type. 64 | -- 'Nothing' indicates that the value is outside the bounds. 65 | fromIntegerMaybe :: forall n . (Integral n, Bounded n) => Integer -> Maybe n 66 | fromIntegerMaybe j 67 | | l <= j, j <= u = Just (fromInteger j) 68 | | otherwise = Nothing 69 | where 70 | u = toInteger (maxBound :: n) 71 | l = toInteger (minBound :: n) 72 | 73 | 74 | -- | A convience wrapper over 'mapInsertNoDupe' 75 | mapFromListNoDupes :: Ord k => [(k,a)] -> Either (k,a) (Map k a) 76 | mapFromListNoDupes = go mempty 77 | where 78 | go !m [] = Right m 79 | go !m ((k,!v):rest) = case mapInsertNoDupe k v m of 80 | Nothing -> Left (k,v) 81 | Just m' -> go m' rest 82 | 83 | -- | A convience wrapper over 'Data.Map.insertLookupWithKey' 84 | mapInsertNoDupe :: Ord k => k -> a -> Map k a -> Maybe (Map k a) 85 | mapInsertNoDupe kx x t = case Map.insertLookupWithKey (\_ a _ -> a) kx x t of 86 | (Nothing, m) -> Just m 87 | (Just _, _) -> Nothing 88 | 89 | 90 | -- | Equivalent to the function 'Data.ByteString.toStrict'. 91 | -- O(n) Convert a lazy 'BS.L.ByteString' into a strict 'BS.ByteString'. 92 | {-# INLINE bsToStrict #-} 93 | bsToStrict :: BS.L.ByteString -> BS.ByteString 94 | bsToStrict = BS.L.toStrict 95 | -------------------------------------------------------------------------------- /src/Data/YAML/Dumper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE Safe #-} 4 | 5 | -- | 6 | -- Copyright: © Herbert Valerio Riedel 2015-2018 7 | -- SPDX-License-Identifier: GPL-2.0-or-later 8 | -- 9 | module Data.YAML.Dumper 10 | ( encodeNode 11 | , encodeNode' 12 | ) where 13 | 14 | import Data.YAML.Event.Internal as YE 15 | import Data.YAML.Event.Writer (writeEvents) 16 | import Data.YAML.Internal as YI 17 | import Data.YAML.Schema.Internal as YS 18 | 19 | import qualified Data.ByteString.Lazy as BS.L 20 | import qualified Data.Map as Map 21 | import qualified Data.Text as T 22 | 23 | -- internal 24 | type EvList = [Either String Event] 25 | type Node2EvList = [Node ()] -> EvList 26 | 27 | -- | Dump YAML Nodes as a lazy 'UTF8' encoded 'BS.L.ByteString' 28 | -- 29 | -- Each YAML 'Node' is emitted as a individual YAML Document where each Document is terminated by a 'DocumentEnd' indicator. 30 | -- 31 | -- This is a convenience wrapper over `encodeNode'` 32 | -- 33 | -- @since 0.2.0 34 | encodeNode :: [Doc (Node ())] -> BS.L.ByteString 35 | encodeNode = encodeNode' coreSchemaEncoder UTF8 36 | 37 | -- | Customizable variant of 'encodeNode' 38 | -- 39 | -- __NOTE__: A leading will be emitted for all encodings /other than/ 'UTF8'. 40 | -- 41 | -- @since 0.2.0 42 | encodeNode' :: SchemaEncoder -> Encoding -> [Doc (Node ())] -> BS.L.ByteString 43 | encodeNode' SchemaEncoder{..} encoding nodes = writeEvents encoding $ map getEvent (dumpEvents (map docRoot nodes)) 44 | where 45 | 46 | getEvent :: Either String Event -> Event 47 | getEvent = \x -> case x of 48 | Right ev -> ev 49 | Left str -> error str 50 | 51 | dumpEvents :: Node2EvList 52 | dumpEvents nodes' = Right StreamStart: go0 nodes' 53 | where 54 | go0 :: [Node ()] -> EvList 55 | go0 [] = [Right StreamEnd] 56 | go0 n = Right (DocumentStart NoDirEndMarker): goNode (0 :: Int) n (\ev -> go0 ev) 57 | 58 | 59 | goNode :: Int -> [Node ()] -> Node2EvList -> EvList 60 | goNode _ [] _ = [Left "Dumper: unexpected pattern in goNode"] 61 | goNode lvl (node: rest) cont = case node of 62 | YI.Scalar _ scalar -> goScalar scalar Nothing: isDocEnd lvl rest cont 63 | Mapping _ tag m -> Right (MappingStart Nothing (getTag schemaEncoderMapping tag) Block) : goMap (lvl + 1) m rest cont 64 | Sequence _ tag s -> Right (SequenceStart Nothing (getTag schemaEncoderSequence tag) Block) : goSeq (lvl + 1) s rest cont 65 | Anchor _ nid n -> goAnchor lvl nid n rest cont 66 | 67 | goScalar :: YS.Scalar -> Maybe Anchor -> Either String Event 68 | goScalar s anc = case schemaEncoderScalar s of 69 | Right (t, sty, text) -> Right (YE.Scalar anc t sty text) 70 | Left err -> Left err 71 | 72 | goMap :: Int -> Mapping () -> [Node ()] -> Node2EvList -> EvList 73 | goMap lvl m rest cont = case (mapToList m) of 74 | [] -> Right MappingEnd : isDocEnd (lvl - 1) rest cont 75 | list -> goNode lvl list g 76 | where 77 | g [] = Right MappingEnd : isDocEnd (lvl - 1) rest cont 78 | g rest' = goNode lvl rest' g 79 | mapToList = Map.foldrWithKey (\k v a -> k : v : a) [] 80 | 81 | goSeq :: Int -> [Node ()] -> [Node ()] -> Node2EvList -> EvList 82 | goSeq lvl [] rest cont = Right SequenceEnd : isDocEnd (lvl - 1) rest cont 83 | goSeq lvl nod rest cont = goNode lvl nod g 84 | where 85 | g [] = Right SequenceEnd : isDocEnd (lvl - 1) rest cont 86 | g rest' = goNode lvl rest' g 87 | 88 | goAnchor :: Int -> NodeId -> Node () -> [Node ()] -> Node2EvList -> EvList 89 | goAnchor lvl nid nod rest cont = case nod of 90 | YI.Scalar _ scalar -> goScalar scalar (ancName nid): isDocEnd lvl rest cont 91 | Mapping _ tag m -> Right (MappingStart (ancName nid) (getTag schemaEncoderMapping tag) Block) : goMap (lvl + 1) m rest cont 92 | Sequence _ tag s -> Right (SequenceStart (ancName nid) (getTag schemaEncoderSequence tag) Block) : goSeq (lvl + 1) s rest cont 93 | Anchor _ _ _ -> Left "Anchor has a anchor node" : (cont rest) 94 | 95 | isDocEnd :: Int -> [Node ()] -> Node2EvList -> EvList 96 | isDocEnd lvl rest cont = if lvl == 0 then Right (DocumentEnd (rest /= [])): (cont rest) else (cont rest) 97 | 98 | ancName :: NodeId -> Maybe Anchor 99 | ancName nid 100 | | nid == (0-1) = Nothing 101 | | otherwise = Just $! T.pack ("a" ++ show nid) 102 | 103 | getTag :: (Tag -> Either String Tag) -> Tag -> Tag 104 | getTag f tag = case f tag of 105 | Right t -> t 106 | Left err -> error err 107 | 108 | 109 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | ### 0.2.1.5 2 | 3 | _2025-03-11, Andreas Abel_ 4 | 5 | * Drop support for old dependencies predating LTS 7.24 (GHC 8.0). 6 | * Relax bound on `containers`. 7 | * Tested with GHC 8.0 - 9.12.1. 8 | 9 | ### 0.2.1.4 10 | 11 | _2024-04-25, Andreas Abel_ 12 | 13 | * Drop support for GHC 7. 14 | * Testsuite: relax lower bounds to accommodate LTS 11.22 (GHC 8.2) for new Stack CI. 15 | * Tested with GHC 8.0 - 9.10.0 (alpha3). 16 | 17 | ### 0.2.1.3 18 | 19 | _2023-10-14, Andreas Abel_ 20 | 21 | * Pacify `x-partial` warning of GHC 9.8. 22 | * Tested with GHC 7.10 - 9.8.1. 23 | 24 | ### 0.2.1.2 25 | 26 | _2023-09-29, Andreas Abel_ 27 | 28 | * Add `default-extensions: TypeOperators` to silence warning under GHC ≥ 9.4. 29 | * Support latest versions of dependencies. 30 | * Tested with GHC 7.10 - 9.8.0. 31 | 32 | ### 0.2.1.1 33 | 34 | _2022-05-11, Andreas Abel_ 35 | 36 | * Compatibility with `mtl-2.3`. 37 | * Tested with GHC 7.4 - 9.2. 38 | 39 | ### 0.2.1.0 40 | 41 | _2019-10-06, Herbert Valerio Riedel_ 42 | 43 | * Define `Functor Doc` instance ([#33](https://github.com/haskell-hvr/HsYAML/issues/33)) 44 | * New `withScalar` function and also define `ToYAML Scalar` and `FromYAML Scalar` instances 45 | * Export `Pair` `type` synonym from `Data.YAML` ([#31](https://github.com/haskell-hvr/HsYAML/issues/31)) 46 | * New `Data.YAML.prettyPosWithSource` function for pretty-printing source locations (i.e. `Pos` values) 47 | * Add export `docRoot :: Doc n -> n` field accessor for convenience ([#32](https://github.com/haskell-hvr/HsYAML/issues/32)) 48 | 49 | ## 0.2.0.0 50 | 51 | This release incorporates the work from [Vijay Tadikamalla's GSOC 2019 Project](https://vijayphoenix.github.io/blog/gsoc-the-conclusion/). 52 | Highlights of this major release include support for emitting YAML as 53 | well as providing direct access to source locations throughout the 54 | parsing pipeline for improved error reporting. 55 | 56 | * Changes in `Data.YAML` module 57 | * YAML 1.2 Schema encoders ([#21](https://github.com/haskell-hvr/HsYAML/pull/21)) 58 | * New `ToYAML` class for encoding Haskell Data-types from which YAML nodes can be constructed ([#20](https://github.com/haskell-hvr/HsYAML/pull/20)) 59 | * New functions like `encodeNode`, `encodeNode'` for constructing AST 60 | * New functions like `encode`, `encode1`, `encodeStrict`, `encode1Strict` for supporting typeclass-based dumping 61 | * Some ToYAML instances and other api 62 | * Modify `typeMismatch` function to show error source location in error messages ([#19](https://github.com/haskell-hvr/HsYAML/pull/19)) 63 | * Provide location-aware `failAtNode` alternative to `fail` 64 | 65 | * Changes in `Data.YAML.Event` module 66 | * Preserve and round-trip Comments at Event level([#24](https://github.com/haskell-hvr/HsYAML/pull/24)) 67 | * New `Comment` Event to preserve comments while parsing 68 | * Some additional implementations to preserve and round-trip comments 69 | * Fix issue [#22](https://github.com/haskell-hvr/HsYAML/issues/22) 70 | * New `EvPos` type for recording event and their corresponding position ([#19](https://github.com/haskell-hvr/HsYAML/pull/19)) 71 | * Preserve Flow Mapping and Flow sequence ([#18](https://github.com/haskell-hvr/HsYAML/pull/18)) 72 | * Features to preserve Literal/Folded ScalarStyle ([#15](https://github.com/haskell-hvr/HsYAML/pull/15)) 73 | * New `Chomp` type denoting Block Chomping Indicator 74 | * New `IndentOfs` type denoting Block Indentation Indicator 75 | * New `NodeStyle` type denoting flow/block style 76 | * `Event(SequenceStart,MappingStart)` constructors now record `NodeStyle` 77 | * `Style` type renamed to `ScalarType` 78 | * New `writeEvents` and `writeEventsText` function 79 | * `Event(DocumentStart)` now records YAML directive 80 | * Event parser now rejects duplicate/unsupported YAML/TAG 81 | directives as mandated by the YAML 1.2 specification 82 | 83 | * Move some schema related definitions from `Data.YAML` into the new `Data.YAML.Schema` module 84 | 85 | * Make `decode`, `decode1`, `decodeStrict`, `decode1Strict`, `decodeNode`, and `decodeNode'` treat 86 | duplicate keys (under the respective YAML schema) in YAML mappings 87 | as a loader-error (controllable via new 88 | `schemaResolverMappingDuplicates` schema property) 89 | 90 | * Define `Generic` and `NFData` instances for most types 91 | 92 | * Fix `X38W` testcase ([#13](https://github.com/haskell-hvr/HsYAML/issues/13), [#14](https://github.com/haskell-hvr/HsYAML/issues/14)) 93 | 94 | --- 95 | 96 | #### 0.1.1.3 97 | 98 | * Fix bug in float regexp being too lax in the JSON and Core schema ([#7](https://github.com/hvr/HsYAML/issues/7)) 99 | * Remove dependency on `dlist` 100 | 101 | #### 0.1.1.2 102 | 103 | * Tolerate BOM at *each* `l-document-prefix` (rather than only at the first one encountered in a YAML stream) 104 | * Workaround broken `mtl-2.2.2` bundled in GHC 8.4.1 ([#1](https://github.com/hvr/HsYAML/issues/1)) 105 | * Relax to GPL-2.0-or-later 106 | 107 | #### 0.1.1.1 108 | 109 | * Reject (illegal) non-scalar code-points in UTF-32 streams 110 | * Tolerate BOM at start of stream 111 | * Disambiguate choice in `l-any-document` production regarding token separation of `c-directives-end` 112 | * Fix `c-indentation-indicator(n)` grammar production when 113 | auto-detecting indentation in the presence of empty leading lines; 114 | also reject (illegal) auto-indent-level scalars with leading 115 | more-indented all-space lines 116 | * Complete character escape rules for double-quoted scalars 117 | * Minor optimizations 118 | 119 | ### 0.1.1.0 120 | 121 | * `Data.YAML` module promoted from `TrustWorthy` to `Safe` 122 | * Add `FromYAML Natural` instance 123 | * Add `MonadFail`, `Alternative`, and `MonadPlus` instances for `Data.YAML.Parser` 124 | * Add `Data.YAML.decodeStrict` function 125 | * Export `Data.YAML.typeMismatch` helper function 126 | 127 | ## 0.1.0.0 128 | 129 | * First version. Released on an unsuspecting world. 130 | -------------------------------------------------------------------------------- /HsYAML.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.14 2 | name: HsYAML 3 | version: 0.2.1.5 4 | x-revision: 1 5 | 6 | synopsis: Pure Haskell YAML 1.2 processor 7 | homepage: https://github.com/haskell-hvr/HsYAML 8 | bug-reports: https://github.com/haskell-hvr/HsYAML/issues 9 | license: GPL-2 10 | X-SPDX-License-Identifier: GPL-2.0-or-later 11 | license-files: LICENSE.GPLv2 LICENSE.GPLv3 12 | author: Herbert Valerio Riedel 13 | maintainer: https://github.com/haskell-hvr/HsYAML 14 | copyright: 2015-2018 Herbert Valerio Riedel 15 | , 2007-2008 Oren Ben-Kiki 16 | category: Text 17 | build-type: Simple 18 | tested-with: 19 | GHC == 9.12.2 20 | GHC == 9.10.2 21 | GHC == 9.8.4 22 | GHC == 9.6.7 23 | GHC == 9.4.8 24 | GHC == 9.2.8 25 | GHC == 9.0.2 26 | GHC == 8.10.7 27 | GHC == 8.8.4 28 | GHC == 8.6.5 29 | GHC == 8.4.4 30 | GHC == 8.2.2 31 | GHC == 8.0.2 32 | 33 | description: 34 | @HsYAML@ is a [YAML 1.2](http://yaml.org/spec/1.2/spec.html) processor, i.e. a library for parsing and serializing YAML documents. 35 | 36 | . 37 | Features of @HsYAML@ include: 38 | . 39 | * Pure Haskell implementation with small dependency footprint and emphasis on strict compliance with the [YAML 1.2 specification](http://yaml.org/spec/1.2/spec.html). 40 | * Direct decoding to native Haskell types via (@aeson@-inspired) typeclass-based API (see "Data.YAML"). 41 | * Allows round-tripping while preserving ordering, anchors, and comments at Event-level. 42 | * Support for constructing custom YAML node graph representation (including support for cyclic YAML data structures). 43 | * Support for the standard (untyped) /Failsafe/, (strict) /JSON/, and (flexible) /Core/ \"schemas\" providing implicit typing rules as defined in the YAML 1.2 specification (including support for user-defined custom schemas; see "Data.YAML.Schema"). 44 | * Support for emitting YAML using /Failsafe/, (strict) /JSON/, and (flexible) /Core/ \"schemas\" (including support for user-defined custom encoding schemas; see "Data.YAML.Schema"). 45 | * Event-based API resembling LibYAML's Event-based API (see "Data.YAML.Event"). 46 | * Low-level API access to lexical token-based scanner (see "Data.YAML.Token"). 47 | . 48 | See also the package which allows to decode and encode YAML by leveraging @aeson@'s 'FromJSON' and 'ToJSON' instances. 49 | 50 | extra-source-files: 51 | ChangeLog.md 52 | 53 | source-repository head 54 | type: git 55 | location: https://github.com/haskell-hvr/HsYAML.git 56 | 57 | flag exe 58 | description: Enable @exe:yaml-test@ component 59 | manual: True 60 | default: False 61 | 62 | library 63 | hs-source-dirs: src 64 | exposed-modules: Data.YAML 65 | , Data.YAML.Schema 66 | , Data.YAML.Event 67 | , Data.YAML.Token 68 | other-modules: Data.YAML.Loader 69 | , Data.YAML.Dumper 70 | , Data.YAML.Internal 71 | , Data.YAML.Event.Internal 72 | , Data.YAML.Event.Writer 73 | , Data.YAML.Pos 74 | , Data.YAML.Schema.Internal 75 | , Data.YAML.Token.Encoding 76 | , Util 77 | , Data.DList 78 | 79 | default-language: Haskell2010 80 | default-extensions: TypeOperators 81 | other-extensions: DeriveGeneric 82 | FlexibleContexts 83 | FlexibleInstances 84 | FunctionalDependencies 85 | MultiParamTypeClasses 86 | OverloadedStrings 87 | PostfixOperators 88 | RecordWildCards 89 | RecursiveDo 90 | Safe 91 | ScopedTypeVariables 92 | Trustworthy 93 | TypeSynonymInstances 94 | 95 | build-depends: 96 | -- Lower bounds chosen from LTS-7.24 (GHC 8.0.1) 97 | base >= 4.9 && < 5 98 | , bytestring >= 0.10.8.1 && < 0.13 99 | , containers >= 0.5.7.1 && < 1 100 | , deepseq >= 1.4.2.0 && < 1.6 101 | , text >= 1.2.3 && < 2.2 102 | , mtl >= 2.2.1 && < 2.4 103 | , parsec >= 3.1.13.0 && < 3.2 104 | , transformers >= 0.5.2.0 && < 0.7 105 | 106 | ghc-options: 107 | -Wall 108 | -Wcompat 109 | 110 | executable yaml-test 111 | hs-source-dirs: src-test 112 | main-is: Main.hs 113 | other-modules: TML 114 | 115 | default-language: Haskell2010 116 | 117 | if flag(exe) 118 | build-depends: HsYAML 119 | -- inherited constraints 120 | , bytestring 121 | , base 122 | , text 123 | , containers 124 | , mtl 125 | -- non-inherited 126 | , megaparsec >= 7.0 && < 10 127 | , microaeson == 0.1.* 128 | , filepath >= 1.4 && < 1.6 129 | , directory >= 1.2 && < 1.4 130 | else 131 | buildable: False 132 | 133 | ghc-options: -rtsopts 134 | 135 | test-suite tests 136 | default-language: Haskell2010 137 | type: exitcode-stdio-1.0 138 | hs-source-dirs: tests 139 | main-is: Tests.hs 140 | 141 | ghc-options: -rtsopts 142 | 143 | build-depends: HsYAML 144 | -- inherited constraints 145 | , bytestring >= 0.10.8.0 146 | , base 147 | , text 148 | , containers 149 | , mtl 150 | -- non-inherited 151 | -- lower bounds chosen from lts-11.22 (GHC 8.2) 152 | , QuickCheck >= 2.10.1 && < 3 153 | , tasty >= 1.0.1.1 && < 1.6 154 | , tasty-quickcheck >= 0.9.2 && < 1 155 | -------------------------------------------------------------------------------- /src/Data/YAML/Event/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE Safe #-} 4 | 5 | -- | 6 | -- Copyright: © Herbert Valerio Riedel 2015-2018 7 | -- SPDX-License-Identifier: GPL-2.0-or-later 8 | -- 9 | module Data.YAML.Event.Internal 10 | ( EvStream 11 | , Event(..) 12 | , EvPos(..) 13 | , Directives(..) 14 | , ScalarStyle(..) 15 | , Chomp(..) 16 | , IndentOfs(..) 17 | , NodeStyle(..) 18 | , scalarNodeStyle 19 | , Tag(..), untagged, isUntagged, tagToText 20 | , Anchor 21 | , Pos(..) 22 | , Y.Encoding(..) 23 | ) where 24 | 25 | 26 | import qualified Data.Text as T 27 | import Data.YAML.Pos (Pos (..)) 28 | import qualified Data.YAML.Token as Y 29 | 30 | import Util 31 | 32 | 33 | -- | YAML Event Types 34 | -- 35 | -- The events correspond to the ones from [LibYAML](http://pyyaml.org/wiki/LibYAML) 36 | -- 37 | -- The grammar below defines well-formed streams of 'Event's: 38 | -- 39 | -- @ 40 | -- stream ::= 'StreamStart' document* 'StreamEnd' 41 | -- document ::= 'DocumentStart' node 'DocumentEnd' 42 | -- node ::= 'Alias' 43 | -- | 'Scalar' 44 | -- | 'Comment' 45 | -- | sequence 46 | -- | mapping 47 | -- sequence ::= 'SequenceStart' node* 'SequenceEnd' 48 | -- mapping ::= 'MappingStart' (node node)* 'MappingEnd' 49 | -- @ 50 | -- 51 | -- @since 0.2.0 52 | data Event 53 | = StreamStart 54 | | StreamEnd 55 | | DocumentStart !Directives 56 | | DocumentEnd !Bool 57 | | Comment !Text 58 | | Alias !Anchor 59 | | Scalar !(Maybe Anchor) !Tag !ScalarStyle !Text 60 | | SequenceStart !(Maybe Anchor) !Tag !NodeStyle 61 | | SequenceEnd 62 | | MappingStart !(Maybe Anchor) !Tag !NodeStyle 63 | | MappingEnd 64 | deriving (Show, Eq, Generic) 65 | 66 | -- | @since 0.2.0 67 | instance NFData Event where 68 | rnf StreamStart = () 69 | rnf StreamEnd = () 70 | rnf (DocumentStart _) = () 71 | rnf (DocumentEnd _) = () 72 | rnf (Comment _) = () 73 | rnf (Alias _) = () 74 | rnf (Scalar a _ _ _) = rnf a 75 | rnf (SequenceStart a _ _) = rnf a 76 | rnf SequenceEnd = () 77 | rnf (MappingStart a _ _) = rnf a 78 | rnf MappingEnd = () 79 | 80 | -- |'Event' with corresponding Pos in YAML stream 81 | -- 82 | -- @since 0.2.0 83 | data EvPos = EvPos 84 | { eEvent :: !Event 85 | , ePos :: !Pos 86 | } deriving (Eq, Show, Generic) 87 | 88 | -- | @since 0.2.0 89 | instance NFData EvPos where rnf (EvPos ev p) = rnf (ev,p) 90 | 91 | -- | Encodes document @%YAML@ directives and the directives end-marker 92 | -- 93 | -- @since 0.2.0 94 | data Directives = NoDirEndMarker -- ^ no directives and also no @---@ marker 95 | | DirEndMarkerNoVersion -- ^ @---@ marker present, but no explicit @%YAML@ directive present 96 | | DirEndMarkerVersion !Word -- ^ @---@ marker present, as well as a @%YAML 1.mi@ version directive; the minor version @mi@ is stored in the 'Word' field. 97 | deriving (Show, Eq, Generic) 98 | 99 | -- | @since 0.2.0 100 | instance NFData Directives where rnf !_ = () 101 | 102 | -- | 'Scalar'-specific node style 103 | -- 104 | -- This can be considered a more granular superset of 'NodeStyle'. 105 | -- See also 'scalarNodeStyle'. 106 | -- 107 | -- @since 0.2.0 108 | data ScalarStyle = Plain 109 | | SingleQuoted 110 | | DoubleQuoted 111 | | Literal !Chomp !IndentOfs 112 | | Folded !Chomp !IndentOfs 113 | deriving (Eq,Ord,Show,Generic) 114 | 115 | -- | @since 0.2.0 116 | instance NFData ScalarStyle where rnf !_ = () 117 | 118 | -- | 119 | -- 120 | -- @since 0.2.0 121 | data Chomp = Strip -- ^ Remove all trailing line breaks and shows the presence of @-@ chomping indicator. 122 | | Clip -- ^ Keep first trailing line break; this also the default behavior used if no explicit chomping indicator is specified. 123 | | Keep -- ^ Keep all trailing line breaks and shows the presence of @+@ chomping indicator. 124 | deriving (Eq,Ord,Show,Generic) 125 | 126 | -- | @since 0.2.0 127 | instance NFData Chomp where rnf !_ = () 128 | 129 | -- | Block Indentation Indicator 130 | -- 131 | -- 'IndentAuto' is the special case for auto Block Indentation Indicator 132 | -- 133 | -- @since 0.2.0 134 | data IndentOfs = IndentAuto | IndentOfs1 | IndentOfs2 | IndentOfs3 | IndentOfs4 | IndentOfs5 | IndentOfs6 | IndentOfs7 | IndentOfs8 | IndentOfs9 135 | deriving (Eq, Ord, Show, Enum, Generic) 136 | 137 | -- | @since 0.2.0 138 | instance NFData IndentOfs where rnf !_ = () 139 | 140 | -- | Node style 141 | -- 142 | -- @since 0.2.0 143 | data NodeStyle = Flow 144 | | Block 145 | deriving (Eq,Ord,Show,Generic) 146 | 147 | -- | @since 0.2.0 148 | instance NFData NodeStyle where rnf !_ = () 149 | 150 | -- | Convert 'ScalarStyle' to 'NodeStyle' 151 | -- 152 | -- @since 0.2.0 153 | scalarNodeStyle :: ScalarStyle -> NodeStyle 154 | scalarNodeStyle Plain = Flow 155 | scalarNodeStyle SingleQuoted = Flow 156 | scalarNodeStyle DoubleQuoted = Flow 157 | scalarNodeStyle (Literal _ _) = Block 158 | scalarNodeStyle (Folded _ _ ) = Block 159 | 160 | -- | YAML Anchor identifiers 161 | type Anchor = Text 162 | 163 | -- | YAML Tags 164 | newtype Tag = Tag (Maybe Text) 165 | deriving (Eq,Ord,Generic) 166 | 167 | instance Show Tag where 168 | show (Tag x) = show x 169 | 170 | -- | @since 0.2.0 171 | instance NFData Tag where rnf (Tag x) = rnf x 172 | 173 | -- | Event stream produced by 'Data.YAML.Event.parseEvents' 174 | -- 175 | -- A 'Left' value denotes parsing errors. The event stream ends 176 | -- immediately once a 'Left' value is returned. 177 | type EvStream = [Either (Pos,String) EvPos] 178 | 179 | 180 | -- | Convert 'Tag' to its string representation 181 | -- 182 | -- Returns 'Nothing' for 'untagged' 183 | tagToText :: Tag -> Maybe T.Text 184 | tagToText (Tag x) = x 185 | 186 | -- | An \"untagged\" YAML tag 187 | untagged :: Tag 188 | untagged = Tag Nothing 189 | 190 | -- | Equivalent to @(== 'untagged')@ 191 | isUntagged :: Tag -> Bool 192 | isUntagged (Tag Nothing) = True 193 | isUntagged _ = False 194 | 195 | -------------------------------------------------------------------------------- /src/Data/YAML/Loader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE RecursiveDo #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE Trustworthy #-} 7 | 8 | -- | 9 | -- Copyright: © Herbert Valerio Riedel 2015-2018 10 | -- SPDX-License-Identifier: GPL-2.0-or-later 11 | -- 12 | module Data.YAML.Loader 13 | ( decodeLoader 14 | , Loader(..) 15 | , LoaderT 16 | , NodeId 17 | ) where 18 | 19 | import Control.Monad.State (MonadState(..), gets, modify, 20 | StateT, evalStateT, state) 21 | import Control.Monad.Trans (MonadTrans(..)) 22 | import qualified Data.ByteString.Lazy as BS.L 23 | import qualified Data.Map as Map 24 | import qualified Data.Set as Set 25 | 26 | import Data.YAML.Event (Tag) 27 | import qualified Data.YAML.Event as YE 28 | import Util 29 | 30 | -- | Unique identifier for identifying nodes 31 | -- 32 | -- This is allows to observe the alias/anchor-reference structure 33 | type NodeId = Word 34 | 35 | -- | Structure defining how to construct a document tree/graph 36 | -- 37 | -- @since 0.2.0 38 | -- 39 | data Loader m n = Loader 40 | { yScalar :: Tag -> YE.ScalarStyle -> Text -> LoaderT m n 41 | , ySequence :: Tag -> [n] -> LoaderT m n 42 | , yMapping :: Tag -> [(n,n)] -> LoaderT m n 43 | , yAlias :: NodeId -> Bool -> n -> LoaderT m n 44 | , yAnchor :: NodeId -> n -> LoaderT m n 45 | } 46 | 47 | -- | Helper type for 'Loader' 48 | -- 49 | -- @since 0.2.0 50 | type LoaderT m n = YE.Pos -> m (Either (YE.Pos,String) n) 51 | 52 | -- TODO: newtype LoaderT m n = LoaderT { runLoaderT :: YE.Pos -> m (Either String n) } 53 | 54 | -- | Generalised document tree/graph construction 55 | -- 56 | -- This doesn't yet perform any tag resolution (thus all scalars are 57 | -- represented as 'Text' values). See also 'Data.YAML.decodeNode' for a more 58 | -- convenient interface. 59 | -- 60 | -- @since 0.2.0 61 | {-# INLINEABLE decodeLoader #-} 62 | decodeLoader :: forall n m . MonadFix m => Loader m n -> BS.L.ByteString -> m (Either (YE.Pos, String) [n]) 63 | decodeLoader Loader{..} bs0 = do 64 | case sequence $ filter (not. isComment) (YE.parseEvents bs0) of 65 | Left (pos,err) -> return $ Left (pos,err) 66 | Right evs -> runParserT goStream evs 67 | where 68 | isComment evPos = case evPos of 69 | Right (YE.EvPos {eEvent = (YE.Comment _), ePos = _}) -> True 70 | _ -> False 71 | 72 | goStream :: PT n m [n] 73 | goStream = do 74 | _ <- satisfy (== YE.StreamStart) 75 | ds <- manyUnless (== YE.StreamEnd) goDoc 76 | eof 77 | return ds 78 | 79 | goDoc :: PT n m n 80 | goDoc = do 81 | _ <- satisfy isDocStart 82 | modify $ \s0 -> s0 { sDict = mempty, sCycle = mempty } 83 | n <- goNode 84 | _ <- satisfy isDocEnd 85 | return n 86 | 87 | getNewNid :: PT n m Word 88 | getNewNid = state $ \s0 -> let i0 = sIdCnt s0 89 | in (i0, s0 { sIdCnt = i0+1 }) 90 | 91 | returnNode :: YE.Pos -> Maybe YE.Anchor -> Either (YE.Pos, String) n -> PT n m n 92 | returnNode _ _ (Left err) = throwError err 93 | returnNode _ Nothing (Right node) = return node 94 | returnNode pos (Just a) (Right node) = do 95 | nid <- getNewNid 96 | node' <- liftEither' =<< lift (yAnchor nid node pos) 97 | modify $ \s0 -> s0 { sDict = Map.insert a (nid,node') (sDict s0) } 98 | return node' 99 | 100 | registerAnchor :: YE.Pos -> Maybe YE.Anchor -> PT n m n -> PT n m n 101 | registerAnchor _ Nothing pn = pn 102 | registerAnchor pos (Just a) pn = do 103 | modify $ \s0 -> s0 { sCycle = Set.insert a (sCycle s0) } 104 | nid <- getNewNid 105 | 106 | mdo 107 | modify $ \s0 -> s0 { sDict = Map.insert a (nid,n) (sDict s0) } 108 | n0 <- pn 109 | n <- liftEither' =<< lift (yAnchor nid n0 pos) 110 | return n 111 | 112 | exitAnchor :: Maybe YE.Anchor -> PT n m () 113 | exitAnchor Nothing = return () 114 | exitAnchor (Just a) = modify $ \s0 -> s0 { sCycle = Set.delete a (sCycle s0) } 115 | 116 | goNode :: PT n m n 117 | goNode = do 118 | n <- anyEv 119 | let pos = YE.ePos n 120 | case YE.eEvent n of 121 | YE.Scalar manc tag sty val -> do 122 | exitAnchor manc 123 | n' <- lift (yScalar tag sty val pos) 124 | returnNode pos manc $! n' 125 | 126 | YE.SequenceStart manc tag _ -> registerAnchor pos manc $ do 127 | ns <- manyUnless (== YE.SequenceEnd) goNode 128 | exitAnchor manc 129 | liftEither' =<< lift (ySequence tag ns pos) 130 | 131 | YE.MappingStart manc tag _ -> registerAnchor pos manc $ do 132 | kvs <- manyUnless (== YE.MappingEnd) (liftM2 (,) goNode goNode) 133 | exitAnchor manc 134 | liftEither' =<< lift (yMapping tag kvs pos) 135 | 136 | YE.Alias a -> do 137 | d <- gets sDict 138 | cy <- gets sCycle 139 | case Map.lookup a d of 140 | Nothing -> throwError (pos, ("anchor not found: " ++ show a)) 141 | Just (nid,n') -> liftEither' =<< lift (yAlias nid (Set.member a cy) n' pos) 142 | 143 | _ -> throwError (pos, "goNode: unexpected event") 144 | 145 | ---------------------------------------------------------------------------- 146 | -- small parser framework 147 | 148 | 149 | data S n = S { sEvs :: [YE.EvPos] 150 | , sDict :: Map YE.Anchor (Word,n) 151 | , sCycle :: Set YE.Anchor 152 | , sIdCnt :: !Word 153 | } 154 | 155 | newtype PT n m a = PT (StateT (S n) (ExceptT (YE.Pos, String) m) a) 156 | deriving ( Functor 157 | , Applicative 158 | , Monad 159 | , MonadState (S n) 160 | , MonadError (YE.Pos, String) 161 | , MonadFix 162 | ) 163 | 164 | instance MonadTrans (PT n) where 165 | lift = PT . lift . lift 166 | 167 | runParserT :: Monad m => PT n m a -> [YE.EvPos] -> m (Either (YE.Pos, String) a) 168 | runParserT (PT act) s0 = runExceptT $ evalStateT act (S s0 mempty mempty 0) 169 | 170 | satisfy :: Monad m => (YE.Event -> Bool) -> PT n m YE.EvPos 171 | satisfy p = do 172 | s0 <- get 173 | case sEvs s0 of 174 | [] -> throwError (fakePos, "satisfy: premature eof") 175 | (ev:rest) 176 | | p (YE.eEvent ev) -> do put (s0 { sEvs = rest}) 177 | return ev 178 | | otherwise -> throwError (YE.ePos ev, ("satisfy: predicate failed " ++ show ev)) 179 | 180 | peek :: Monad m => PT n m (Maybe YE.EvPos) 181 | peek = do 182 | s0 <- get 183 | case sEvs s0 of 184 | [] -> return Nothing 185 | (ev:_) -> return (Just ev) 186 | 187 | peek1 :: Monad m => PT n m YE.EvPos 188 | peek1 = maybe (throwError (fakePos,"peek1: premature eof")) return =<< peek 189 | 190 | anyEv :: Monad m => PT n m YE.EvPos 191 | anyEv = satisfy (const True) 192 | 193 | eof :: Monad m => PT n m () 194 | eof = do 195 | s0 <- get 196 | case sEvs s0 of 197 | [] -> return () 198 | (ev:_) -> throwError (YE.ePos ev, "eof expected") 199 | 200 | -- NB: consumes the end-event 201 | manyUnless :: Monad m => (YE.Event -> Bool) -> PT n m a -> PT n m [a] 202 | manyUnless p act = do 203 | t0 <- peek1 204 | if p (YE.eEvent t0) 205 | then anyEv >> return [] 206 | else liftM2 (:) act (manyUnless p act) 207 | 208 | {- 209 | tryError :: MonadError e m => m a -> m (Either e a) 210 | tryError act = catchError (Right <$> act) (pure . Left) 211 | -} 212 | 213 | isDocStart :: YE.Event -> Bool 214 | isDocStart (YE.DocumentStart _) = True 215 | isDocStart _ = False 216 | 217 | isDocEnd :: YE.Event -> Bool 218 | isDocEnd (YE.DocumentEnd _) = True 219 | isDocEnd _ = False 220 | 221 | fakePos :: YE.Pos 222 | fakePos = YE.Pos { posByteOffset = -1 , posCharOffset = -1 , posLine = 1 , posColumn = 0 } 223 | -------------------------------------------------------------------------------- /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'HsYAML.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250506 12 | # 13 | # REGENDATA ("0.19.20250506",["github","HsYAML.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | push: 18 | branches: 19 | - master 20 | pull_request: 21 | branches: 22 | - master 23 | jobs: 24 | linux: 25 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 26 | runs-on: ubuntu-24.04 27 | timeout-minutes: 28 | 60 29 | container: 30 | image: buildpack-deps:jammy 31 | continue-on-error: ${{ matrix.allow-failure }} 32 | strategy: 33 | matrix: 34 | include: 35 | - compiler: ghc-9.12.2 36 | compilerKind: ghc 37 | compilerVersion: 9.12.2 38 | setup-method: ghcup 39 | allow-failure: false 40 | - compiler: ghc-9.10.2 41 | compilerKind: ghc 42 | compilerVersion: 9.10.2 43 | setup-method: ghcup 44 | allow-failure: false 45 | - compiler: ghc-9.8.4 46 | compilerKind: ghc 47 | compilerVersion: 9.8.4 48 | setup-method: ghcup 49 | allow-failure: false 50 | - compiler: ghc-9.6.7 51 | compilerKind: ghc 52 | compilerVersion: 9.6.7 53 | setup-method: ghcup 54 | allow-failure: false 55 | - compiler: ghc-9.4.8 56 | compilerKind: ghc 57 | compilerVersion: 9.4.8 58 | setup-method: ghcup 59 | allow-failure: false 60 | - compiler: ghc-9.2.8 61 | compilerKind: ghc 62 | compilerVersion: 9.2.8 63 | setup-method: ghcup 64 | allow-failure: false 65 | - compiler: ghc-9.0.2 66 | compilerKind: ghc 67 | compilerVersion: 9.0.2 68 | setup-method: ghcup 69 | allow-failure: false 70 | - compiler: ghc-8.10.7 71 | compilerKind: ghc 72 | compilerVersion: 8.10.7 73 | setup-method: ghcup 74 | allow-failure: false 75 | - compiler: ghc-8.8.4 76 | compilerKind: ghc 77 | compilerVersion: 8.8.4 78 | setup-method: ghcup 79 | allow-failure: false 80 | - compiler: ghc-8.6.5 81 | compilerKind: ghc 82 | compilerVersion: 8.6.5 83 | setup-method: ghcup 84 | allow-failure: false 85 | - compiler: ghc-8.4.4 86 | compilerKind: ghc 87 | compilerVersion: 8.4.4 88 | setup-method: ghcup 89 | allow-failure: false 90 | - compiler: ghc-8.2.2 91 | compilerKind: ghc 92 | compilerVersion: 8.2.2 93 | setup-method: ghcup 94 | allow-failure: false 95 | - compiler: ghc-8.0.2 96 | compilerKind: ghc 97 | compilerVersion: 8.0.2 98 | setup-method: ghcup 99 | allow-failure: false 100 | fail-fast: false 101 | steps: 102 | - name: apt-get install 103 | run: | 104 | apt-get update 105 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev 106 | - name: Install GHCup 107 | run: | 108 | mkdir -p "$HOME/.ghcup/bin" 109 | curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup" 110 | chmod a+x "$HOME/.ghcup/bin/ghcup" 111 | - name: Install cabal-install 112 | run: | 113 | "$HOME/.ghcup/bin/ghcup" install cabal 3.14.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 114 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" 115 | - name: Install GHC (GHCup) 116 | if: matrix.setup-method == 'ghcup' 117 | run: | 118 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 119 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 120 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 121 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 122 | echo "HC=$HC" >> "$GITHUB_ENV" 123 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 124 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 125 | env: 126 | HCKIND: ${{ matrix.compilerKind }} 127 | HCNAME: ${{ matrix.compiler }} 128 | HCVER: ${{ matrix.compilerVersion }} 129 | - name: Set PATH and environment variables 130 | run: | 131 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 132 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 133 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 134 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 135 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 136 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 137 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 138 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 139 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 140 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 141 | env: 142 | HCKIND: ${{ matrix.compilerKind }} 143 | HCNAME: ${{ matrix.compiler }} 144 | HCVER: ${{ matrix.compilerVersion }} 145 | - name: env 146 | run: | 147 | env 148 | - name: write cabal config 149 | run: | 150 | mkdir -p $CABAL_DIR 151 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 184 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 185 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 186 | rm -f cabal-plan.xz 187 | chmod a+x $HOME/.cabal/bin/cabal-plan 188 | cabal-plan --version 189 | - name: checkout 190 | uses: actions/checkout@v4 191 | with: 192 | path: source 193 | - name: initial cabal.project for sdist 194 | run: | 195 | touch cabal.project 196 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 197 | cat cabal.project 198 | - name: sdist 199 | run: | 200 | mkdir -p sdist 201 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 202 | - name: unpack 203 | run: | 204 | mkdir -p unpacked 205 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 206 | - name: generate cabal.project 207 | run: | 208 | PKGDIR_HsYAML="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/HsYAML-[0-9.]*')" 209 | echo "PKGDIR_HsYAML=${PKGDIR_HsYAML}" >> "$GITHUB_ENV" 210 | rm -f cabal.project cabal.project.local 211 | touch cabal.project 212 | touch cabal.project.local 213 | echo "packages: ${PKGDIR_HsYAML}" >> cabal.project 214 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package HsYAML" >> cabal.project ; fi 215 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi 216 | cat >> cabal.project <> cabal.project.local 220 | cat cabal.project 221 | cat cabal.project.local 222 | - name: dump install plan 223 | run: | 224 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 225 | cabal-plan 226 | - name: restore cache 227 | uses: actions/cache/restore@v4 228 | with: 229 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 230 | path: ~/.cabal/store 231 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 232 | - name: install dependencies 233 | run: | 234 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 235 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 236 | - name: build w/o tests 237 | run: | 238 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 239 | - name: build 240 | run: | 241 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 242 | - name: tests 243 | run: | 244 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 245 | - name: cabal check 246 | run: | 247 | cd ${PKGDIR_HsYAML} || false 248 | ${CABAL} -vnormal check 249 | - name: haddock 250 | run: | 251 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 252 | - name: unconstrained build 253 | run: | 254 | rm -f cabal.project.local 255 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 256 | - name: prepare for constraint sets 257 | run: | 258 | rm -f cabal.project.local 259 | - name: constraint set containers-0.8 260 | run: | 261 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='containers ^>=0.8' all --dry-run ; fi 262 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then cabal-plan topo | sort ; fi 263 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='containers ^>=0.8' --dependencies-only -j2 all ; fi 264 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='containers ^>=0.8' all ; fi 265 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then $CABAL v2-test $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='containers ^>=0.8' all ; fi 266 | - name: save cache 267 | if: always() 268 | uses: actions/cache/save@v4 269 | with: 270 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 271 | path: ~/.cabal/store 272 | -------------------------------------------------------------------------------- /src/Data/YAML/Token/Encoding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE Safe #-} 4 | 5 | -- | 6 | -- Copyright: © Oren Ben-Kiki 2007, 7 | -- © Herbert Valerio Riedel 2015-2018 8 | -- SPDX-License-Identifier: GPL-2.0-or-later 9 | -- 10 | -- UTF decoding 11 | -- 12 | -- This really should be factored out to the standard libraries. Since it isn't 13 | -- there, we get to tailor it exactly to our needs. We use lazy byte strings as 14 | -- input, which should give reasonable I\/O performance when reading large 15 | -- files. The output is a normal 'Char' list which is easy to work with and 16 | -- should be efficient enough as long as the 'Data.YAML.Token.Parser' does its job right. 17 | -- 18 | module Data.YAML.Token.Encoding 19 | ( decode 20 | , Encoding(..) 21 | ) where 22 | 23 | import qualified Data.ByteString.Lazy as BL 24 | import qualified Data.ByteString.Lazy.Char8 as BLC 25 | 26 | import Util 27 | 28 | -- | Denotes the /Unicode Transformation Format/ (UTF) used for serializing the YAML document 29 | data Encoding = UTF8 -- ^ UTF-8 encoding (or ASCII) 30 | | UTF16LE -- ^ UTF-16 little endian 31 | | UTF16BE -- ^ UTF-16 big endian 32 | | UTF32LE -- ^ UTF-32 little endian 33 | | UTF32BE -- ^ UTF-32 big endian 34 | deriving (Eq,Generic) 35 | 36 | -- | @show encoding@ converts an 'Encoding' to the encoding name (with a "-") 37 | -- as used by most programs. 38 | instance Show Encoding where 39 | show UTF8 = "UTF-8" 40 | show UTF16LE = "UTF-16LE" 41 | show UTF16BE = "UTF-16BE" 42 | show UTF32LE = "UTF-32LE" 43 | show UTF32BE = "UTF-32BE" 44 | 45 | -- | @since 0.2.0 46 | instance NFData Encoding where rnf !_ = () 47 | 48 | -- | @'decode' bytes@ automatically detects the 'Encoding' used and converts the 49 | -- /bytes/ to Unicode characters, with byte offsets. Note the offset is for 50 | -- past end of the character, not its beginning. 51 | decode :: BLC.ByteString -> (Encoding, [(Int, Char)]) 52 | decode text = (encoding, undoEncoding encoding text) 53 | where 54 | encoding = detectEncoding $ BL.unpack $ BL.take 4 text 55 | 56 | -- | @'detectEncoding' text@ examines the first few chars (bytes) of the /text/ 57 | -- to deduce the Unicode encoding used according to the YAML spec. 58 | detectEncoding :: [Word8] -> Encoding 59 | detectEncoding text = case text of 60 | 0x00 : 0x00 : 0xFE : 0xFF : _ -> UTF32BE 61 | 0x00 : 0x00 : 0x00 : _ : _ -> UTF32BE 62 | 0xFF : 0xFE : 0x00 : 0x00 : _ -> UTF32LE 63 | _ : 0x00 : 0x00 : 0x00 : _ -> UTF32LE 64 | 0xFE : 0xFF : _ -> UTF16BE 65 | 0x00 : _ : _ -> UTF16BE 66 | 0xFF : 0xFE : _ -> UTF16LE 67 | _ : 0x00 : _ -> UTF16LE 68 | 0xEF : 0xBB : 0xBF : _ -> UTF8 69 | _ -> UTF8 70 | 71 | -- | @undoEncoding encoding bytes@ converts a /bytes/ stream to Unicode 72 | -- characters according to the /encoding/. 73 | undoEncoding :: Encoding -> BLC.ByteString -> [(Int, Char)] 74 | undoEncoding encoding bytes = 75 | case encoding of 76 | UTF8 -> undoUTF8 bytes 0 77 | UTF16LE -> combinePairs $ undoUTF16LE bytes 0 78 | UTF16BE -> combinePairs $ undoUTF16BE bytes 0 79 | UTF32LE -> validateScalars $ undoUTF32LE bytes 0 80 | UTF32BE -> validateScalars $ undoUTF32BE bytes 0 81 | where 82 | validateScalars [] = [] 83 | validateScalars (x@(_,c):rest) 84 | | '\xD800' <= c, c <= '\xDFFF' = error "UTF-32 stream contains invalid surrogate code-point" 85 | | otherwise = x : validateScalars rest 86 | 87 | -- ** UTF-32 decoding 88 | 89 | -- | @hasFewerThan bytes n@ checks whether there are fewer than /n/ /bytes/ 90 | -- left to read. 91 | hasFewerThan :: Int -> BLC.ByteString -> Bool 92 | hasFewerThan n bytes 93 | | n == 1 = BLC.null bytes 94 | | n > 1 = BLC.null bytes || hasFewerThan (n - 1) (BLC.tail bytes) 95 | | otherwise = False 96 | 97 | -- | @undoUTF32LE bytes offset@ decoded a UTF-32LE /bytes/ stream to Unicode 98 | -- chars. 99 | undoUTF32LE :: BLC.ByteString -> Int -> [(Int, Char)] 100 | undoUTF32LE bytes offset 101 | | BLC.null bytes = [] 102 | | hasFewerThan 4 bytes = error "UTF-32LE input contains invalid number of bytes" 103 | | otherwise = let first = BLC.head bytes 104 | bytes' = BLC.tail bytes 105 | second = BLC.head bytes' 106 | bytes'' = BLC.tail bytes' 107 | third = BLC.head bytes'' 108 | bytes''' = BLC.tail bytes'' 109 | fourth = BLC.head bytes''' 110 | rest = BLC.tail bytes''' 111 | in (offset + 4, 112 | chr $ ord first 113 | + 256 * (ord second 114 | + 256 * (ord third 115 | + 256 * ord fourth))):(undoUTF32LE rest $ offset + 4) 116 | 117 | -- | @undoUTF32BE bytes offset@ decoded a UTF-32BE /bytes/ stream to Unicode 118 | -- chars. 119 | undoUTF32BE :: BLC.ByteString -> Int -> [(Int, Char)] 120 | undoUTF32BE bytes offset 121 | | BLC.null bytes = [] 122 | | hasFewerThan 4 bytes = error "UTF-32BE input contains invalid number of bytes" 123 | | otherwise = let first = BLC.head bytes 124 | bytes' = BLC.tail bytes 125 | second = BLC.head bytes' 126 | bytes'' = BLC.tail bytes' 127 | third = BLC.head bytes'' 128 | bytes''' = BLC.tail bytes'' 129 | fourth = BLC.head bytes''' 130 | rest = BLC.tail bytes''' 131 | in (offset + 4, 132 | chr $ ord fourth 133 | + 256 * (ord third 134 | + 256 * (ord second 135 | + 256 * ord first))):(undoUTF32BE rest $ offset + 4) 136 | 137 | -- ** UTF-16 decoding 138 | 139 | -- | @combinePairs chars@ converts each pair of UTF-16 surrogate characters to a 140 | -- single Unicode character. 141 | combinePairs :: [(Int, Char)] -> [(Int, Char)] 142 | combinePairs [] = [] 143 | combinePairs (head'@(_, head_char):tail') 144 | | '\xD800' <= head_char && head_char <= '\xDBFF' = combineLead head' tail' 145 | | '\xDC00' <= head_char && head_char <= '\xDFFF' = error "UTF-16 contains trail surrogate without lead surrogate" 146 | | otherwise = head':combinePairs tail' 147 | 148 | -- | @combineLead lead rest@ combines the /lead/ surrogate with the head of the 149 | -- /rest/ of the input chars, assumed to be a /trail/ surrogate, and continues 150 | -- combining surrogate pairs. 151 | combineLead :: (Int, Char) -> [(Int, Char)] -> [(Int, Char)] 152 | combineLead _lead [] = error "UTF-16 contains lead surrogate as final character" 153 | combineLead (_, lead_char) ((trail_offset, trail_char):rest) 154 | | '\xDC00' <= trail_char && trail_char <= '\xDFFF' = (trail_offset, combineSurrogates lead_char trail_char):combinePairs rest 155 | | otherwise = error "UTF-16 contains lead surrogate without trail surrogate" 156 | 157 | -- | @surrogateOffset@ is copied from the Unicode FAQs. 158 | surrogateOffset :: Int 159 | surrogateOffset = 0x10000 - (0xD800 * 1024) - 0xDC00 160 | 161 | -- | @combineSurrogates lead trail@ combines two UTF-16 surrogates into a single 162 | -- Unicode character. 163 | combineSurrogates :: Char -> Char -> Char 164 | combineSurrogates lead trail = chr $ ord lead * 1024 + ord trail + surrogateOffset 165 | 166 | -- | @undoUTF18LE bytes offset@ decoded a UTF-16LE /bytes/ stream to Unicode 167 | -- chars. 168 | undoUTF16LE :: BLC.ByteString -> Int -> [(Int, Char)] 169 | undoUTF16LE bytes offset 170 | | BLC.null bytes = [] 171 | | hasFewerThan 2 bytes = error "UTF-16LE input contains odd number of bytes" 172 | | otherwise = let low = BLC.head bytes 173 | bytes' = BLC.tail bytes 174 | high = BLC.head bytes' 175 | rest = BLC.tail bytes' 176 | in (offset + 2, chr $ ord low + ord high * 256):(undoUTF16LE rest $ offset + 2) 177 | 178 | -- | @undoUTF18BE bytes offset@ decoded a UTF-16BE /bytes/ stream to Unicode 179 | -- chars. 180 | undoUTF16BE :: BLC.ByteString -> Int -> [(Int, Char)] 181 | undoUTF16BE bytes offset 182 | | BLC.null bytes = [] 183 | | hasFewerThan 2 bytes = error "UTF-16BE input contains odd number of bytes" 184 | | otherwise = let high = BLC.head bytes 185 | bytes' = BLC.tail bytes 186 | low = BLC.head bytes' 187 | rest = BLC.tail bytes' 188 | in (offset + 2, chr $ ord low + ord high * 256):(undoUTF16BE rest $ offset + 2) 189 | 190 | -- ** UTF-8 decoding 191 | 192 | -- | @undoUTF8 bytes offset@ decoded a UTF-8 /bytes/ stream to Unicode chars. 193 | undoUTF8 :: BLC.ByteString -> Int -> [(Int, Char)] 194 | undoUTF8 bytes = undoUTF8' (BL.unpack bytes) 195 | 196 | w2c :: Word8 -> Char 197 | w2c = chr . fromIntegral 198 | 199 | w2i :: Word8 -> Int 200 | w2i = fromIntegral 201 | 202 | undoUTF8' :: [Word8] -> Int -> [(Int, Char)] 203 | undoUTF8' [] _ = [] 204 | undoUTF8' (first:rest) !offset 205 | | first < 0x80 = (offset', c) : undoUTF8' rest offset' 206 | where 207 | !offset' = offset + 1 208 | !c = w2c first 209 | undoUTF8' (first:rest) !offset 210 | | first < 0xC0 = error "UTF-8 input contains invalid first byte" 211 | | first < 0xE0 = decodeTwoUTF8 first offset rest 212 | | first < 0xF0 = decodeThreeUTF8 first offset rest 213 | | first < 0xF8 = decodeFourUTF8 first offset rest 214 | | otherwise = error "UTF-8 input contains invalid first byte" 215 | 216 | -- | @decodeTwoUTF8 first offset bytes@ decodes a two-byte UTF-8 character, 217 | -- where the /first/ byte is already available and the second is the head of 218 | -- the /bytes/, and then continues to undo the UTF-8 encoding. 219 | decodeTwoUTF8 :: Word8 -> Int -> [Word8] -> [(Int, Char)] 220 | decodeTwoUTF8 first offset (second:rest) 221 | | second < 0x80 || 0xBF < second = error "UTF-8 double byte char has invalid second byte" 222 | | otherwise = (offset', c) : undoUTF8' rest offset' 223 | where 224 | !offset' = offset + 2 225 | !c = chr ((w2i first - 0xc0) * 0x40 + (w2i second - 0x80)) 226 | decodeTwoUTF8 _ _ [] = error "UTF-8 double byte char is missing second byte at eof" 227 | 228 | -- | @decodeThreeUTF8 first offset bytes@ decodes a three-byte UTF-8 character, 229 | -- where the /first/ byte is already available and the second and third are the 230 | -- head of the /bytes/, and then continues to undo the UTF-8 encoding. 231 | decodeThreeUTF8 :: Word8 -> Int -> [Word8] -> [(Int, Char)] 232 | decodeThreeUTF8 first offset (second:third:rest) 233 | | second < 0x80 || 0xBF < second = error "UTF-8 triple byte char has invalid second byte" 234 | | third < 0x80 || 0xBF < third = error "UTF-8 triple byte char has invalid third byte" 235 | | otherwise = (offset', c): undoUTF8' rest offset' 236 | where 237 | !offset' = offset + 3 238 | !c = chr((w2i first - 0xE0) * 0x1000 + 239 | (w2i second - 0x80) * 0x40 + 240 | (w2i third - 0x80)) 241 | decodeThreeUTF8 _ _ _ =error "UTF-8 triple byte char is missing bytes at eof" 242 | 243 | -- | @decodeFourUTF8 first offset bytes@ decodes a four-byte UTF-8 character, 244 | -- where the /first/ byte is already available and the second, third and fourth 245 | -- are the head of the /bytes/, and then continues to undo the UTF-8 encoding. 246 | decodeFourUTF8 :: Word8 -> Int -> [Word8] -> [(Int, Char)] 247 | decodeFourUTF8 first offset (second:third:fourth:rest) 248 | | second < 0x80 || 0xBF < second = error "UTF-8 quad byte char has invalid second byte" 249 | | third < 0x80 || 0xBF < third = error "UTF-8 quad byte char has invalid third byte" 250 | | fourth < 0x80 || 0xBF < fourth = error "UTF-8 quad byte char has invalid fourth byte" 251 | | otherwise = (offset', c) : undoUTF8' rest offset' 252 | where 253 | !offset' = offset + 4 254 | !c = chr((w2i first - 0xF0) * 0x40000 + 255 | (w2i second - 0x80) * 0x1000 + 256 | (w2i third - 0x80) * 0x40 + 257 | (w2i fourth - 0x80)) 258 | 259 | decodeFourUTF8 _ _ _ = error "UTF-8 quad byte char is missing bytes at eof" 260 | -------------------------------------------------------------------------------- /src-test/TML.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | 4 | -- Copyright: © Herbert Valerio Riedel 2018 5 | -- SPDX-License-Identifier: GPL-2.0-or-later 6 | -- 7 | -- Incomplete TestML 0.3.0 parser 8 | module TML 9 | ( TML.parse 10 | 11 | , Document(..) 12 | , Block(..) 13 | 14 | , Point(..) 15 | , PseudoId(..) 16 | 17 | , Code(..) 18 | , AssertOp(..) 19 | , CodeExpr(..) 20 | , CodeObject(..) 21 | , FunCall(..) 22 | ) where 23 | 24 | import Data.ByteString (ByteString) 25 | import qualified Data.ByteString.Char8 as B 26 | 27 | import Control.Applicative hiding (many, some) 28 | import Control.Monad 29 | import qualified Data.Aeson.Micro as J 30 | import qualified Data.ByteString as BS 31 | import qualified Data.Char as C 32 | import Data.List 33 | import qualified Data.Map as Map 34 | import Data.Maybe 35 | import qualified Data.Text as T 36 | import qualified Data.Text.Encoding as T 37 | import qualified Data.Text.IO as T 38 | import Data.Void 39 | import System.Environment 40 | import Text.Megaparsec 41 | import Text.Megaparsec.Char 42 | import qualified Text.Megaparsec.Char.Lexer as L 43 | 44 | type Parser = Parsec Void T.Text 45 | 46 | parse :: String -> T.Text -> Either T.Text Document 47 | parse fn raw = either (Left . T.pack . errorBundlePretty) 48 | (Right .process_pseudo) 49 | (Text.Megaparsec.parse testml_document fn raw) 50 | 51 | 52 | ---------------------------------------------------------------------------- 53 | 54 | data Document = Document [Code] [Block] 55 | deriving Show 56 | 57 | instance J.ToJSON Document where 58 | toJSON (Document code dat) 59 | = J.object [ "testml" J..= ("0.3.0" :: T.Text) 60 | , "code" J..= code 61 | , "data" J..= dat 62 | ] 63 | 64 | data Block = Block !T.Text [Point] 65 | deriving Show 66 | 67 | instance J.ToJSON Block where 68 | toJSON (Block label points) 69 | = J.object [ "label" J..= label 70 | , "point" J..= J.object (map f points) 71 | ] 72 | where 73 | f (PointStr k v) = k J..= v 74 | f (PointPseudo k) = (T.pack (show k)) J..= True 75 | f (PointInt k v) = k J..= v 76 | 77 | data Point = PointStr !T.Text !T.Text 78 | | PointInt !T.Text !Integer 79 | | PointPseudo !PseudoId 80 | deriving Show 81 | 82 | instance J.ToJSON Code where 83 | toJSON (CodeAssignmentStmt lhs rhs) 84 | = J.Array [J.String "=", J.String lhs, J.toJSON rhs] 85 | toJSON stmt@(CodeExpressionStmt lhs massert) 86 | | pobjs@(_:_) <- pointObjsInExpr stmt 87 | = J.Array [ J.String "%()" 88 | , J.Array [ J.String ("*" `mappend` p) | p <- pobjs ] 89 | , expr' 90 | ] 91 | | otherwise = expr' 92 | where 93 | expr' = case massert of 94 | Just (op,rhs) -> J.toJSON (op,lhs,rhs) 95 | Nothing -> J.toJSON lhs 96 | 97 | data Code = CodeAssignmentStmt !T.Text !CodeExpr 98 | | CodeExpressionStmt !CodeExpr !(Maybe (AssertOp,CodeExpr)) 99 | | CodeImportStmt [T.Text] 100 | deriving Show 101 | 102 | instance J.ToJSON AssertOp where 103 | toJSON AssertEq = J.String "==" 104 | toJSON AssertHas = J.String "~~" 105 | toJSON AssertLike = J.String "=~" 106 | 107 | data AssertOp = AssertEq | AssertHas | AssertLike 108 | deriving Show 109 | 110 | instance J.ToJSON CodeExpr where 111 | toJSON (CodeExpr obj []) = J.toJSON obj 112 | toJSON (CodeExpr obj fns) = J.Array $ [J.String ".", J.toJSON obj] ++ map J.toJSON fns 113 | 114 | data CodeExpr = CodeExpr !CodeObject [FunCall] 115 | deriving Show 116 | 117 | instance J.ToJSON CodeObject where 118 | toJSON (StrObj s) = J.String s 119 | toJSON (NumObj n) = J.Number n 120 | toJSON (PointObj j) = J.Array [J.String "*", J.String j] 121 | toJSON (CallObj fn) = J.toJSON fn 122 | 123 | data CodeObject = StrObj !T.Text 124 | | CallObj !FunCall 125 | | NumObj !Double 126 | | PointObj !T.Text 127 | deriving Show 128 | 129 | instance J.ToJSON FunCall where 130 | toJSON (FunCall fn args) = J.Array (J.String fn : map J.toJSON args) 131 | 132 | data FunCall = FunCall !T.Text [CodeExpr] 133 | deriving Show 134 | 135 | 136 | 137 | pointObjsInExpr :: Code -> [T.Text] 138 | pointObjsInExpr co = nub $ case co of 139 | CodeAssignmentStmt _ expr -> goExpr expr 140 | CodeExpressionStmt e1 Nothing -> goExpr e1 141 | CodeExpressionStmt e1 (Just (_,e2)) -> goExpr e1 ++ goExpr e2 142 | where 143 | goExpr (CodeExpr obj fns) = goObj obj ++ concatMap goFun fns 144 | 145 | goFun (FunCall _ exprs) = concatMap goExpr exprs 146 | 147 | goObj (PointObj j) = [j] 148 | goObj (CallObj fn) = goFun fn 149 | goObj (StrObj _) = [] 150 | goObj (NumObj _) = [] 151 | 152 | 153 | testml_document :: Parser Document 154 | testml_document = Document <$> code_section <*> data_section <* eof 155 | 156 | pseudo_point_name :: Parser PseudoId 157 | pseudo_point_name 158 | = choice [ HEAD <$ string "HEAD" 159 | , LAST <$ string "LAST" 160 | , ONLY <$ string "ONLY" 161 | , SKIP <$ string "SKIP" 162 | , TODO <$ string "TODO" 163 | , DIFF <$ string "DIFF" 164 | ] 165 | 166 | data PseudoId = HEAD 167 | | LAST 168 | | ONLY 169 | | SKIP 170 | | TODO 171 | | DIFF 172 | deriving (Eq,Show) 173 | 174 | process_pseudo :: Document -> Document 175 | process_pseudo (Document code bs0) = Document code (go bs0) 176 | where 177 | go blocks 178 | | Just b <- find isOnly blocks' = [b] 179 | | Just bs <- goHead blocks' = bs 180 | | Just bs <- goLast [] blocks' = bs 181 | | otherwise = blocks' 182 | where 183 | blocks' = filter (not . isSkip) blocks 184 | 185 | isOnly b = ONLY `elem` pseudos b 186 | isSkip b = SKIP `elem` pseudos b 187 | isHead b = HEAD `elem` pseudos b 188 | isLast b = LAST `elem` pseudos b 189 | 190 | pseudos (Block _ ps) = [ k | PointPseudo k <- ps ] 191 | 192 | goHead [] = Nothing 193 | goHead (b:bs) 194 | | isHead b = Just (b:bs) 195 | | otherwise = goHead bs 196 | 197 | goLast acc [] = Nothing 198 | goLast acc (b:bs) 199 | | isLast b = Just $ reverse (b:bs) 200 | | otherwise = goLast (b:acc) bs 201 | 202 | code_section :: Parser [Code] 203 | code_section = do 204 | xs <- many code_statement 205 | pure (catMaybes xs) 206 | where 207 | code_statement = choice 208 | [ Nothing <$ comment_lines 209 | , Just <$> import_directive 210 | , Just <$> assignment_statement 211 | , Just <$> expression_statement 212 | ] 213 | 214 | import_directive = do 215 | string "%Import" 216 | ws 217 | mods <- module_name `sepBy1` ws 218 | ws0 219 | eol 220 | pure $! CodeImportStmt mods 221 | 222 | module_name :: Parser T.Text 223 | module_name = T.pack <$> some alphaNumChar 224 | 225 | assignment_statement = do 226 | v <- try $ do 227 | v' <- identifier_name 228 | ws 229 | void (char '=') <|> void (string "||=") -- FIXME 230 | ws 231 | pure v' 232 | e <- code_expression 233 | eol 234 | pure (CodeAssignmentStmt v e) 235 | 236 | expression_statement = do 237 | -- TODO: expression-label 238 | -- optional (double_string >> char ':' >> ws0) 239 | 240 | -- TODO: pick-expression 241 | 242 | lhs <- code_expression 243 | ws 244 | op <- choice 245 | [ AssertEq <$ string "==" 246 | , AssertHas <$ string "~~" 247 | , AssertLike <$ string "=~" 248 | ] 249 | ws 250 | rhs <- code_expression 251 | 252 | optional $ do 253 | ws0 254 | char ':' 255 | double_string 256 | 257 | eol 258 | 259 | pure (CodeExpressionStmt lhs (Just (op,rhs))) 260 | 261 | 262 | code_expression :: Parser CodeExpr 263 | code_expression = CodeExpr <$> code_object <*> many function_call 264 | 265 | 266 | -- quoted string 267 | double_string :: Parser T.Text 268 | double_string = do 269 | char '"' 270 | str <- many (noneOf ("\n\"\\" :: [Char]) <|> (char '\\' >> (unesc <$> oneOf ("\\\"0nt" :: [Char])))) 271 | char '"' 272 | pure $! (T.pack str) 273 | where 274 | unesc '0' = '\0' 275 | unesc 'n' = '\n' 276 | unesc 't' = '\t' 277 | unesc c = c 278 | 279 | single_string :: Parser T.Text 280 | single_string = do 281 | char '\'' 282 | str <- many (noneOf ("\n'\\" :: [Char]) <|> (char '\\' >> (oneOf ("\\'" :: [Char])))) 283 | char '\'' 284 | pure $! (T.pack str) 285 | 286 | function_call :: Parser FunCall 287 | function_call = do 288 | char '.' 289 | call_object 290 | 291 | call_object :: Parser FunCall 292 | call_object = FunCall <$> identifier_name 293 | <*> optional' [] (between (char '(') (char ')') $ code_expression `sepBy1` (char ',' >> ws0)) 294 | 295 | optional' def p = do 296 | x <- optional p 297 | case x of 298 | Nothing -> pure def 299 | Just y -> pure y 300 | 301 | code_object :: Parser CodeObject 302 | code_object 303 | = choice 304 | [ mkPoint <$> char '*' <*> lowerChar <*> many (lowerChar <|> digitChar <|> char '-' <|> char '_') 305 | , mkNum <$> optional (char '-') <*> some digitChar <*> optional (char '.' >> some digitChar) 306 | , CallObj <$> call_object 307 | , StrObj <$> single_string 308 | , StrObj <$> double_string 309 | ] "code-object" 310 | where 311 | mkPoint _ c cs = PointObj $! (T.pack (c:cs)) 312 | mkNum msign ds1 mds2 = NumObj $! (read $ (maybe id (:) msign) ds1 ++ (maybe "" ('.':) mds2)) 313 | 314 | data_section :: Parser [Block] 315 | data_section = many block_definition 316 | where 317 | block_definition = do 318 | -- block_heading 319 | string "===" *> ws 320 | l <- T.pack <$> manyTill anySingle eol 321 | 322 | -- TODO: user_defined 323 | ps <- many point_definition 324 | pure (Block l ps) 325 | 326 | point_definition = do 327 | string "---" *> ws 328 | 329 | j <- eitherP identifier_user pseudo_point_name 330 | 331 | filters <- maybe [] id <$> optional filter_spec 332 | 333 | let single = do 334 | _ <- char ':' *> ws 335 | x <- T.pack <$> manyTill anySingle eol 336 | -- consume and ignore any point_lines 337 | _ <- point_lines 338 | pure $! case j of 339 | Left j' -> mkSinglePointVal j' (transformPoint True filters x) 340 | Right j' -> PointPseudo j' -- is this allowed? 341 | 342 | multi = do 343 | ws0 *> eol 344 | x <- point_lines 345 | pure $! case j of 346 | Left j' -> PointStr j' (transformPoint False filters x) 347 | Right j' -> PointPseudo j' 348 | 349 | single <|> multi 350 | 351 | filter_spec = between (char '(') (char ')') $ many (oneOf ("<#+-~/@" :: [Char])) 352 | 353 | mkSinglePointVal k v 354 | | T.all C.isDigit v = PointInt k (read (T.unpack v)) 355 | | otherwise = PointStr k v 356 | 357 | point_lines :: Parser T.Text 358 | point_lines = T.pack . unlines <$> go 359 | where 360 | go = many (notFollowedBy point_boundary *> manyTill anySingle eol) 361 | 362 | point_boundary :: Parser () 363 | point_boundary = void (string "---") <|> void (string "===") <|> eof 364 | 365 | identifier_user :: Parser T.Text 366 | identifier_user = do 367 | x <- (:) <$> lowerChar <*> many alphaNumChar 368 | xs <- many ((:) <$> char '-' <*> some alphaNumChar) 369 | 370 | pure $! T.pack (concat (x:xs)) 371 | 372 | identifier_name :: Parser T.Text 373 | identifier_name = do 374 | x <- (:) <$> letterChar <*> many alphaNumChar 375 | xs <- many ((:) <$> char '-' <*> some alphaNumChar) 376 | 377 | pure $! T.pack (concat (x:xs)) 378 | 379 | 380 | ws :: Parser () 381 | ws = void $ takeWhile1P (Just "BLANK") (\c -> c == ' ' || c == '\t') 382 | 383 | ws0 :: Parser () 384 | ws0 = void $ takeWhileP (Just "BLANK") (\c -> c == ' ' || c == '\t') 385 | 386 | blank_line :: Parser () 387 | blank_line = (try (ws0 <* eol) <|> try (ws <* eof)) "blank-line" 388 | 389 | comment_line :: Parser () 390 | comment_line = (char '#' *> takeWhileP Nothing (/= '\n') *> void eol) "comment-line" 391 | 392 | comment_lines :: Parser () 393 | comment_lines = void (some (comment_line <|> blank_line)) 394 | 395 | stripTrailEols :: T.Text -> T.Text 396 | stripTrailEols = go 397 | where 398 | go t | T.isSuffixOf "\n\n" t = go (T.init t) 399 | | T.isSuffixOf "\r\n\r\n" t = go (T.init (T.init t)) 400 | | t == "\n" = "" 401 | | otherwise = t 402 | 403 | -- 'undent' 404 | stripPrefixInd :: T.Text -> T.Text 405 | stripPrefixInd = T.unlines . map go . T.lines 406 | where 407 | go t | T.isPrefixOf " " t = T.drop 4 t 408 | | T.isPrefixOf " " t = T.drop 3 t 409 | | T.isPrefixOf " " t = T.drop 2 t 410 | | T.isPrefixOf " " t = T.drop 1 t 411 | | otherwise = t 412 | 413 | stripComments :: T.Text -> T.Text 414 | stripComments = T.unlines . filter (not . T.isPrefixOf "#") . T.lines 415 | 416 | transformPoint :: Bool -> [Char] -> T.Text -> T.Text 417 | transformPoint single mods0 -- TODO: backslash 418 | = go mods0 . 419 | (if keepBlanks then id else stripTrailEols) . 420 | (if keepComments then id else stripComments) 421 | where 422 | keepBlanks = single || ('+' `elem` mods0) 423 | keepComments = single || ('#' `elem` mods0) 424 | 425 | go [] = id 426 | go ('<':xs) 427 | | single = error "invalid filter for point-single" 428 | | otherwise = go xs . stripPrefixInd 429 | go ('+':xs) = go xs -- negative flag 430 | go ('#':xs) = go xs -- negative flag 431 | go ('-':xs) = go xs . T.dropWhileEnd C.isSpace 432 | go (c:_) = error ("unknown filter " ++ show c) 433 | -------------------------------------------------------------------------------- /LICENSE.GPLv2: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 2, June 1991 3 | 4 | Copyright (C) 1989, 1991 Free Software Foundation, Inc., 5 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | Preamble 10 | 11 | The licenses for most software are designed to take away your 12 | freedom to share and change it. By contrast, the GNU General Public 13 | License is intended to guarantee your freedom to share and change free 14 | software--to make sure the software is free for all its users. This 15 | General Public License applies to most of the Free Software 16 | Foundation's software and to any other program whose authors commit to 17 | using it. (Some other Free Software Foundation software is covered by 18 | the GNU Lesser General Public License instead.) You can apply it to 19 | your programs, too. 20 | 21 | When we speak of free software, we are referring to freedom, not 22 | price. Our General Public Licenses are designed to make sure that you 23 | have the freedom to distribute copies of free software (and charge for 24 | this service if you wish), that you receive source code or can get it 25 | if you want it, that you can change the software or use pieces of it 26 | in new free programs; and that you know you can do these things. 27 | 28 | To protect your rights, we need to make restrictions that forbid 29 | anyone to deny you these rights or to ask you to surrender the rights. 30 | These restrictions translate to certain responsibilities for you if you 31 | distribute copies of the software, or if you modify it. 32 | 33 | For example, if you distribute copies of such a program, whether 34 | gratis or for a fee, you must give the recipients all the rights that 35 | you have. You must make sure that they, too, receive or can get the 36 | source code. And you must show them these terms so they know their 37 | rights. 38 | 39 | We protect your rights with two steps: (1) copyright the software, and 40 | (2) offer you this license which gives you legal permission to copy, 41 | distribute and/or modify the software. 42 | 43 | Also, for each author's protection and ours, we want to make certain 44 | that everyone understands that there is no warranty for this free 45 | software. If the software is modified by someone else and passed on, we 46 | want its recipients to know that what they have is not the original, so 47 | that any problems introduced by others will not reflect on the original 48 | authors' reputations. 49 | 50 | Finally, any free program is threatened constantly by software 51 | patents. We wish to avoid the danger that redistributors of a free 52 | program will individually obtain patent licenses, in effect making the 53 | program proprietary. To prevent this, we have made it clear that any 54 | patent must be licensed for everyone's free use or not licensed at all. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | GNU GENERAL PUBLIC LICENSE 60 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 61 | 62 | 0. This License applies to any program or other work which contains 63 | a notice placed by the copyright holder saying it may be distributed 64 | under the terms of this General Public License. The "Program", below, 65 | refers to any such program or work, and a "work based on the Program" 66 | means either the Program or any derivative work under copyright law: 67 | that is to say, a work containing the Program or a portion of it, 68 | either verbatim or with modifications and/or translated into another 69 | language. (Hereinafter, translation is included without limitation in 70 | the term "modification".) Each licensee is addressed as "you". 71 | 72 | Activities other than copying, distribution and modification are not 73 | covered by this License; they are outside its scope. The act of 74 | running the Program is not restricted, and the output from the Program 75 | is covered only if its contents constitute a work based on the 76 | Program (independent of having been made by running the Program). 77 | Whether that is true depends on what the Program does. 78 | 79 | 1. You may copy and distribute verbatim copies of the Program's 80 | source code as you receive it, in any medium, provided that you 81 | conspicuously and appropriately publish on each copy an appropriate 82 | copyright notice and disclaimer of warranty; keep intact all the 83 | notices that refer to this License and to the absence of any warranty; 84 | and give any other recipients of the Program a copy of this License 85 | along with the Program. 86 | 87 | You may charge a fee for the physical act of transferring a copy, and 88 | you may at your option offer warranty protection in exchange for a fee. 89 | 90 | 2. You may modify your copy or copies of the Program or any portion 91 | of it, thus forming a work based on the Program, and copy and 92 | distribute such modifications or work under the terms of Section 1 93 | above, provided that you also meet all of these conditions: 94 | 95 | a) You must cause the modified files to carry prominent notices 96 | stating that you changed the files and the date of any change. 97 | 98 | b) You must cause any work that you distribute or publish, that in 99 | whole or in part contains or is derived from the Program or any 100 | part thereof, to be licensed as a whole at no charge to all third 101 | parties under the terms of this License. 102 | 103 | c) If the modified program normally reads commands interactively 104 | when run, you must cause it, when started running for such 105 | interactive use in the most ordinary way, to print or display an 106 | announcement including an appropriate copyright notice and a 107 | notice that there is no warranty (or else, saying that you provide 108 | a warranty) and that users may redistribute the program under 109 | these conditions, and telling the user how to view a copy of this 110 | License. (Exception: if the Program itself is interactive but 111 | does not normally print such an announcement, your work based on 112 | the Program is not required to print an announcement.) 113 | 114 | These requirements apply to the modified work as a whole. If 115 | identifiable sections of that work are not derived from the Program, 116 | and can be reasonably considered independent and separate works in 117 | themselves, then this License, and its terms, do not apply to those 118 | sections when you distribute them as separate works. But when you 119 | distribute the same sections as part of a whole which is a work based 120 | on the Program, the distribution of the whole must be on the terms of 121 | this License, whose permissions for other licensees extend to the 122 | entire whole, and thus to each and every part regardless of who wrote it. 123 | 124 | Thus, it is not the intent of this section to claim rights or contest 125 | your rights to work written entirely by you; rather, the intent is to 126 | exercise the right to control the distribution of derivative or 127 | collective works based on the Program. 128 | 129 | In addition, mere aggregation of another work not based on the Program 130 | with the Program (or with a work based on the Program) on a volume of 131 | a storage or distribution medium does not bring the other work under 132 | the scope of this License. 133 | 134 | 3. You may copy and distribute the Program (or a work based on it, 135 | under Section 2) in object code or executable form under the terms of 136 | Sections 1 and 2 above provided that you also do one of the following: 137 | 138 | a) Accompany it with the complete corresponding machine-readable 139 | source code, which must be distributed under the terms of Sections 140 | 1 and 2 above on a medium customarily used for software interchange; or, 141 | 142 | b) Accompany it with a written offer, valid for at least three 143 | years, to give any third party, for a charge no more than your 144 | cost of physically performing source distribution, a complete 145 | machine-readable copy of the corresponding source code, to be 146 | distributed under the terms of Sections 1 and 2 above on a medium 147 | customarily used for software interchange; or, 148 | 149 | c) Accompany it with the information you received as to the offer 150 | to distribute corresponding source code. (This alternative is 151 | allowed only for noncommercial distribution and only if you 152 | received the program in object code or executable form with such 153 | an offer, in accord with Subsection b above.) 154 | 155 | The source code for a work means the preferred form of the work for 156 | making modifications to it. For an executable work, complete source 157 | code means all the source code for all modules it contains, plus any 158 | associated interface definition files, plus the scripts used to 159 | control compilation and installation of the executable. However, as a 160 | special exception, the source code distributed need not include 161 | anything that is normally distributed (in either source or binary 162 | form) with the major components (compiler, kernel, and so on) of the 163 | operating system on which the executable runs, unless that component 164 | itself accompanies the executable. 165 | 166 | If distribution of executable or object code is made by offering 167 | access to copy from a designated place, then offering equivalent 168 | access to copy the source code from the same place counts as 169 | distribution of the source code, even though third parties are not 170 | compelled to copy the source along with the object code. 171 | 172 | 4. You may not copy, modify, sublicense, or distribute the Program 173 | except as expressly provided under this License. Any attempt 174 | otherwise to copy, modify, sublicense or distribute the Program is 175 | void, and will automatically terminate your rights under this License. 176 | However, parties who have received copies, or rights, from you under 177 | this License will not have their licenses terminated so long as such 178 | parties remain in full compliance. 179 | 180 | 5. You are not required to accept this License, since you have not 181 | signed it. However, nothing else grants you permission to modify or 182 | distribute the Program or its derivative works. These actions are 183 | prohibited by law if you do not accept this License. Therefore, by 184 | modifying or distributing the Program (or any work based on the 185 | Program), you indicate your acceptance of this License to do so, and 186 | all its terms and conditions for copying, distributing or modifying 187 | the Program or works based on it. 188 | 189 | 6. Each time you redistribute the Program (or any work based on the 190 | Program), the recipient automatically receives a license from the 191 | original licensor to copy, distribute or modify the Program subject to 192 | these terms and conditions. You may not impose any further 193 | restrictions on the recipients' exercise of the rights granted herein. 194 | You are not responsible for enforcing compliance by third parties to 195 | this License. 196 | 197 | 7. If, as a consequence of a court judgment or allegation of patent 198 | infringement or for any other reason (not limited to patent issues), 199 | conditions are imposed on you (whether by court order, agreement or 200 | otherwise) that contradict the conditions of this License, they do not 201 | excuse you from the conditions of this License. If you cannot 202 | distribute so as to satisfy simultaneously your obligations under this 203 | License and any other pertinent obligations, then as a consequence you 204 | may not distribute the Program at all. For example, if a patent 205 | license would not permit royalty-free redistribution of the Program by 206 | all those who receive copies directly or indirectly through you, then 207 | the only way you could satisfy both it and this License would be to 208 | refrain entirely from distribution of the Program. 209 | 210 | If any portion of this section is held invalid or unenforceable under 211 | any particular circumstance, the balance of the section is intended to 212 | apply and the section as a whole is intended to apply in other 213 | circumstances. 214 | 215 | It is not the purpose of this section to induce you to infringe any 216 | patents or other property right claims or to contest validity of any 217 | such claims; this section has the sole purpose of protecting the 218 | integrity of the free software distribution system, which is 219 | implemented by public license practices. Many people have made 220 | generous contributions to the wide range of software distributed 221 | through that system in reliance on consistent application of that 222 | system; it is up to the author/donor to decide if he or she is willing 223 | to distribute software through any other system and a licensee cannot 224 | impose that choice. 225 | 226 | This section is intended to make thoroughly clear what is believed to 227 | be a consequence of the rest of this License. 228 | 229 | 8. If the distribution and/or use of the Program is restricted in 230 | certain countries either by patents or by copyrighted interfaces, the 231 | original copyright holder who places the Program under this License 232 | may add an explicit geographical distribution limitation excluding 233 | those countries, so that distribution is permitted only in or among 234 | countries not thus excluded. In such case, this License incorporates 235 | the limitation as if written in the body of this License. 236 | 237 | 9. The Free Software Foundation may publish revised and/or new versions 238 | of the General Public License from time to time. Such new versions will 239 | be similar in spirit to the present version, but may differ in detail to 240 | address new problems or concerns. 241 | 242 | Each version is given a distinguishing version number. If the Program 243 | specifies a version number of this License which applies to it and "any 244 | later version", you have the option of following the terms and conditions 245 | either of that version or of any later version published by the Free 246 | Software Foundation. If the Program does not specify a version number of 247 | this License, you may choose any version ever published by the Free Software 248 | Foundation. 249 | 250 | 10. If you wish to incorporate parts of the Program into other free 251 | programs whose distribution conditions are different, write to the author 252 | to ask for permission. For software which is copyrighted by the Free 253 | Software Foundation, write to the Free Software Foundation; we sometimes 254 | make exceptions for this. Our decision will be guided by the two goals 255 | of preserving the free status of all derivatives of our free software and 256 | of promoting the sharing and reuse of software generally. 257 | 258 | NO WARRANTY 259 | 260 | 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 268 | REPAIR OR CORRECTION. 269 | 270 | 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 278 | POSSIBILITY OF SUCH DAMAGES. 279 | 280 | END OF TERMS AND CONDITIONS 281 | 282 | How to Apply These Terms to Your New Programs 283 | 284 | If you develop a new program, and you want it to be of the greatest 285 | possible use to the public, the best way to achieve this is to make it 286 | free software which everyone can redistribute and change under these terms. 287 | 288 | To do so, attach the following notices to the program. It is safest 289 | to attach them to the start of each source file to most effectively 290 | convey the exclusion of warranty; and each file should have at least 291 | the "copyright" line and a pointer to where the full notice is found. 292 | 293 | 294 | Copyright (C) 295 | 296 | This program is free software; you can redistribute it and/or modify 297 | it under the terms of the GNU General Public License as published by 298 | the Free Software Foundation; either version 2 of the License, or 299 | (at your option) any later version. 300 | 301 | This program is distributed in the hope that it will be useful, 302 | but WITHOUT ANY WARRANTY; without even the implied warranty of 303 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 304 | GNU General Public License for more details. 305 | 306 | You should have received a copy of the GNU General Public License along 307 | with this program; if not, write to the Free Software Foundation, Inc., 308 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 309 | 310 | Also add information on how to contact you by electronic and paper mail. 311 | 312 | If the program is interactive, make it output a short notice like this 313 | when it starts in an interactive mode: 314 | 315 | Gnomovision version 69, Copyright (C) year name of author 316 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 317 | This is free software, and you are welcome to redistribute it 318 | under certain conditions; type `show c' for details. 319 | 320 | The hypothetical commands `show w' and `show c' should show the appropriate 321 | parts of the General Public License. Of course, the commands you use may 322 | be called something other than `show w' and `show c'; they could even be 323 | mouse-clicks or menu items--whatever suits your program. 324 | 325 | You should also get your employer (if you work as a programmer) or your 326 | school, if any, to sign a "copyright disclaimer" for the program, if 327 | necessary. Here is a sample; alter the names: 328 | 329 | Yoyodyne, Inc., hereby disclaims all copyright interest in the program 330 | `Gnomovision' (which makes passes at compilers) written by James Hacker. 331 | 332 | , 1 April 1989 333 | Ty Coon, President of Vice 334 | 335 | This General Public License does not permit incorporating your program into 336 | proprietary programs. If your program is a subroutine library, you may 337 | consider it more useful to permit linking proprietary applications with the 338 | library. If this is what you want to do, use the GNU Lesser General 339 | Public License instead of this License. 340 | -------------------------------------------------------------------------------- /src/Data/YAML/Schema/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE Safe #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | 7 | -- | 8 | -- Copyright: © Herbert Valerio Riedel 2015-2018 9 | -- SPDX-License-Identifier: GPL-2.0-or-later 10 | -- 11 | -- YAML 1.2 Schema resolvers and encoders 12 | -- 13 | module Data.YAML.Schema.Internal 14 | ( SchemaResolver(..) 15 | , failsafeSchemaResolver 16 | , jsonSchemaResolver 17 | , coreSchemaResolver 18 | , Scalar(..) 19 | 20 | , SchemaEncoder(..) 21 | , failsafeSchemaEncoder 22 | , jsonSchemaEncoder 23 | , coreSchemaEncoder 24 | 25 | , tagNull, tagBool, tagStr, tagInt, tagFloat, tagSeq, tagMap 26 | 27 | , isPlainChar , isAmbiguous, defaultSchemaEncoder, setScalarStyle 28 | , encodeDouble, encodeBool, encodeInt 29 | ) where 30 | 31 | import qualified Data.Char as C 32 | import qualified Data.Map as Map 33 | import qualified Data.Set as Set 34 | import qualified Data.Text as T 35 | import Numeric (readHex, readOct) 36 | import Text.Parsec as P 37 | import Text.Parsec.Text 38 | 39 | import Data.YAML.Event (ScalarStyle (..), Tag, isUntagged, mkTag, untagged) 40 | import qualified Data.YAML.Event as YE 41 | 42 | import Util 43 | 44 | -- | Primitive scalar types as defined in YAML 1.2 45 | data Scalar = SNull -- ^ @tag:yaml.org,2002:null@ 46 | | SBool !Bool -- ^ @tag:yaml.org,2002:bool@ 47 | | SFloat !Double -- ^ @tag:yaml.org,2002:float@ 48 | | SInt !Integer -- ^ @tag:yaml.org,2002:int@ 49 | | SStr !Text -- ^ @tag:yaml.org,2002:str@ 50 | 51 | | SUnknown !Tag !Text -- ^ unknown/unsupported tag or untagged (thus unresolved) scalar 52 | deriving (Eq,Ord,Show,Generic) 53 | 54 | -- | @since 0.2.0 55 | instance NFData Scalar where 56 | rnf SNull = () 57 | rnf (SBool _) = () 58 | rnf (SFloat _) = () 59 | rnf (SInt _) = () 60 | rnf (SStr _) = () 61 | rnf (SUnknown t _) = rnf t 62 | 63 | -- | Definition of a [YAML 1.2 Schema](http://yaml.org/spec/1.2/spec.html#Schema) 64 | -- 65 | -- A YAML schema defines how implicit tags are resolved to concrete tags and how data is represented textually in YAML. 66 | data SchemaResolver = SchemaResolver 67 | { schemaResolverScalar :: Tag -> YE.ScalarStyle -> T.Text -> Either String Scalar 68 | , schemaResolverSequence :: Tag -> Either String Tag 69 | , schemaResolverMapping :: Tag -> Either String Tag 70 | , schemaResolverMappingDuplicates :: Bool -- TODO: use something different from 'Bool' 71 | } 72 | 73 | 74 | data ScalarTag = ScalarBangTag -- ^ non-specific ! tag 75 | | ScalarQMarkTag -- ^ non-specific ? tag 76 | | ScalarTag !Tag -- ^ specific tag 77 | 78 | -- common logic for 'schemaResolverScalar' 79 | scalarTag :: (ScalarTag -> T.Text -> Either String Scalar) 80 | -> Tag -> YE.ScalarStyle -> T.Text -> Either String Scalar 81 | scalarTag f tag sty val = f tag' val 82 | where 83 | tag' = case sty of 84 | YE.Plain 85 | | tag == untagged -> ScalarQMarkTag -- implicit ? tag 86 | 87 | _ | tag == untagged -> ScalarBangTag -- implicit ! tag 88 | | tag == tagBang -> ScalarBangTag -- explicit ! tag 89 | | otherwise -> ScalarTag tag 90 | 91 | 92 | -- | \"Failsafe\" schema resolver as specified 93 | -- in [YAML 1.2 / 10.1.2. Tag Resolution](http://yaml.org/spec/1.2/spec.html#id2803036) 94 | failsafeSchemaResolver :: SchemaResolver 95 | failsafeSchemaResolver = SchemaResolver{..} 96 | where 97 | -- scalars 98 | schemaResolverScalar = scalarTag go 99 | where 100 | go ScalarBangTag v = Right (SStr v) 101 | go (ScalarTag t) v 102 | | t == tagStr = Right (SStr v) 103 | | otherwise = Right (SUnknown t v) 104 | go ScalarQMarkTag v = Right (SUnknown untagged v) -- leave unresolved 105 | 106 | -- mappings 107 | schemaResolverMapping t 108 | | t == tagBang = Right tagMap 109 | | otherwise = Right t 110 | 111 | schemaResolverMappingDuplicates = False 112 | 113 | -- sequences 114 | schemaResolverSequence t 115 | | t == tagBang = Right tagSeq 116 | | otherwise = Right t 117 | 118 | -- | Strict JSON schema resolver as specified 119 | -- in [YAML 1.2 / 10.2.2. Tag Resolution](http://yaml.org/spec/1.2/spec.html#id2804356) 120 | jsonSchemaResolver :: SchemaResolver 121 | jsonSchemaResolver = SchemaResolver{..} 122 | where 123 | -- scalars 124 | schemaResolverScalar = scalarTag go 125 | where 126 | go ScalarBangTag v = Right (SStr v) 127 | go (ScalarTag t) v 128 | | t == tagStr = Right (SStr v) 129 | | t == tagNull = if isNullLiteral v then Right SNull else Left ("invalid !!null " ++ show v) 130 | | t == tagInt = maybe (Left $ "invalid !!int " ++ show v) (Right . SInt) $ jsonDecodeInt v 131 | | t == tagFloat = maybe (Left $ "invalid !!float " ++ show v) (Right . SFloat) $ jsonDecodeFloat v 132 | | t == tagBool = maybe (Left $ "invalid !!bool " ++ show v) (Right . SBool) $ jsonDecodeBool v 133 | | otherwise = Right (SUnknown t v) -- unknown specific tag 134 | go ScalarQMarkTag v 135 | | isNullLiteral v = Right SNull 136 | | Just b <- jsonDecodeBool v = Right $! SBool b 137 | | Just i <- jsonDecodeInt v = Right $! SInt i 138 | | Just f <- jsonDecodeFloat v = Right $! SFloat f 139 | | otherwise = Right (SUnknown untagged v) -- leave unresolved -- FIXME: YAML 1.2 spec requires an error here 140 | 141 | isNullLiteral = (== "null") 142 | 143 | -- mappings 144 | schemaResolverMapping t 145 | | t == tagBang = Right tagMap 146 | | isUntagged t = Right tagMap 147 | | otherwise = Right t 148 | 149 | schemaResolverMappingDuplicates = False 150 | 151 | -- sequences 152 | schemaResolverSequence t 153 | | t == tagBang = Right tagSeq 154 | | isUntagged t = Right tagSeq 155 | | otherwise = Right t 156 | 157 | -- | Core schema resolver as specified 158 | -- in [YAML 1.2 / 10.3.2. Tag Resolution](http://yaml.org/spec/1.2/spec.html#id2805071) 159 | coreSchemaResolver :: SchemaResolver 160 | coreSchemaResolver = SchemaResolver{..} 161 | where 162 | -- scalars 163 | schemaResolverScalar = scalarTag go 164 | where 165 | go ScalarBangTag v = Right (SStr v) 166 | go (ScalarTag t) v 167 | | t == tagStr = Right (SStr v) 168 | | t == tagNull = if isNullLiteral v then Right SNull else Left ("invalid !!null " ++ show v) 169 | | t == tagInt = maybe (Left $ "invalid !!int " ++ show v) (Right . SInt) $ coreDecodeInt v 170 | | t == tagFloat = maybe (Left $ "invalid !!float " ++ show v) (Right . SFloat) $ coreDecodeFloat v 171 | | t == tagBool = maybe (Left $ "invalid !!bool " ++ show v) (Right . SBool) $ coreDecodeBool v 172 | | otherwise = Right (SUnknown t v) -- unknown specific tag 173 | go ScalarQMarkTag v 174 | | isNullLiteral v = Right SNull 175 | | Just b <- coreDecodeBool v = Right $! SBool b 176 | | Just i <- coreDecodeInt v = Right $! SInt i 177 | | Just f <- coreDecodeFloat v = Right $! SFloat f 178 | | otherwise = Right (SStr v) -- map to !!str by default 179 | 180 | isNullLiteral = flip Set.member (Set.fromList [ "", "null", "NULL", "Null", "~" ]) 181 | 182 | -- mappings 183 | schemaResolverMapping t 184 | | t == tagBang = Right tagMap 185 | | isUntagged t = Right tagMap 186 | | otherwise = Right t 187 | 188 | schemaResolverMappingDuplicates = False 189 | 190 | -- sequences 191 | schemaResolverSequence t 192 | | t == tagBang = Right tagSeq 193 | | isUntagged t = Right tagSeq 194 | | otherwise = Right t 195 | 196 | 197 | -- | @tag:yaml.org,2002:bool@ (JSON Schema) 198 | jsonDecodeBool :: T.Text -> Maybe Bool 199 | jsonDecodeBool "false" = Just False 200 | jsonDecodeBool "true" = Just True 201 | jsonDecodeBool _ = Nothing 202 | 203 | -- | @tag:yaml.org,2002:bool@ (Core Schema) 204 | coreDecodeBool :: T.Text -> Maybe Bool 205 | coreDecodeBool = flip Map.lookup $ 206 | Map.fromList [ ("true", True) 207 | , ("True", True) 208 | , ("TRUE", True) 209 | , ("false", False) 210 | , ("False", False) 211 | , ("FALSE", False) 212 | ] 213 | 214 | -- | @tag:yaml.org,2002:int@ according to JSON Schema 215 | -- 216 | -- > 0 | -? [1-9] [0-9]* 217 | jsonDecodeInt :: T.Text -> Maybe Integer 218 | jsonDecodeInt t | T.null t = Nothing 219 | jsonDecodeInt "0" = Just 0 220 | jsonDecodeInt t = do 221 | -- [-]? [1-9] [0-9]* 222 | let tabs | T.isPrefixOf "-" t = T.tail t 223 | | otherwise = t 224 | 225 | guard (not (T.null tabs)) 226 | guard (T.head tabs /= '0') 227 | guard (T.all C.isDigit tabs) 228 | 229 | readMaybe (T.unpack t) 230 | 231 | -- | @tag:yaml.org,2002:int@ according to Core Schema 232 | -- 233 | -- > [-+]? [0-9]+ (Base 10) 234 | -- > 0o [0-7]+ (Base 8) 235 | -- > 0x [0-9a-fA-F]+ (Base 16) 236 | -- 237 | coreDecodeInt :: T.Text -> Maybe Integer 238 | coreDecodeInt t 239 | | T.null t = Nothing 240 | 241 | -- > 0x [0-9a-fA-F]+ (Base 16) 242 | | Just rest <- T.stripPrefix "0x" t 243 | , T.all C.isHexDigit rest 244 | , [(j,"")] <- readHex (T.unpack rest) 245 | = Just $! j 246 | 247 | -- 0o [0-7]+ (Base 8) 248 | | Just rest <- T.stripPrefix "0o" t 249 | , T.all C.isOctDigit rest 250 | , [(j,"")] <- readOct (T.unpack rest) 251 | = Just $! j 252 | 253 | -- [-+]? [0-9]+ (Base 10) 254 | | T.all C.isDigit t 255 | = Just $! read (T.unpack t) 256 | 257 | | Just rest <- T.stripPrefix "+" t 258 | , not (T.null rest) 259 | , T.all C.isDigit rest 260 | = Just $! read (T.unpack rest) 261 | 262 | | Just rest <- T.stripPrefix "-" t 263 | , not (T.null rest) 264 | , T.all C.isDigit rest 265 | = Just $! read (T.unpack t) 266 | 267 | | otherwise = Nothing 268 | 269 | 270 | -- | @tag:yaml.org,2002:float@ according to JSON Schema 271 | -- 272 | -- > -? ( 0 | [1-9] [0-9]* ) ( \. [0-9]* )? ( [eE] [-+]? [0-9]+ )? 273 | -- 274 | jsonDecodeFloat :: T.Text -> Maybe Double 275 | jsonDecodeFloat = either (const Nothing) Just . parse float "" 276 | where 277 | float :: Parser Double 278 | float = do 279 | -- -? 280 | p0 <- option "" ("-" <$ char '-') 281 | 282 | -- ( 0 | [1-9] [0-9]* ) 283 | p1 <- do 284 | d <- digit 285 | if (d /= '0') 286 | then (d:) <$> P.many digit 287 | else pure [d] 288 | 289 | -- ( \. [0-9]* )? 290 | p2 <- option "" $ (:) <$> char '.' <*> option "0" (many1 digit) 291 | 292 | -- ( [eE] [-+]? [0-9]+ )? 293 | p3 <- option "" $ do 294 | void (char 'e' P.<|> char 'E') 295 | s <- option "" (("-" <$ char '-') P.<|> ("" <$ char '+')) 296 | d <- P.many1 digit 297 | 298 | pure ("e" ++ s ++ d) 299 | 300 | eof 301 | 302 | let t' = p0++p1++p2++p3 303 | pure $! read t' 304 | 305 | -- | @tag:yaml.org,2002:float@ according to Core Schema 306 | -- 307 | -- > [-+]? ( \. [0-9]+ | [0-9]+ ( \. [0-9]* )? ) ( [eE] [-+]? [0-9]+ )? 308 | -- 309 | coreDecodeFloat :: T.Text -> Maybe Double 310 | coreDecodeFloat t 311 | | Just j <- Map.lookup t literals = Just j -- short-cut 312 | | otherwise = either (const Nothing) Just . parse float "" $ t 313 | where 314 | float :: Parser Double 315 | float = do 316 | -- [-+]? 317 | p0 <- option "" (("-" <$ char '-') P.<|> "" <$ char '+') 318 | 319 | -- ( \. [0-9]+ | [0-9]+ ( \. [0-9]* )? ) 320 | p1 <- (char '.' *> (("0."++) <$> many1 digit)) 321 | P.<|> do d1 <- many1 digit 322 | d2 <- option "" $ (:) <$> char '.' <*> option "0" (many1 digit) 323 | pure (d1++d2) 324 | 325 | -- ( [eE] [-+]? [0-9]+ )? 326 | p2 <- option "" $ do 327 | void (char 'e' P.<|> char 'E') 328 | s <- option "" (("-" <$ char '-') P.<|> ("" <$ char '+')) 329 | d <- P.many1 digit 330 | 331 | pure ("e" ++ s ++ d) 332 | 333 | eof 334 | 335 | let t' = p0++p1++p2 336 | 337 | pure $! read t' 338 | 339 | literals = Map.fromList 340 | [ ("0" , 0) 341 | 342 | , (".nan", (0/0)) 343 | , (".NaN", (0/0)) 344 | , (".NAN", (0/0)) 345 | 346 | , (".inf", (1/0)) 347 | , (".Inf", (1/0)) 348 | , (".INF", (1/0)) 349 | 350 | , ("+.inf", (1/0)) 351 | , ("+.Inf", (1/0)) 352 | , ("+.INF", (1/0)) 353 | 354 | , ("-.inf", (-1/0)) 355 | , ("-.Inf", (-1/0)) 356 | , ("-.INF", (-1/0)) 357 | ] 358 | 359 | -- | Some tags specified in YAML 1.2 360 | tagNull, tagBool, tagStr, tagInt, tagFloat, tagSeq, tagMap, tagBang :: Tag 361 | tagNull = mkTag "tag:yaml.org,2002:null" 362 | tagStr = mkTag "tag:yaml.org,2002:str" 363 | tagInt = mkTag "tag:yaml.org,2002:int" 364 | tagFloat = mkTag "tag:yaml.org,2002:float" 365 | tagBool = mkTag "tag:yaml.org,2002:bool" 366 | tagSeq = mkTag "tag:yaml.org,2002:seq" 367 | tagMap = mkTag "tag:yaml.org,2002:map" 368 | tagBang = mkTag "!" 369 | 370 | 371 | -- | @since 0.2.0 372 | data SchemaEncoder = SchemaEncoder 373 | { schemaEncoderScalar :: Scalar -> Either String (Tag, ScalarStyle, T.Text) 374 | , schemaEncoderSequence :: Tag -> Either String Tag 375 | , schemaEncoderMapping :: Tag -> Either String Tag 376 | } 377 | 378 | mappingTag :: Tag -> Either String Tag 379 | mappingTag t 380 | | t == tagMap = Right untagged 381 | | otherwise = Right t 382 | 383 | seqTag :: Tag -> Either String Tag 384 | seqTag t 385 | | t == tagSeq = Right untagged 386 | | otherwise = Right t 387 | 388 | 389 | -- | \"Failsafe\" schema encoder as specified 390 | -- in [YAML 1.2 / 10.1.2. Tag Resolution](http://yaml.org/spec/1.2/spec.html#id2803036) 391 | -- 392 | -- @since 0.2.0 393 | failsafeSchemaEncoder :: SchemaEncoder 394 | failsafeSchemaEncoder = SchemaEncoder{..} 395 | where 396 | 397 | schemaEncoderScalar s = case s of 398 | SNull -> Left "SNull scalar type not supported in failsafeSchemaEncoder" 399 | SBool _ -> Left "SBool scalar type not supported in failsafeSchemaEncoder" 400 | SFloat _ -> Left "SFloat scalar type not supported in failsafeSchemaEncoder" 401 | SInt _ -> Left "SInt scalar type not supported in failsafeSchemaEncoder" 402 | SStr text -> failEncodeStr text 403 | SUnknown t v -> Right (t, DoubleQuoted, v) 404 | 405 | schemaEncoderMapping = mappingTag 406 | schemaEncoderSequence = seqTag 407 | 408 | -- | Strict JSON schema encoder as specified 409 | -- in [YAML 1.2 / 10.2.2. Tag Resolution](http://yaml.org/spec/1.2/spec.html#id2804356) 410 | -- 411 | -- @since 0.2.0 412 | jsonSchemaEncoder :: SchemaEncoder 413 | jsonSchemaEncoder = SchemaEncoder{..} 414 | where 415 | 416 | schemaEncoderScalar s = case s of 417 | SNull -> Right (untagged, Plain, "null") 418 | SBool bool -> Right (untagged, Plain, encodeBool bool) 419 | SFloat double -> Right (untagged, Plain, encodeDouble double) 420 | SInt int -> Right (untagged, Plain, encodeInt int) 421 | SStr text -> jsonEncodeStr text 422 | SUnknown _ _ -> Left "SUnknown scalar type not supported in jsonSchemaEncoder" 423 | 424 | schemaEncoderMapping = mappingTag 425 | schemaEncoderSequence = seqTag 426 | 427 | -- | Core schema encoder as specified 428 | -- in [YAML 1.2 / 10.3.2. Tag Resolution](http://yaml.org/spec/1.2/spec.html#id2805071) 429 | -- 430 | -- @since 0.2.0 431 | coreSchemaEncoder :: SchemaEncoder 432 | coreSchemaEncoder = SchemaEncoder{..} 433 | where 434 | 435 | schemaEncoderScalar s = case s of 436 | SNull -> Right (untagged, Plain, "null") 437 | SBool bool -> Right (untagged, Plain, encodeBool bool) 438 | SFloat double -> Right (untagged, Plain, encodeDouble double) 439 | SInt int -> Right (untagged, Plain, encodeInt int) 440 | SStr text -> coreEncodeStr text 441 | SUnknown t v -> Right (t, DoubleQuoted, v) 442 | 443 | schemaEncoderMapping = mappingTag 444 | schemaEncoderSequence = seqTag 445 | 446 | -- | Encode Boolean 447 | -- 448 | -- @since 0.2.0 449 | encodeBool :: Bool -> T.Text 450 | encodeBool b = if b then "true" else "false" 451 | 452 | -- | Encode Double 453 | -- 454 | -- @since 0.2.0 455 | encodeDouble :: Double -> T.Text 456 | encodeDouble d 457 | | d /= d = ".nan" 458 | | d == (1/0) = ".inf" 459 | | d == (-1/0) = "-.inf" 460 | | otherwise = T.pack . show $ d 461 | 462 | -- | Encode Integer 463 | -- 464 | -- @since 0.2.0 465 | encodeInt :: Integer -> T.Text 466 | encodeInt = T.pack . show 467 | 468 | 469 | failEncodeStr :: T.Text -> Either String (Tag, ScalarStyle, T.Text) 470 | failEncodeStr t 471 | | T.isPrefixOf " " t = Right (untagged, DoubleQuoted, t) 472 | | T.last t == ' ' = Right (untagged, DoubleQuoted, t) 473 | | T.any (not. isPlainChar) t = Right (untagged, DoubleQuoted, t) 474 | | otherwise = Right (untagged, Plain, t) 475 | 476 | jsonEncodeStr :: T.Text -> Either String (Tag, ScalarStyle, T.Text) 477 | jsonEncodeStr t 478 | | T.null t = Right (untagged, DoubleQuoted, t) 479 | | T.isPrefixOf " " t = Right (untagged, DoubleQuoted, t) 480 | | T.last t == ' ' = Right (untagged, DoubleQuoted, t) 481 | | T.any (not. isPlainChar) t = Right (untagged, DoubleQuoted, t) 482 | | isAmbiguous jsonSchemaResolver t = Right (untagged, DoubleQuoted, t) 483 | | otherwise = Right (untagged, Plain, t) 484 | 485 | coreEncodeStr :: T.Text -> Either String (Tag, ScalarStyle, T.Text) 486 | coreEncodeStr t 487 | | T.null t = Right (untagged, DoubleQuoted, t) 488 | | T.isPrefixOf " " t = Right (untagged, DoubleQuoted, t) 489 | | T.last t == ' ' = Right (untagged, DoubleQuoted, t) 490 | | T.any (not. isPlainChar) t = Right (untagged, DoubleQuoted, t) 491 | | isAmbiguous coreSchemaResolver t = Right (untagged, DoubleQuoted, t) 492 | | otherwise = Right (untagged, Plain, t) 493 | 494 | -- | These are some characters which can be used in 'Plain' 'Scalar's safely without any quotes (see ). 495 | -- 496 | -- __NOTE__: This does not mean that other characters (like @"\\n"@ and other special characters like @"-?:,[]{}#&*!,>%\@`\"\'"@) cannot be used in 'Plain' 'Scalar's. 497 | -- 498 | -- @since 0.2.0 499 | isPlainChar :: Char -> Bool 500 | isPlainChar c = C.isAlphaNum c || c `elem` (" ~$^+=%@`\\'\"" 501 | 502 | -- | Returns True if the string can be decoded by the given 'SchemaResolver' 503 | -- into a 'Scalar' which is not a of type 'SStr'. 504 | -- 505 | -- >>> isAmbiguous coreSchemaResolver "true" 506 | -- True 507 | -- 508 | -- >>> isAmbiguous failSchemaResolver "true" 509 | -- False 510 | -- 511 | -- @since 0.2.0 512 | isAmbiguous :: SchemaResolver -> T.Text -> Bool 513 | isAmbiguous SchemaResolver{..} t = case schemaResolverScalar untagged Plain t of 514 | Left err -> error err 515 | Right (SStr _ ) -> False 516 | Right _ -> True 517 | 518 | -- | According to YAML 1.2 'coreSchemaEncoder' is the default 'SchemaEncoder' 519 | -- 520 | -- By default, 'Scalar's are encoded as follows: 521 | -- 522 | -- * String which are made of Plain Characters (see 'isPlainChar'), unambiguous (see 'isAmbiguous') and do not contain any leading/trailing spaces are encoded as 'Plain' 'Scalar'. 523 | -- 524 | -- * Rest of the strings are encoded in DoubleQuotes 525 | -- 526 | -- * Booleans are encoded using 'encodeBool' 527 | -- 528 | -- * Double values are encoded using 'encodeDouble' 529 | -- 530 | -- * Integral values are encoded using 'encodeInt' 531 | -- 532 | -- @since 0.2.0 533 | defaultSchemaEncoder :: SchemaEncoder 534 | defaultSchemaEncoder = coreSchemaEncoder 535 | 536 | -- | Set the 'Scalar' style in the encoded YAML. This is a function that decides 537 | -- for each 'Scalar' the type of YAML string to output. 538 | -- 539 | -- __WARNING__: You must ensure that special strings (like @"true"@\/@"false"@\/@"null"@\/@"1234"@) are not encoded with the 'Plain' style, because 540 | -- then they will be decoded as boolean, null or numeric values. You can use 'isAmbiguous' to detect them. 541 | -- 542 | -- __NOTE__: For different 'SchemaResolver's, different strings are ambiguous. For example, @"true"@ is not ambiguous for 'failsafeSchemaResolver'. 543 | -- 544 | -- @since 0.2.0 545 | setScalarStyle :: (Scalar -> Either String (Tag, ScalarStyle, T.Text)) -> SchemaEncoder -> SchemaEncoder 546 | setScalarStyle customScalarEncoder encoder = encoder { schemaEncoderScalar = customScalarEncoder } 547 | 548 | -------------------------------------------------------------------------------- /src/Data/YAML/Event/Writer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE Safe #-} 4 | 5 | 6 | -- | 7 | -- Copyright: © Herbert Valerio Riedel 2015-2018 8 | -- SPDX-License-Identifier: GPL-2.0-or-later 9 | -- 10 | -- Event-stream oriented YAML writer API 11 | -- 12 | module Data.YAML.Event.Writer 13 | ( writeEvents 14 | , writeEventsText 15 | ) where 16 | 17 | import Data.YAML.Event.Internal 18 | 19 | import qualified Data.ByteString.Lazy as BS.L 20 | import qualified Data.Char as C 21 | import qualified Data.Map as Map 22 | import qualified Data.Text as T 23 | import Text.Printf (printf) 24 | 25 | import qualified Data.Text.Lazy as T.L 26 | import qualified Data.Text.Lazy.Builder as T.B 27 | import qualified Data.Text.Lazy.Encoding as T.L 28 | 29 | import Util 30 | 31 | 32 | {- WARNING: the code that follows will make you cry; a safety pig is provided below for your benefit. 33 | 34 | _ 35 | _._ _..._ .-', _.._(`)) 36 | '-. ` ' /-._.-' ',/ 37 | ) \ '. 38 | / _ _ | \ 39 | | a a / | 40 | \ .-. ; 41 | '-('' ).-' ,' ; 42 | '-; | .' 43 | \ \ / 44 | | 7 .__ _.-\ \ 45 | | | | ``/ /` / 46 | /,_| | /,_/ / 47 | /,_/ '`-' 48 | 49 | -} 50 | 51 | -- | Serialise 'Event's using specified UTF encoding to a lazy 'BS.L.ByteString' 52 | -- 53 | -- __NOTE__: This function is only well-defined for valid 'Event' streams 54 | -- 55 | -- @since 0.2.0.0 56 | writeEvents :: Encoding -> [Event] -> BS.L.ByteString 57 | writeEvents UTF8 = T.L.encodeUtf8 . writeEventsText 58 | writeEvents UTF16LE = T.L.encodeUtf16LE . T.L.cons '\xfeff' . writeEventsText 59 | writeEvents UTF16BE = T.L.encodeUtf16BE . T.L.cons '\xfeff' . writeEventsText 60 | writeEvents UTF32LE = T.L.encodeUtf32LE . T.L.cons '\xfeff' . writeEventsText 61 | writeEvents UTF32BE = T.L.encodeUtf32BE . T.L.cons '\xfeff' . writeEventsText 62 | 63 | -- | Serialise 'Event's to lazy 'T.L.Text' 64 | -- 65 | -- __NOTE__: This function is only well-defined for valid 'Event' streams 66 | -- 67 | -- @since 0.2.0.0 68 | writeEventsText :: [Event] -> T.L.Text 69 | writeEventsText [] = mempty 70 | writeEventsText (StreamStart:xs) = T.B.toLazyText $ goStream xs (error "writeEvents: internal error") 71 | where 72 | -- goStream :: [Event] -> [Event] -> T.B.Builder 73 | goStream [StreamEnd] _ = mempty 74 | goStream (StreamEnd : _ : _ ) _cont = error "writeEvents: events after StreamEnd" 75 | goStream (Comment com: rest) cont = goComment (0 :: Int) True BlockIn com (goStream rest cont) 76 | goStream (DocumentStart marker : rest) cont 77 | = case marker of 78 | NoDirEndMarker -> putNode False rest (\zs -> goDoc zs cont) 79 | DirEndMarkerNoVersion -> "---" <> putNode True rest (\zs -> goDoc zs cont) 80 | DirEndMarkerVersion mi -> "%YAML 1." <> (T.B.fromString (show mi)) <> "\n---" <> putNode True rest (\zs -> goDoc zs cont) 81 | goStream (x:_) _cont = error ("writeEvents: unexpected " ++ show x ++ " (expected DocumentStart or StreamEnd)") 82 | goStream [] _cont = error ("writeEvents: unexpected end of stream (expected DocumentStart or StreamEnd)") 83 | 84 | goDoc (DocumentEnd marker : rest) cont 85 | = (if marker then "...\n" else mempty) <> goStream rest cont 86 | goDoc (Comment com: rest) cont = goComment (0 :: Int) True BlockIn com (goDoc rest cont) 87 | goDoc ys _ = error (show ys) 88 | 89 | -- unexpected s l = error ("writeEvents: unexpected " ++ show l ++ " " ++ show s) 90 | 91 | writeEventsText (x:_) = error ("writeEvents: unexpected " ++ show x ++ " (expected StreamStart)") 92 | 93 | -- | Production context -- copied from Data.YAML.Token 94 | data Context = BlockOut -- ^ Outside block sequence. 95 | | BlockIn -- ^ Inside block sequence. 96 | | BlockKey -- ^ Implicit block key. 97 | | FlowOut -- ^ Outside flow collection. 98 | | FlowIn -- ^ Inside flow collection. 99 | | FlowKey -- ^ Implicit flow key. 100 | deriving (Eq,Show) 101 | 102 | goComment :: Int -> Bool -> Context -> T.Text -> T.B.Builder -> T.B.Builder 103 | goComment !n !sol c comment cont = doSol <> "#" <> (T.B.fromText comment) <> doEol <> doIndent <> cont 104 | where 105 | doEol 106 | | not sol && n == 0 = mempty -- "--- " case 107 | | sol && FlowIn == c = mempty 108 | | otherwise = eol 109 | 110 | doSol 111 | | not sol && (BlockOut == c || FlowOut == c) = ws 112 | | sol = mkInd n' 113 | | otherwise = eol <> mkInd n' 114 | 115 | n' 116 | | BlockOut <- c = max 0 (n - 1) 117 | | FlowOut <- c = n + 1 118 | | otherwise = n 119 | 120 | doIndent 121 | | BlockOut <- c = mkInd n' 122 | | FlowOut <- c = mkInd n' 123 | | otherwise = mempty 124 | 125 | putNode :: Bool -> [Event] -> ([Event] -> T.B.Builder) -> T.B.Builder 126 | putNode = \docMarker -> go (-1 :: Int) (not docMarker) BlockIn 127 | where 128 | 129 | {- s-l+block-node(n,c) 130 | 131 | [196] s-l+block-node(n,c) ::= s-l+block-in-block(n,c) | s-l+flow-in-block(n) 132 | 133 | [197] s-l+flow-in-block(n) ::= s-separate(n+1,flow-out) ns-flow-node(n+1,flow-out) s-l-comments 134 | 135 | [198] s-l+block-in-block(n,c) ::= s-l+block-scalar(n,c) | s-l+block-collection(n,c) 136 | 137 | [199] s-l+block-scalar(n,c) ::= s-separate(n+1,c) ( c-ns-properties(n+1,c) s-separate(n+1,c) )? ( c-l+literal(n) | c-l+folded(n) ) 138 | 139 | [200] s-l+block-collection(n,c) ::= ( s-separate(n+1,c) c-ns-properties(n+1,c) )? s-l-comments 140 | ( l+block-sequence(seq-spaces(n,c)) | l+block-mapping(n) ) 141 | 142 | [201] seq-spaces(n,c) ::= c = block-out ⇒ n-1 143 | c = block-in ⇒ n 144 | 145 | -} 146 | 147 | go :: Int -> Bool -> Context -> [Event] -> ([Event] -> T.B.Builder) -> T.B.Builder 148 | go _ _ _ [] _cont = error ("putNode: expected node-start event instead of end-of-stream") 149 | go !n !sol c (t : rest) cont = case t of 150 | Scalar anc tag sty t' -> goStr (n+1) sol c anc tag sty t' (cont rest) 151 | SequenceStart anc tag sty -> goSeq (n+1) sol (chn sty) anc tag sty rest cont 152 | MappingStart anc tag sty -> goMap (n+1) sol (chn sty) anc tag sty rest cont 153 | Alias a -> pfx <> goAlias c a (cont rest) 154 | Comment com -> goComment (n+1) sol c com (go n sol c rest cont) 155 | _ -> error ("putNode: expected node-start event instead of " ++ show t) 156 | 157 | where 158 | pfx | sol = mempty 159 | | BlockKey <- c = mempty 160 | | FlowKey <- c = mempty 161 | | otherwise = T.B.singleton ' ' 162 | 163 | chn sty 164 | | Flow <-sty, (BlockIn == c || BlockOut == c) = FlowOut 165 | | otherwise = c 166 | 167 | 168 | goMap _ sol _ anc tag _ (MappingEnd : rest) cont = pfx $ "{}\n" <> cont rest 169 | where 170 | pfx cont' = wsSol sol <> anchorTag'' (Right ws) anc tag cont' 171 | 172 | goMap n sol c anc tag Block xs cont = case c of 173 | BlockIn | not (not sol && n == 0) -- avoid "--- " case 174 | -> wsSol sol <> anchorTag'' (Right (eol <> mkInd n)) anc tag 175 | (putKey xs putValue') 176 | _ -> anchorTag'' (Left ws) anc tag $ doEol <> g' xs 177 | where 178 | g' (MappingEnd : rest) = cont rest -- All comments should be part of the key 179 | g' ys = pfx <> putKey ys putValue' 180 | 181 | g (Comment com: rest) = goComment n True c' com (g rest) -- For trailing comments 182 | g (MappingEnd : rest) = cont rest 183 | g ys = pfx <> putKey ys putValue' 184 | 185 | pfx = if c == BlockIn || c == BlockOut || c == BlockKey then mkInd n else ws 186 | c' = if FlowIn == c then FlowKey else BlockKey 187 | 188 | doEol = case c of 189 | FlowKey -> mempty 190 | FlowIn -> mempty 191 | _ -> eol 192 | 193 | putKey zs cont2 194 | | isSmallKey zs = go n (n == 0) c' zs (\ys -> ":" <> cont2 ys) 195 | | Comment com: rest <- zs = "?" <> ws <> goComment 0 True BlockIn com (f rest cont2) 196 | | otherwise = "?" <> go n False BlockIn zs (putValue cont2) 197 | 198 | f (Comment com: rest) cont2 = goComment (n + 1) True BlockIn com (f rest cont2) -- Comments should not change position in key 199 | f zs cont2 = ws <> mkInd n <> go n False BlockIn zs (putValue cont2) 200 | 201 | putValue cont2 zs 202 | | FlowIn <- c = ws <> mkInd (n - 1) <> ":" <> cont2 zs 203 | | otherwise = mkInd n <> ":" <> cont2 zs 204 | 205 | putValue' (Comment com: rest) = goComment (n + 1) False BlockOut com (ws <> putValue' rest) -- Comments should not change position in value 206 | putValue' zs = go n False (if FlowIn == c then FlowIn else BlockOut) zs g 207 | 208 | goMap n sol c anc tag Flow xs cont = 209 | wsSol sol <> anchorTag'' (Right ws) anc tag ("{" <> f xs) 210 | where 211 | f (Comment com: rest) = eol <> wsSol sol <> goComment n' True (inFlow c) com (f rest) 212 | f (MappingEnd : rest) = eol <> wsSol sol <> mkInd (n - 1) <> "}" <> doEol <> cont rest 213 | f ys = eol <> mkInd n' <> putKey ys putValue' 214 | 215 | n' = n + 1 216 | 217 | doEol = case c of 218 | FlowKey -> mempty 219 | FlowIn -> mempty 220 | _ -> eol 221 | 222 | g (Comment com: rest) = "," <> eol <> wsSol sol <> goComment n' True (inFlow c) com (f rest) 223 | g (MappingEnd : rest) = eol <> wsSol sol <> mkInd (n - 1) <> "}" <> doEol <> cont rest 224 | g ys = "," <> eol <> mkInd n' <> putKey ys putValue' 225 | 226 | putKey zs cont2 227 | | (Comment com: rest) <- zs = goComment n' True c com (eol <> mkInd n' <> putKey rest cont2) 228 | | isSmallKey zs = go n' (n == 0) FlowKey zs (if isComEv zs then putValue cont2 else (\ys -> ":" <> cont2 ys)) 229 | | otherwise = "?" <> go n False FlowIn zs (putValue cont2) 230 | 231 | putValue cont2 zs 232 | | Comment com: rest <- zs = eol <> wsSol sol <> goComment n' True (inFlow c) com (putValue cont2 rest) 233 | | otherwise = eol <> mkInd n' <> ":" <> cont2 zs 234 | 235 | putValue' zs 236 | | Comment com : rest <- zs = goComment n' False FlowOut com (putValue' rest) 237 | | otherwise = go n' False FlowIn zs g 238 | 239 | 240 | goSeq _ sol _ anc tag _ (SequenceEnd : rest) cont = pfx $ "[]\n" <> cont rest 241 | where 242 | pfx cont' = wsSol sol <> anchorTag'' (Right ws) anc tag cont' 243 | 244 | goSeq n sol c anc tag Block xs cont = case c of 245 | BlockOut -> anchorTag'' (Left ws) anc tag (eol <> if isComEv xs then "-" <> eol <> f xs else g xs) 246 | 247 | BlockIn 248 | | not sol && n == 0 {- "---" case -} -> goSeq n sol BlockOut anc tag Block xs cont 249 | | Comment com: rest <- xs -> wsSol sol <> anchorTag'' (Right (eol <> mkInd n')) anc tag ("-" <> ws <> goComment 0 True BlockIn com (f rest)) 250 | | otherwise -> wsSol sol <> anchorTag'' (Right (eol <> mkInd n')) anc tag ("-" <> go n' False BlockIn xs g) 251 | 252 | BlockKey -> error "sequence in block-key context not supported" 253 | 254 | _ -> error "Invalid Context in Block style" 255 | 256 | where 257 | n' | BlockOut <- c = max 0 (n - 1) 258 | | otherwise = n 259 | 260 | g (Comment com: rest) = goComment n' True BlockIn com (g rest) 261 | g (SequenceEnd : rest) = cont rest 262 | g ys = mkInd n' <> "-" <> go n' False BlockIn ys g 263 | 264 | f (Comment com: rest) = goComment n' True BlockIn com (f rest) 265 | f (SequenceEnd : rest) = cont rest 266 | f ys = ws <> mkInd n' <> go n' False BlockIn ys g 267 | 268 | goSeq n sol c anc tag Flow xs cont = 269 | wsSol sol <> anchorTag'' (Right ws) anc tag ("[" <> f xs) 270 | where 271 | f (Comment com: rest) = eol <> wsSol sol <> goComment n' True (inFlow c) com (f rest) 272 | f (SequenceEnd : rest) = eol <> wsSol sol <> mkInd (n - 1) <> "]" <> doEol <> cont rest 273 | f ys = eol <> mkInd n' <> go n' False (inFlow c) ys g 274 | 275 | n' = n + 1 276 | 277 | doEol = case c of 278 | FlowKey -> mempty 279 | FlowIn -> mempty 280 | _ -> eol 281 | 282 | g (Comment com: rest) = "," <> eol <> wsSol sol <> goComment n' True (inFlow c) com (f rest) 283 | g (SequenceEnd : rest) = eol <> wsSol sol <> mkInd (n - 1) <> "]" <> doEol <> cont rest 284 | g ys = "," <> eol <> mkInd n' <> go n' False (inFlow c) ys g 285 | 286 | 287 | goAlias c a cont = T.B.singleton '*' <> T.B.fromText a <> sep <> cont 288 | where 289 | sep = case c of 290 | BlockIn -> eol 291 | BlockOut -> eol 292 | BlockKey -> T.B.singleton ' ' 293 | FlowIn -> mempty 294 | FlowOut -> eol 295 | FlowKey -> T.B.singleton ' ' 296 | 297 | goStr :: Int -> Bool -> Context -> Maybe Anchor -> Tag -> ScalarStyle -> Text -> T.B.Builder -> T.B.Builder 298 | goStr !n !sol c anc tag sty t cont = case sty of 299 | -- flow-style 300 | 301 | Plain -- empty scalars 302 | | t == "" -> case () of 303 | _ | Nothing <- anc, Tag Nothing <- tag -> contEol -- not even node properties 304 | | sol -> anchorTag0 anc tag (if c == BlockKey || c == FlowKey then ws <> cont else contEol) 305 | | BlockKey <- c -> anchorTag0 anc tag (ws <> cont) 306 | | FlowKey <- c -> anchorTag0 anc tag (ws <> cont) 307 | | otherwise -> anchorTag'' (Left ws) anc tag contEol 308 | 309 | Plain -> pfx $ 310 | let h [] = contEol 311 | h (x:xs) = T.B.fromText x <> f' xs 312 | where 313 | f' [] = contEol 314 | f' (y:ys) = eol <> mkInd (n+1) <> T.B.fromText y <> f' ys 315 | in h (insFoldNls (T.lines t)) -- FIXME: unquoted plain-strings can't handle leading/trailing whitespace properly 316 | 317 | SingleQuoted -> pfx $ T.B.singleton '\'' <> f (insFoldNls $ T.lines (T.replace "'" "''" t) ++ [ mempty | T.isSuffixOf "\n" t]) (T.B.singleton '\'' <> contEol) -- FIXME: leading white-space (i.e. SPC) before/after LF 318 | 319 | DoubleQuoted -> pfx $ T.B.singleton '"' <> T.B.fromText (escapeDQ t) <> T.B.singleton '"' <> contEol 320 | 321 | -- block style 322 | Folded chm iden -> pfx $ ">" <> goChomp chm <> goDigit iden <> g (insFoldNls' $ T.lines t) (fromEnum iden) cont 323 | 324 | Literal chm iden -> pfx $ "|" <> goChomp chm <> goDigit iden <> g (T.lines t) (fromEnum iden) cont 325 | 326 | where 327 | goDigit :: IndentOfs -> T.B.Builder 328 | goDigit iden = let ch = C.intToDigit.fromEnum $ iden 329 | in if(ch == '0') then mempty else T.B.singleton ch 330 | 331 | goChomp :: Chomp -> T.B.Builder 332 | goChomp chm = case chm of 333 | Strip -> T.B.singleton '-' 334 | Clip -> mempty 335 | Keep -> T.B.singleton '+' 336 | 337 | pfx cont' = (if sol || c == BlockKey || c == FlowKey then mempty else ws) <> anchorTag'' (Right ws) anc tag cont' 338 | 339 | doEol = case c of 340 | BlockKey -> False 341 | FlowKey -> False 342 | FlowIn -> False 343 | _ -> True 344 | 345 | contEol 346 | | doEol = eol <> cont 347 | | otherwise = cont 348 | 349 | g [] _ cont' = eol <> cont' 350 | g (x:xs) dig cont' 351 | | T.null x = eol <> g xs dig cont' 352 | | dig == 0 = eol <> (if n > 0 then mkInd n else mkInd' 1) <> T.B.fromText x <> g xs dig cont' 353 | | otherwise = eol <> mkInd (n-1) <> mkInd' dig <> T.B.fromText x <> g xs dig cont' 354 | 355 | g' [] cont' = cont' 356 | g' (x:xs) cont' = eol <> mkInd (n+1) <> T.B.fromText x <> g' xs cont' 357 | 358 | f [] cont' = cont' 359 | f (x:xs) cont' = T.B.fromText x <> g' xs cont' 360 | 361 | 362 | isSmallKey (Alias _ : _) = True 363 | isSmallKey (Scalar _ _ (Folded _ _) _: _) = False 364 | isSmallKey (Scalar _ _ (Literal _ _) _: _) = False 365 | isSmallKey (Scalar _ _ _ _ : _) = True 366 | isSmallKey (SequenceStart _ _ _ : _) = False 367 | isSmallKey (MappingStart _ _ _ : _) = False 368 | isSmallKey _ = False 369 | 370 | -- 371 | inFlow c = case c of 372 | FlowIn -> FlowIn 373 | FlowOut -> FlowIn 374 | BlockKey -> FlowKey 375 | FlowKey -> FlowKey 376 | _ -> error "Invalid context in Flow style" 377 | 378 | 379 | putTag t cont 380 | | Just t' <- T.stripPrefix "tag:yaml.org,2002:" t = "!!" <> T.B.fromText t' <> cont 381 | | "!" `T.isPrefixOf` t = T.B.fromText t <> cont 382 | | otherwise = "!<" <> T.B.fromText t <> T.B.singleton '>' <> cont 383 | 384 | anchorTag'' :: Either T.B.Builder T.B.Builder -> Maybe Anchor -> Tag -> T.B.Builder -> T.B.Builder 385 | anchorTag'' _ Nothing (Tag Nothing) cont = cont 386 | anchorTag'' (Right pad) Nothing (Tag (Just t)) cont = putTag t (pad <> cont) 387 | anchorTag'' (Right pad) (Just a) (Tag Nothing) cont = T.B.singleton '&' <> T.B.fromText a <> pad <> cont 388 | anchorTag'' (Right pad) (Just a) (Tag (Just t)) cont = T.B.singleton '&' <> T.B.fromText a <> T.B.singleton ' ' <> putTag t (pad <> cont) 389 | anchorTag'' (Left pad) Nothing (Tag (Just t)) cont = pad <> putTag t cont 390 | anchorTag'' (Left pad) (Just a) (Tag Nothing) cont = pad <> T.B.singleton '&' <> T.B.fromText a <> cont 391 | anchorTag'' (Left pad) (Just a) (Tag (Just t)) cont = pad <> T.B.singleton '&' <> T.B.fromText a <> T.B.singleton ' ' <> putTag t cont 392 | 393 | anchorTag0 = anchorTag'' (Left mempty) 394 | -- anchorTag = anchorTag'' (Right (T.B.singleton ' ')) 395 | -- anchorTag' = anchorTag'' (Left (T.B.singleton ' ')) 396 | 397 | isComEv :: [Event] -> Bool 398 | isComEv (Comment _: _) = True 399 | isComEv _ = False 400 | 401 | -- indentation helper 402 | mkInd :: Int -> T.B.Builder 403 | mkInd (-1) = mempty 404 | mkInd 0 = mempty 405 | mkInd 1 = " " 406 | mkInd 2 = " " 407 | mkInd 3 = " " 408 | mkInd 4 = " " 409 | mkInd l 410 | | l < 0 = error (show l) 411 | | otherwise = T.B.fromText (T.replicate l " ") 412 | 413 | mkInd' :: Int -> T.B.Builder 414 | mkInd' 1 = " " 415 | mkInd' 2 = " " 416 | mkInd' 3 = " " 417 | mkInd' 4 = " " 418 | mkInd' 5 = " " 419 | mkInd' 6 = " " 420 | mkInd' 7 = " " 421 | mkInd' 8 = " " 422 | mkInd' 9 = " " 423 | mkInd' l = error ("Impossible Indentation-level" ++ show l) 424 | 425 | eol, ws:: T.B.Builder 426 | eol = T.B.singleton '\n' 427 | ws = T.B.singleton ' ' 428 | 429 | wsSol :: Bool -> T.B.Builder 430 | wsSol sol = if sol then mempty else ws 431 | 432 | escapeDQ :: Text -> Text 433 | escapeDQ t 434 | | T.all (\c -> C.isPrint c && c /= '\\' && c /= '"') t = t 435 | | otherwise = T.concatMap escapeChar t 436 | 437 | escapeChar :: Char -> Text 438 | escapeChar c 439 | | c == '\\' = "\\\\" 440 | | c == '"' = "\\\"" 441 | | C.isPrint c = T.singleton c 442 | | Just e <- Map.lookup c emap = e 443 | | x <= 0xff = T.pack (printf "\\x%02x" x) 444 | | x <= 0xffff = T.pack (printf "\\u%04x" x) 445 | | otherwise = T.pack (printf "\\U%08x" x) 446 | where 447 | x = ord c 448 | 449 | emap = Map.fromList [ (v,T.pack ['\\',k]) | (k,v) <- escapes ] 450 | 451 | 452 | escapes :: [(Char,Char)] 453 | escapes = 454 | [ ('0', '\0') 455 | , ('a', '\x7') 456 | , ('b', '\x8') 457 | , ('\x9', '\x9') 458 | , ('t', '\x9') 459 | , ('n', '\xa') 460 | , ('v', '\xb') 461 | , ('f', '\xc') 462 | , ('r', '\xd') 463 | , ('e', '\x1b') 464 | , (' ', ' ') 465 | , ('"', '"') 466 | , ('/', '/') 467 | , ('\\', '\\') 468 | , ('N', '\x85') 469 | , ('_', '\xa0') 470 | , ('L', '\x2028') 471 | , ('P', '\x2029') 472 | ] 473 | 474 | 475 | -- flow style line folding 476 | -- FIXME: check single-quoted strings with leading '\n' or trailing '\n's 477 | insFoldNls :: [Text] -> [Text] 478 | insFoldNls [] = [] 479 | insFoldNls z0@(z:zs) 480 | | all T.null z0 = "" : z0 -- HACK 481 | | otherwise = z : go zs 482 | where 483 | go [] = [] 484 | go (l:ls) 485 | | T.null l = l : go' ls 486 | | otherwise = "" : l : go ls 487 | 488 | go' [] = [""] 489 | go' (l:ls) 490 | | T.null l = l : go' ls 491 | | otherwise = "" : l : go ls 492 | 493 | {- block style line folding 494 | 495 | The combined effect of the block line folding rules is that each 496 | “paragraph” is interpreted as a line, empty lines are interpreted as a 497 | line feed, and the formatting of more-indented lines is preserved. 498 | 499 | -} 500 | insFoldNls' :: [Text] -> [Text] 501 | insFoldNls' = go' 502 | where 503 | go [] = [] 504 | go (l:ls) 505 | | T.null l = l : go ls 506 | | isWhite (T.head l) = l : go' ls 507 | | otherwise = "" : l : go ls 508 | 509 | go' [] = [] 510 | go' (l:ls) 511 | | T.null l = l : go' ls 512 | | isWhite (T.head l) = l : go' ls 513 | | otherwise = l : go ls 514 | 515 | -- @s-white@ 516 | isWhite :: Char -> Bool 517 | isWhite ' ' = True 518 | isWhite '\t' = True 519 | isWhite _ = False 520 | -------------------------------------------------------------------------------- /src/Data/YAML.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE Safe #-} 6 | 7 | -- | 8 | -- Copyright: © Herbert Valerio Riedel 2015-2018 9 | -- SPDX-License-Identifier: GPL-2.0-or-later 10 | -- 11 | -- Document oriented [YAML](http://yaml.org/spec/1.2/spec.html) parsing API inspired by [aeson](http://hackage.haskell.org/package/aeson). 12 | 13 | module Data.YAML 14 | ( 15 | 16 | -- * Overview 17 | -- $overview 18 | 19 | -- * Quick Start Tutorial 20 | -- $start 21 | 22 | -- ** Decoding/Loading YAML document 23 | -- $loading 24 | 25 | -- ** Encoding/dumping 26 | -- $dumping 27 | 28 | -- * Typeclass-based resolving/decoding 29 | decode 30 | , decode1 31 | , decodeStrict 32 | , decode1Strict 33 | , FromYAML(..) 34 | , Parser 35 | , parseEither 36 | , failAtNode 37 | , typeMismatch 38 | 39 | -- ** Accessors for YAML t'Mapping's 40 | , Mapping 41 | , (.:), (.:?), (.:!), (.!=) 42 | 43 | -- * Typeclass-based dumping 44 | , encode 45 | , encode1 46 | , encodeStrict 47 | , encode1Strict 48 | , ToYAML(..) 49 | 50 | -- ** Accessors for encoding t'Mapping's 51 | , Pair 52 | , mapping 53 | , (.=) 54 | 55 | -- ** Prism-style parsers 56 | , withScalar 57 | , withSeq 58 | , withBool 59 | , withFloat 60 | , withInt 61 | , withNull 62 | , withStr 63 | , withMap 64 | 65 | -- * \"Concrete\" AST 66 | , decodeNode 67 | , decodeNode' 68 | , encodeNode 69 | , encodeNode' 70 | , Doc(Doc,docRoot) 71 | , Node(..) 72 | , Scalar(..) 73 | 74 | -- * Source locations 75 | , Pos(..) 76 | , prettyPosWithSource 77 | 78 | -- * YAML 1.2 Schema resolvers 79 | -- 80 | -- | See also "Data.YAML.Schema" 81 | , SchemaResolver 82 | , failsafeSchemaResolver 83 | , jsonSchemaResolver 84 | , coreSchemaResolver 85 | 86 | -- * YAML 1.2 Schema encoders 87 | -- 88 | -- | See also "Data.YAML.Schema" 89 | , SchemaEncoder 90 | , failsafeSchemaEncoder 91 | , jsonSchemaEncoder 92 | , coreSchemaEncoder 93 | 94 | -- * Generalised AST construction 95 | , decodeLoader 96 | , Loader(..) 97 | , LoaderT 98 | , NodeId 99 | 100 | ) where 101 | 102 | import qualified Control.Monad.Fail as Fail 103 | import qualified Data.ByteString as BS 104 | import qualified Data.ByteString.Lazy as BS.L 105 | import qualified Data.Map as Map 106 | import qualified Data.Text as T 107 | 108 | import Data.YAML.Dumper 109 | import Data.YAML.Event (isUntagged, tagToText) 110 | import Data.YAML.Internal 111 | import Data.YAML.Loader 112 | import Data.YAML.Pos 113 | import Data.YAML.Schema.Internal 114 | 115 | import Util 116 | 117 | -- $overview 118 | -- 119 | -- The diagram below depicts the standard layers of a [YAML 1.2](http://yaml.org/spec/1.2/spec.html) processor. This module covers the upper /Native/ and /Representation/ layers, whereas the "Data.YAML.Event" and "Data.YAML.Token" modules provide access to the lower /Serialization/ and /Presentation/ layers respectively. 120 | -- 121 | -- <> 122 | -- 123 | -- $start 124 | -- 125 | -- This section contains basic information on the different ways to work with YAML data using this library. 126 | -- 127 | -- $loading 128 | -- 129 | -- We address the process of loading data from a YAML document as decoding. 130 | -- 131 | -- Let's assume we want to decode (i.e. /load/) a simple YAML document 132 | -- 133 | -- > - name: Erik Weisz 134 | -- > age: 52 135 | -- > magic: True 136 | -- > - name: Mina Crandon 137 | -- > age: 53 138 | -- 139 | -- into a native Haskell data structure of type @[Person]@, i.e. a list of @Person@ records. 140 | -- 141 | -- The code below shows how to manually define a @Person@ record type together with a 'FromYAML' instance: 142 | -- 143 | -- > {-# LANGUAGE OverloadedStrings #-} 144 | -- > 145 | -- > import Data.YAML 146 | -- > 147 | -- > data Person = Person 148 | -- > { name :: Text 149 | -- > , age :: Int 150 | -- > , magic :: Bool 151 | -- > } deriving Show 152 | -- > 153 | -- > instance FromYAML Person where 154 | -- > parseYAML = withMap "Person" $ \m -> Person 155 | -- > <$> m .: "name" 156 | -- > <*> m .: "age" 157 | -- > <*> m .:? "magic" .!= False 158 | -- 159 | -- And now we can 'decode' the YAML document like so: 160 | -- 161 | -- >>> decode "- name: Erik Weisz\n age: 52\n magic: True\n- name: Mina Crandon\n age: 53" :: Either (Pos,String) [[Person]] 162 | -- Right [[Person {name = "Erik Weisz", age = 52, magic = True},Person {name = "Mina Crandon", age = 53, magic = False}]] 163 | -- 164 | -- There are predefined 'FromYAML' instance for many types. 165 | -- 166 | -- The example below shows decoding multiple YAML documents into a list of 'Int' lists: 167 | -- 168 | -- >>> decode "---\n- 1\n- 2\n- 3\n---\n- 4\n- 5\n- 6" :: Either (Pos,String) [[Int]] 169 | -- Right [[1,2,3],[4,5,6]] 170 | -- 171 | -- If you are expecting exactly one YAML document then you can use convenience function 'decode1' 172 | -- 173 | -- >>> decode1 "- 1\n- 2\n- 3\n" :: Either (Pos,String) [Int] 174 | -- Right [1,2,3] 175 | -- 176 | -- == Working with AST 177 | -- 178 | -- Sometimes we want to work with YAML data directly, without first converting it to a custom data type. 179 | -- 180 | -- We can easily do that by using the 'Node' type, which is an instance of 'FromYAML', is used to represent an arbitrary YAML AST (abstract syntax tree). For example, 181 | -- 182 | -- >>> decode1 "Name: Vijay" :: Either (Pos,String) (Node Pos) 183 | -- Right (Mapping (Pos {posByteOffset = 0, posCharOffset = 0, posLine = 1, posColumn = 0}) Just "tag:yaml.org,2002:map" (fromList [(Scalar (Pos {posByteOffset = 0, posCharOffset = 0, posLine = 1, posColumn = 0}) (SStr "Name"),Scalar (Pos {posByteOffset = 6, posCharOffset = 6, posLine = 1, posColumn = 6}) (SStr "Vijay"))])) 184 | -- 185 | -- The type parameter 'Pos' is used to indicate the position of each YAML 'Node' in the document. 186 | -- So using the 'Node' type we can easily decode any YAML document. 187 | -- 188 | -- == Pretty-printing source locations 189 | -- 190 | -- Syntax errors or even conversion errors are reported with a source location, e.g. 191 | -- 192 | -- >>> decode "- name: Erik Weisz\n age: 52\n magic: True\n- name: Mina Crandon\n age: young" :: Either (Pos,String) [[Person]] 193 | -- Left (Pos {posByteOffset = 71, posCharOffset = 71, posLine = 5, posColumn = 7},"expected !!int instead of !!str") 194 | -- 195 | -- While accurate this isn't a very convenient error representation. Instead we can use the 'prettyPosWithSource' helper function to create more convenient error report like so 196 | -- 197 | -- @ 198 | -- readPersons :: FilePath -> IO [Person] 199 | -- readPersons fname = do 200 | -- raw <- BS.L.readFile fname 201 | -- case 'decode1' raw of 202 | -- Left (loc,emsg) -> do 203 | -- hPutStrLn stderr (fname ++ ":" ++ 'prettyPosWithSource' loc raw " error" ++ emsg) 204 | -- pure [] 205 | -- Right persons -> pure persons 206 | -- @ 207 | -- 208 | -- which will then print errors in a common form such as 209 | -- 210 | -- > people.yaml:5:7: error 211 | -- > | 212 | -- > 5 | age: young 213 | -- > | ^ 214 | -- > expected !!int instead of !!str 215 | -- 216 | 217 | 218 | -- | Retrieve value in t'Mapping' indexed by a @!!str@ 'Text' key. 219 | -- 220 | -- This parser fails if the key doesn't exist. 221 | (.:) :: FromYAML a => Mapping Pos -> Text -> Parser a 222 | m .: k = maybe (fail $ "key " ++ show k ++ " not found") parseYAML (Map.lookup (Scalar fakePos (SStr k)) m) 223 | 224 | -- | Retrieve optional value in t'Mapping' indexed by a @!!str@ 'Text' key. 225 | -- 226 | -- 'Nothing' is returned if the key is missing or points to a @tag:yaml.org,2002:null@ node. 227 | -- This combinator only fails if the key exists but cannot be converted to the required type. 228 | -- 229 | -- See also '.:!'. 230 | (.:?) :: FromYAML a => Mapping Pos -> Text -> Parser (Maybe a) 231 | m .:? k = maybe (pure Nothing) parseYAML (Map.lookup (Scalar fakePos (SStr k)) m) 232 | 233 | -- | Retrieve optional value in t'Mapping' indexed by a @!!str@ 'Text' key. 234 | -- 235 | -- 'Nothing' is returned if the key is missing. 236 | -- This combinator only fails if the key exists but cannot be converted to the required type. 237 | -- 238 | -- __NOTE__: This is a variant of '.:?' which doesn't map a @tag:yaml.org,2002:null@ node to 'Nothing'. 239 | (.:!) :: FromYAML a => Mapping Pos -> Text -> Parser (Maybe a) 240 | m .:! k = maybe (pure Nothing) (fmap Just . parseYAML) (Map.lookup (Scalar fakePos (SStr k)) m) 241 | 242 | -- | Defaulting helper to be used with '.:?' or '.:!'. 243 | (.!=) :: Parser (Maybe a) -> a -> Parser a 244 | mv .!= def = fmap (maybe def id) mv 245 | 246 | fakePos :: Pos 247 | fakePos = Pos { posByteOffset = -1 , posCharOffset = -1 , posLine = 1 , posColumn = 0 } 248 | 249 | -- | Parse and decode YAML document(s) into 'Node' graphs 250 | -- 251 | -- This is a convenience wrapper over `decodeNode'`, i.e. 252 | -- 253 | -- @ 254 | -- decodeNode = decodeNode' 'coreSchemaResolver' False False 255 | -- @ 256 | -- 257 | -- In other words, 258 | -- 259 | -- * Use the YAML 1.2 Core schema for resolving 260 | -- * Don't create 'Anchor' nodes 261 | -- * Disallow cyclic anchor references 262 | -- 263 | -- @since 0.2.0 264 | -- 265 | decodeNode :: BS.L.ByteString -> Either (Pos, String) [Doc (Node Pos)] 266 | decodeNode = decodeNode' coreSchemaResolver False False 267 | 268 | 269 | -- | Customizable variant of 'decodeNode' 270 | -- 271 | -- @since 0.2.0 272 | -- 273 | decodeNode' :: SchemaResolver -- ^ YAML Schema resolver to use 274 | -> Bool -- ^ Whether to emit anchor nodes 275 | -> Bool -- ^ Whether to allow cyclic references 276 | -> BS.L.ByteString -- ^ YAML document to parse 277 | -> Either (Pos, String) [Doc (Node Pos)] 278 | decodeNode' SchemaResolver{..} anchorNodes allowCycles bs0 279 | = map Doc <$> runIdentity (decodeLoader failsafeLoader bs0) 280 | where 281 | failsafeLoader = Loader { yScalar = \t s v pos-> pure $ case schemaResolverScalar t s v of 282 | Left e -> Left (pos,e) 283 | Right v' -> Right (Scalar pos v') 284 | , ySequence = \t vs pos -> pure $ case schemaResolverSequence t of 285 | Left e -> Left (pos,e) 286 | Right t' -> Right (Sequence pos t' vs) 287 | , yMapping = \t kvs pos-> pure $ case schemaResolverMapping t of 288 | Left e -> Left (pos,e) 289 | Right t' -> Mapping pos t' <$> mkMap kvs 290 | , yAlias = if allowCycles 291 | then \_ _ n _-> pure $ Right n 292 | else \_ c n pos -> pure $ if c then Left (pos,"cycle detected") else Right n 293 | , yAnchor = if anchorNodes 294 | then \j n pos -> pure $ Right (Anchor pos j n) 295 | else \_ n _ -> pure $ Right n 296 | } 297 | 298 | mkMap :: [(Node Pos, Node Pos)] -> Either (Pos, String) (Map (Node Pos) (Node Pos)) 299 | mkMap kvs 300 | | schemaResolverMappingDuplicates = Right $! Map.fromList kvs 301 | | otherwise = case mapFromListNoDupes kvs of 302 | Left (k,_) -> Left (nodeLoc k,"Duplicate key in mapping: " ++ show k) 303 | Right m -> Right m 304 | 305 | ---------------------------------------------------------------------------- 306 | 307 | -- | YAML Parser 'Monad' used by 'FromYAML' 308 | -- 309 | -- See also 'parseEither' or 'decode' 310 | newtype Parser a = P { unP :: Either (Pos, String) a } 311 | 312 | instance Functor Parser where 313 | fmap f (P x) = P (fmap f x) 314 | 315 | x <$ P (Right _) = P (Right x) 316 | _ <$ P (Left e) = P (Left e) 317 | 318 | instance Applicative Parser where 319 | pure = P . Right 320 | 321 | P (Left e) <*> _ = P (Left e) 322 | P (Right f) <*> P r = P (fmap f r) 323 | 324 | P (Left e) *> _ = P (Left e) 325 | P (Right _) *> p = p 326 | 327 | instance Monad Parser where 328 | return = pure 329 | P m >>= k = P (m >>= unP . k) 330 | (>>) = (*>) 331 | #if !(MIN_VERSION_base(4,13,0)) 332 | fail = Fail.fail 333 | #endif 334 | 335 | 336 | -- | @since 0.1.1.0 337 | -- 338 | -- __NOTE__: 'fail' doesn't convey proper position information unless used within the @with*@-style helpers; consequently it's recommended to use 'failAtNode' when /not/ covered by the location scope of a @with*@-style combinator. 339 | instance Fail.MonadFail Parser where 340 | fail s = P (Left (fakePos, s)) 341 | 342 | -- | Trigger parsing failure located at a specific 'Node' 343 | -- 344 | -- @since 0.2.0.0 345 | failAtNode :: Node Pos -> String -> Parser a 346 | failAtNode n s = P (Left (nodeLoc n, s)) 347 | 348 | -- | @since 0.1.1.0 349 | instance Alternative Parser where 350 | empty = fail "empty" 351 | 352 | P (Left _) <|> y = y 353 | x <|> _ = x 354 | 355 | -- | @since 0.1.1.0 356 | instance MonadPlus Parser where 357 | mzero = empty 358 | mplus = (<|>) 359 | 360 | -- | Run 'Parser' 361 | -- 362 | -- A common use-case is 'parseEither' 'parseYAML'. 363 | parseEither :: Parser a -> Either (Pos, String) a 364 | parseEither = unP 365 | 366 | -- | Informative failure helper 367 | -- 368 | -- This is typically used in fall-through cases of 'parseYAML' like so 369 | -- 370 | -- > instance FromYAML ... where 371 | -- > parseYAML ... = ... 372 | -- > parseYAML node = typeMismatch "SomeThing" node 373 | -- 374 | -- @since 0.1.1.0 375 | typeMismatch :: String -- ^ descriptive name of expected data 376 | -> Node Pos -- ^ actual node 377 | -> Parser a 378 | typeMismatch expected node = failAtNode node ("expected " ++ expected ++ " instead of " ++ got) 379 | where 380 | got = case node of 381 | Scalar _ (SBool _) -> "!!bool" 382 | Scalar _ (SInt _) -> "!!int" 383 | Scalar _ SNull -> "!!null" 384 | Scalar _ (SStr _) -> "!!str" 385 | Scalar _ (SFloat _) -> "!!float" 386 | Scalar _ (SUnknown t v) 387 | | isUntagged t -> tagged t ++ show v 388 | | otherwise -> "(unsupported) " ++ tagged t ++ "scalar" 389 | Anchor _ _ _ -> "anchor" 390 | Mapping _ t _ -> tagged t ++ " mapping" 391 | Sequence _ t _ -> tagged t ++ " sequence" 392 | 393 | tagged t0 = case tagToText t0 of 394 | Nothing -> "non-specifically ? tagged (i.e. unresolved) " 395 | Just t -> T.unpack t ++ " tagged" 396 | 397 | -- | A type into which YAML nodes can be converted/deserialized 398 | class FromYAML a where 399 | parseYAML :: Node Pos -> Parser a 400 | 401 | -- This helper fixes up 'fakePos' locations to a better guess; this is 402 | -- mostly used by the with*-style combinators 403 | {-# INLINE fixupFailPos #-} 404 | fixupFailPos :: Pos -> Parser a -> Parser a 405 | fixupFailPos pos (P (Left (pos0,emsg))) 406 | | pos0 == fakePos = P (Left (pos,emsg)) 407 | fixupFailPos _ p = p 408 | 409 | -- | Operate on @tag:yaml.org,2002:null@ node (or fail) 410 | withNull :: String -> Parser a -> Node Pos -> Parser a 411 | withNull _ f (Scalar pos SNull) = fixupFailPos pos f 412 | withNull expected _ v = typeMismatch expected v 413 | 414 | -- | Operate on t'Scalar' node (or fail) 415 | -- 416 | -- @since 0.2.1 417 | withScalar :: String -> (Scalar -> Parser a) -> Node Pos -> Parser a 418 | withScalar _ f (Scalar pos sca) = fixupFailPos pos (f sca) 419 | withScalar expected _ v = typeMismatch expected v 420 | 421 | -- | Trivial instance 422 | instance (loc ~ Pos) => FromYAML (Node loc) where 423 | parseYAML = pure 424 | 425 | -- | @since 0.2.1 426 | instance FromYAML Scalar where 427 | parseYAML = withScalar "scalar" pure 428 | 429 | instance FromYAML Bool where 430 | parseYAML = withBool "!!bool" pure 431 | 432 | -- | Operate on @tag:yaml.org,2002:bool@ node (or fail) 433 | withBool :: String -> (Bool -> Parser a) -> Node Pos -> Parser a 434 | withBool _ f (Scalar pos (SBool b)) = fixupFailPos pos (f b) 435 | withBool expected _ v = typeMismatch expected v 436 | 437 | instance FromYAML Text where 438 | parseYAML = withStr "!!str" pure 439 | 440 | -- | Operate on @tag:yaml.org,2002:str@ node (or fail) 441 | withStr :: String -> (Text -> Parser a) -> Node Pos -> Parser a 442 | withStr _ f (Scalar pos (SStr b)) = fixupFailPos pos (f b) 443 | withStr expected _ v = typeMismatch expected v 444 | 445 | instance FromYAML Integer where 446 | parseYAML = withInt "!!int" pure 447 | 448 | -- | Operate on @tag:yaml.org,2002:int@ node (or fail) 449 | withInt :: String -> (Integer -> Parser a) -> Node Pos -> Parser a 450 | withInt _ f (Scalar pos (SInt b)) = fixupFailPos pos (f b) 451 | withInt expected _ v = typeMismatch expected v 452 | 453 | -- | @since 0.1.1.0 454 | instance FromYAML Natural where 455 | parseYAML = withInt "!!int" $ \b -> if b < 0 then fail ("!!int " ++ show b ++ " out of range for 'Natural'") 456 | else pure (fromInteger b) 457 | 458 | -- helper for fixed-width integers 459 | {-# INLINE parseInt #-} 460 | parseInt :: (Integral a, Bounded a) => [Char] -> Node Pos -> Parser a 461 | parseInt name = withInt "!!int" $ \b -> maybe (fail $ "!!int " ++ show b ++ " out of range for '" ++ name ++ "'") pure $ 462 | fromIntegerMaybe b 463 | 464 | instance FromYAML Int where parseYAML = parseInt "Int" 465 | instance FromYAML Int8 where parseYAML = parseInt "Int8" 466 | instance FromYAML Int16 where parseYAML = parseInt "Int16" 467 | instance FromYAML Int32 where parseYAML = parseInt "Int32" 468 | instance FromYAML Int64 where parseYAML = parseInt "Int64" 469 | instance FromYAML Word where parseYAML = parseInt "Word" 470 | instance FromYAML Word8 where parseYAML = parseInt "Word8" 471 | instance FromYAML Word16 where parseYAML = parseInt "Word16" 472 | instance FromYAML Word32 where parseYAML = parseInt "Word32" 473 | instance FromYAML Word64 where parseYAML = parseInt "Word64" 474 | 475 | 476 | instance FromYAML Double where 477 | parseYAML = withFloat "!!float" pure 478 | 479 | -- | Operate on @tag:yaml.org,2002:float@ node (or fail) 480 | withFloat :: String -> (Double -> Parser a) -> Node Pos -> Parser a 481 | withFloat _ f (Scalar pos (SFloat b)) = fixupFailPos pos (f b) 482 | withFloat expected _ v = typeMismatch expected v 483 | 484 | 485 | instance (Ord k, FromYAML k, FromYAML v) => FromYAML (Map k v) where 486 | parseYAML = withMap "!!map" $ \xs -> Map.fromList <$> mapM (\(a,b) -> (,) <$> parseYAML a <*> parseYAML b) (Map.toList xs) 487 | 488 | -- | Operate on @tag:yaml.org,2002:map@ node (or fail) 489 | withMap :: String -> (Mapping Pos -> Parser a) -> Node Pos -> Parser a 490 | withMap _ f (Mapping pos tag xs) 491 | | tag == tagMap = fixupFailPos pos (f xs) 492 | withMap expected _ v = typeMismatch expected v 493 | 494 | instance FromYAML v => FromYAML [v] where 495 | parseYAML = withSeq "!!seq" (mapM parseYAML) 496 | 497 | -- | Operate on @tag:yaml.org,2002:seq@ node (or fail) 498 | withSeq :: String -> ([Node Pos] -> Parser a) -> Node Pos-> Parser a 499 | withSeq _ f (Sequence pos tag xs) 500 | | tag == tagSeq = fixupFailPos pos (f xs) 501 | withSeq expected _ v = typeMismatch expected v 502 | 503 | instance FromYAML a => FromYAML (Maybe a) where 504 | parseYAML (Scalar _ SNull) = pure Nothing 505 | parseYAML j = Just <$> parseYAML j 506 | 507 | ---------------------------------------------------------------------------- 508 | 509 | instance (FromYAML a, FromYAML b) => FromYAML (a,b) where 510 | parseYAML = withSeq "!!seq" $ \xs -> 511 | case xs of 512 | [a,b] -> (,) <$> parseYAML a 513 | <*> parseYAML b 514 | _ -> fail ("expected 2-sequence but got " ++ show (length xs) ++ "-sequence instead") 515 | 516 | instance (FromYAML a, FromYAML b, FromYAML c) => FromYAML (a,b,c) where 517 | parseYAML = withSeq "!!seq" $ \xs -> 518 | case xs of 519 | [a,b,c] -> (,,) <$> parseYAML a 520 | <*> parseYAML b 521 | <*> parseYAML c 522 | _ -> fail ("expected 3-sequence but got " ++ show (length xs) ++ "-sequence instead") 523 | 524 | 525 | instance (FromYAML a, FromYAML b, FromYAML c, FromYAML d) => FromYAML (a,b,c,d) where 526 | parseYAML = withSeq "!!seq" $ \xs -> 527 | case xs of 528 | [a,b,c,d] -> (,,,) <$> parseYAML a 529 | <*> parseYAML b 530 | <*> parseYAML c 531 | <*> parseYAML d 532 | _ -> fail ("expected 4-sequence but got " ++ show (length xs) ++ "-sequence instead") 533 | 534 | 535 | instance (FromYAML a, FromYAML b, FromYAML c, FromYAML d, FromYAML e) => FromYAML (a,b,c,d,e) where 536 | parseYAML = withSeq "!!seq" $ \xs -> 537 | case xs of 538 | [a,b,c,d,e] -> (,,,,) <$> parseYAML a 539 | <*> parseYAML b 540 | <*> parseYAML c 541 | <*> parseYAML d 542 | <*> parseYAML e 543 | _ -> fail ("expected 5-sequence but got " ++ show (length xs) ++ "-sequence instead") 544 | 545 | 546 | instance (FromYAML a, FromYAML b, FromYAML c, FromYAML d, FromYAML e, FromYAML f) => FromYAML (a,b,c,d,e,f) where 547 | parseYAML = withSeq "!!seq" $ \xs -> 548 | case xs of 549 | [a,b,c,d,e,f] -> (,,,,,) <$> parseYAML a 550 | <*> parseYAML b 551 | <*> parseYAML c 552 | <*> parseYAML d 553 | <*> parseYAML e 554 | <*> parseYAML f 555 | _ -> fail ("expected 6-sequence but got " ++ show (length xs) ++ "-sequence instead") 556 | 557 | 558 | instance (FromYAML a, FromYAML b, FromYAML c, FromYAML d, FromYAML e, FromYAML f, FromYAML g) => FromYAML (a,b,c,d,e,f,g) where 559 | parseYAML = withSeq "!!seq" $ \xs -> 560 | case xs of 561 | [a,b,c,d,e,f,g] -> (,,,,,,) <$> parseYAML a 562 | <*> parseYAML b 563 | <*> parseYAML c 564 | <*> parseYAML d 565 | <*> parseYAML e 566 | <*> parseYAML f 567 | <*> parseYAML g 568 | _ -> fail ("expected 7-sequence but got " ++ show (length xs) ++ "-sequence instead") 569 | 570 | 571 | -- | Decode YAML document(s) using the YAML 1.2 Core schema 572 | -- 573 | -- Each document contained in the YAML stream produce one element of 574 | -- the response list. Here's an example of decoding two concatenated 575 | -- YAML documents: 576 | -- 577 | -- >>> decode "Foo\n---\nBar" :: Either (Pos,String) [Text] 578 | -- Right ["Foo","Bar"] 579 | -- 580 | -- Note that an empty stream doesn't contain any (non-comment) 581 | -- document nodes, and therefore results in an empty result list: 582 | -- 583 | -- >>> decode "# just a comment" :: Either (Pos,String) [Text] 584 | -- Right [] 585 | -- 586 | -- 'decode' uses the same settings as 'decodeNode' for tag-resolving. If 587 | -- you need a different custom parsing configuration, you need to 588 | -- combine 'parseEither' and `decodeNode'` yourself. 589 | -- 590 | -- The 'decode' as well as the 'decodeNode' functions supports 591 | -- decoding from YAML streams using the UTF-8, UTF-16 (LE or BE), or 592 | -- UTF-32 (LE or BE) encoding (which is auto-detected). 593 | -- 594 | -- @since 0.2.0 595 | -- 596 | decode :: FromYAML v => BS.L.ByteString -> Either (Pos, String) [v] 597 | decode bs0 = decodeNode bs0 >>= mapM (parseEither . parseYAML . (\(Doc x) -> x)) 598 | 599 | -- | Convenience wrapper over 'decode' expecting exactly one YAML document 600 | -- 601 | -- >>> decode1 "---\nBar\n..." :: Either (Pos,String) Text 602 | -- Right "Bar" 603 | -- 604 | -- >>> decode1 "Foo\n---\nBar" :: Either (Pos,String) Text 605 | -- Left (Pos {posByteOffset = 8, posCharOffset = 8, posLine = 3, posColumn = 0},"unexpected multiple YAML documents") 606 | -- 607 | -- >>> decode1 "# Just a comment" :: Either (Pos,String) Text 608 | -- Left (Pos {posByteOffset = 0, posCharOffset = 0, posLine = 1, posColumn = 0},"empty YAML stream") 609 | -- 610 | -- @since 0.2.0 611 | -- 612 | decode1 :: FromYAML v => BS.L.ByteString -> Either (Pos, String) v 613 | decode1 bs0 = do 614 | docs <- decodeNode bs0 615 | case docs of 616 | [] -> Left (Pos { posByteOffset = 0, posCharOffset = 0, posLine = 1, posColumn = 0 }, "empty YAML stream") 617 | [Doc v] -> parseEither $ parseYAML $ v 618 | (_:Doc n:_) -> Left (nodeLoc n, "unexpected multiple YAML documents") 619 | 620 | -- | Like 'decode' but takes a strict 'BS.ByteString' 621 | -- 622 | -- @since 0.2.0 623 | -- 624 | decodeStrict :: FromYAML v => BS.ByteString -> Either (Pos, String) [v] 625 | decodeStrict = decode . BS.L.fromChunks . (:[]) 626 | 627 | -- | Like 'decode1' but takes a strict 'BS.ByteString' 628 | -- 629 | -- @since 0.2.0 630 | -- 631 | decode1Strict :: FromYAML v => BS.ByteString -> Either (Pos, String) v 632 | decode1Strict = decode1 . BS.L.fromChunks . (:[]) 633 | 634 | -- $dumping 635 | -- 636 | -- We address the process of dumping information from a Haskell-data type(s) to a YAML document(s) as encoding. 637 | -- 638 | -- Suppose we want to 'encode' a Haskell-data type Person 639 | -- 640 | -- @ 641 | -- data Person = Person 642 | -- { name :: Text 643 | -- , age :: Int 644 | -- } deriving Show 645 | -- @ 646 | -- 647 | -- To 'encode' data, we need to define a 'ToYAML' instance. 648 | -- 649 | -- @ 650 | -- 651 | -- instance 'ToYAML' Person where 652 | -- \-- this generates a 'Node' 653 | -- 'toYAML' (Person n a) = 'mapping' [ "name" .= n, "age" .= a] 654 | -- 655 | -- @ 656 | -- 657 | -- We can now 'encode' a node like so: 658 | -- 659 | -- >>> encode [Person {name = "Vijay", age = 19}] 660 | -- "age: 19\nname: Vijay\n" 661 | -- 662 | -- There are predefined 'ToYAML' instances for many types. Here's an example encoding a complex Haskell Node' 663 | -- 664 | -- >>> encode1 $ toYAML ([1,2,3], Map.fromList [(1, 2)]) 665 | -- "- - 1\n - 2\n - 3\n- 1: 2\n" 666 | -- 667 | 668 | 669 | -- | A type from which YAML nodes can be constructed 670 | -- 671 | -- @since 0.2.0.0 672 | class ToYAML a where 673 | -- | Convert a Haskell Data-type to a YAML Node data type. 674 | toYAML :: a -> Node () 675 | 676 | instance Loc loc => ToYAML (Node loc) where 677 | toYAML = toUnit 678 | 679 | instance ToYAML Bool where 680 | toYAML = Scalar () . SBool 681 | 682 | instance ToYAML Double where 683 | toYAML = Scalar () . SFloat 684 | 685 | instance ToYAML Int where toYAML = Scalar () . SInt . toInteger 686 | instance ToYAML Int8 where toYAML = Scalar () . SInt . toInteger 687 | instance ToYAML Int16 where toYAML = Scalar () . SInt . toInteger 688 | instance ToYAML Int32 where toYAML = Scalar () . SInt . toInteger 689 | instance ToYAML Int64 where toYAML = Scalar () . SInt . toInteger 690 | instance ToYAML Word where toYAML = Scalar () . SInt . toInteger 691 | instance ToYAML Word8 where toYAML = Scalar () . SInt . toInteger 692 | instance ToYAML Word16 where toYAML = Scalar () . SInt . toInteger 693 | instance ToYAML Word32 where toYAML = Scalar () . SInt . toInteger 694 | instance ToYAML Word64 where toYAML = Scalar () . SInt . toInteger 695 | instance ToYAML Natural where toYAML = Scalar () . SInt . toInteger 696 | instance ToYAML Integer where toYAML = Scalar () . SInt 697 | 698 | 699 | instance ToYAML Text where 700 | toYAML = Scalar () . SStr 701 | 702 | -- | @since 0.2.1 703 | instance ToYAML Scalar where 704 | toYAML = Scalar () 705 | 706 | instance ToYAML a => ToYAML (Maybe a) where 707 | toYAML Nothing = Scalar () SNull 708 | toYAML (Just a) = toYAML a 709 | 710 | -- instance (ToYAML a, ToYAML b) => ToYAML (Either a b) where 711 | -- toYAML (Left a) = toYAML a 712 | -- toYAML (Right b) = toYAML b 713 | 714 | instance ToYAML a => ToYAML [a] where 715 | toYAML = Sequence () tagSeq . map toYAML 716 | 717 | instance (Ord k, ToYAML k, ToYAML v) => ToYAML (Map k v) where 718 | toYAML kv = Mapping () tagMap (Map.fromList $ map (\(k,v) -> (toYAML k , toYAML v)) (Map.toList kv)) 719 | 720 | instance (ToYAML a, ToYAML b) => ToYAML (a, b) where 721 | toYAML (a,b) = toYAML [toYAML a, toYAML b] 722 | 723 | instance (ToYAML a, ToYAML b, ToYAML c) => ToYAML (a, b, c) where 724 | toYAML (a,b,c) = toYAML [toYAML a, toYAML b, toYAML c] 725 | 726 | instance (ToYAML a, ToYAML b, ToYAML c, ToYAML d) => ToYAML (a, b, c, d) where 727 | toYAML (a,b,c,d) = toYAML [toYAML a, toYAML b, toYAML c, toYAML d] 728 | 729 | instance (ToYAML a, ToYAML b, ToYAML c, ToYAML d, ToYAML e) => ToYAML (a, b, c, d, e) where 730 | toYAML (a,b,c,d,e) = toYAML [toYAML a, toYAML b, toYAML c, toYAML d, toYAML e] 731 | 732 | instance (ToYAML a, ToYAML b, ToYAML c, ToYAML d, ToYAML e, ToYAML f) => ToYAML (a, b, c, d, e, f) where 733 | toYAML (a,b,c,d,e,f) = toYAML [toYAML a, toYAML b, toYAML c, toYAML d, toYAML e, toYAML f] 734 | 735 | instance (ToYAML a, ToYAML b, ToYAML c, ToYAML d, ToYAML e, ToYAML f, ToYAML g) => ToYAML (a, b, c, d, e, f, g) where 736 | toYAML (a,b,c,d,e,f,g) = toYAML [toYAML a, toYAML b, toYAML c, toYAML d, toYAML e, toYAML f, toYAML g] 737 | 738 | 739 | -- | Serialize YAML Node(s) using the YAML 1.2 Core schema to a lazy 'Data.YAML.Token.UTF8' encoded 'BS.L.ByteString'. 740 | -- 741 | -- Each YAML Node produces exactly one YAML Document. 742 | -- 743 | -- Here is an example of encoding a list of strings to produce a list of YAML Documents 744 | -- 745 | -- >>> encode (["Document 1", "Document 2"] :: [Text]) 746 | -- "Document 1\n...\nDocument 2\n" 747 | -- 748 | -- If we treat the above list of strings as a single sequence then we will produce a single YAML Document having a single sequence. 749 | -- 750 | -- >>> encode ([["Document 1", "Document 2"]] :: [[Text]]) 751 | -- "- Document 1\n- Document 2\n" 752 | -- 753 | -- Alternatively, if you only need a single YAML document in a YAML stream you might want to use the convenience function 'encode1'; or, if you need more control over the encoding, see 'encodeNode''. 754 | -- 755 | -- @since 0.2.0 756 | encode :: ToYAML v => [v] -> BS.L.ByteString 757 | encode vList = encodeNode $ map (Doc . toYAML) vList 758 | 759 | -- | Convenience wrapper over 'encode' taking exactly one YAML Node. 760 | -- Hence it will always output exactly one YAML Document 761 | -- 762 | -- Here is example of encoding a list of strings to produce exactly one of YAML Documents 763 | -- 764 | -- >>> encode1 (["Document 1", "Document 2"] :: [Text]) 765 | -- "- Document 1\n- Document 2\n" 766 | -- 767 | -- @since 0.2.0 768 | encode1 :: ToYAML v => v -> BS.L.ByteString 769 | encode1 a = encode [a] 770 | 771 | -- | Like 'encode' but outputs 'BS.ByteString' 772 | -- 773 | -- @since 0.2.0 774 | encodeStrict :: ToYAML v => [v] -> BS.ByteString 775 | encodeStrict = bsToStrict . encode 776 | 777 | -- | Like 'encode1' but outputs a strict 'BS.ByteString' 778 | -- 779 | -- @since 0.2.0 780 | encode1Strict :: ToYAML v => v -> BS.ByteString 781 | encode1Strict = bsToStrict . encode1 782 | 783 | -- Internal helper 784 | class Loc loc where 785 | toUnit :: Functor f => f loc -> f () 786 | toUnit = (() <$) 787 | 788 | instance Loc Pos 789 | 790 | instance Loc () where toUnit = id 791 | 792 | -- | Represents a key-value pair in YAML t'Mapping's 793 | -- 794 | -- See also '.=' and 'mapping' 795 | -- 796 | -- @since 0.2.1 797 | type Pair = (Node (), Node ()) 798 | 799 | -- | @since 0.2.0 800 | (.=) :: ToYAML a => Text -> a -> Pair 801 | name .= node = (toYAML name, toYAML node) 802 | 803 | -- | @since 0.2.0 804 | mapping :: [Pair] -> Node () 805 | mapping = Mapping () tagMap . Map.fromList 806 | -------------------------------------------------------------------------------- /src-test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- | 6 | -- Copyright: © Herbert Valerio Riedel 2018 7 | -- SPDX-License-Identifier: GPL-2.0-or-later 8 | -- 9 | module Main where 10 | 11 | import Control.Monad 12 | import Control.Monad.Identity 13 | import qualified Data.ByteString.Char8 as BS 14 | import qualified Data.ByteString.Lazy.Char8 as BS.L 15 | import Data.Int (Int64) 16 | import Data.List (groupBy) 17 | import Data.Maybe 18 | import System.Directory 19 | import System.Environment 20 | import System.Exit 21 | import System.FilePath 22 | import System.IO 23 | import Text.Printf (printf) 24 | import Text.Read 25 | 26 | import qualified Data.Aeson.Micro as J 27 | import Data.Map (Map) 28 | import qualified Data.Map as Map 29 | import Data.Text (Text) 30 | import qualified Data.Text as T 31 | import qualified Data.Text.Encoding as T 32 | import qualified Data.Text.IO as T 33 | 34 | import Data.YAML as Y 35 | import Data.YAML.Event as YE 36 | import Data.YAML.Schema as Y 37 | import qualified Data.YAML.Token as YT 38 | 39 | import qualified TML 40 | 41 | main :: IO () 42 | main = do 43 | args <- getArgs 44 | 45 | case args of 46 | ("yaml2event":args') 47 | | null args' -> cmdYaml2Event 48 | | otherwise -> do 49 | hPutStrLn stderr "unexpected arguments passed to yaml2event sub-command" 50 | exitFailure 51 | 52 | ("yaml2event-pos":args') 53 | | null args' -> cmdYaml2EventPos 54 | | otherwise -> do 55 | hPutStrLn stderr "unexpected arguments passed to yaml2event sub-command" 56 | exitFailure 57 | 58 | ("yaml2yaml-validate":args') 59 | | null args' -> cmdYaml2YamlVal 60 | | otherwise -> do 61 | hPutStrLn stderr "unexpected arguments passed to check sub-command" 62 | exitFailure 63 | 64 | ("yaml2event0":args') 65 | | null args' -> cmdYaml2Event0 66 | | otherwise -> do 67 | hPutStrLn stderr "unexpected arguments passed to yaml2event0 sub-command" 68 | exitFailure 69 | 70 | ("yaml2token":args') 71 | | null args' -> cmdYaml2Token 72 | | otherwise -> do 73 | hPutStrLn stderr "unexpected arguments passed to yaml2token sub-command" 74 | exitFailure 75 | 76 | ("yaml2token0":args') 77 | | null args' -> cmdYaml2Token0 78 | | otherwise -> do 79 | hPutStrLn stderr "unexpected arguments passed to yaml2token0 sub-command" 80 | exitFailure 81 | 82 | ("yaml2json":args') 83 | | null args' -> cmdYaml2Json 84 | | otherwise -> do 85 | hPutStrLn stderr "unexpected arguments passed to yaml2json sub-command" 86 | exitFailure 87 | 88 | ("yaml2yaml":args') 89 | | null args' -> cmdYaml2Yaml 90 | | otherwise -> do 91 | hPutStrLn stderr "unexpected arguments passed to yaml2yaml sub-command" 92 | exitFailure 93 | 94 | ("yaml2yaml-":args') 95 | | null args' -> cmdYaml2Yaml' 96 | | otherwise -> do 97 | hPutStrLn stderr "unexpected arguments passed to yaml2yaml- sub-command" 98 | exitFailure 99 | 100 | ("yaml2yaml-dump": args') 101 | | null args' -> cmdDumpYAML 102 | | otherwise -> do 103 | hPutStrLn stderr "unexpected arguments passed to yaml2event sub-command" 104 | exitFailure 105 | 106 | ("yaml2node":args') 107 | | null args' -> cmdPrintNode 108 | | otherwise -> do 109 | hPutStrLn stderr "unexpected arguments passed to yaml2event sub-command" 110 | exitFailure 111 | 112 | ("run-tml":args') -> cmdRunTml args' 113 | 114 | ("run-tml2":args') -> cmdRunTml' args' -- Temp function for check comment round-trip 115 | 116 | ("testml-compiler":args') -> cmdTestmlCompiler args' 117 | 118 | _ -> do 119 | hPutStrLn stderr "usage: yaml-test []" 120 | hPutStrLn stderr "" 121 | hPutStrLn stderr "Commands:" 122 | hPutStrLn stderr "" 123 | hPutStrLn stderr " yaml2token reads YAML stream from STDIN and dumps tokens to STDOUT" 124 | hPutStrLn stderr " yaml2token0 reads YAML stream from STDIN and prints count of tokens to STDOUT" 125 | hPutStrLn stderr " yaml2event reads YAML stream from STDIN and dumps events to STDOUT" 126 | hPutStrLn stderr " yaml2event0 reads YAML stream from STDIN and prints count of events to STDOUT" 127 | hPutStrLn stderr " yaml2event-pos reads YAML stream from STDIN and dumps events & position to STDOUT" 128 | hPutStrLn stderr " yaml2json reads YAML stream from STDIN and dumps JSON to STDOUT" 129 | hPutStrLn stderr " yaml2yaml reads YAML stream from STDIN and dumps YAML to STDOUT (non-streaming version)" 130 | hPutStrLn stderr " yaml2yaml- reads YAML stream from STDIN and dumps YAML to STDOUT (streaming version)" 131 | hPutStrLn stderr " yaml2yaml-validate reads YAML stream from STDIN and dumps YAML to STDOUT and also outputs the no. of differences and differences after a round-trip" 132 | hPutStrLn stderr " yaml2node reads YAML stream from STDIN and dumps YAML Nodes to STDOUT" 133 | hPutStrLn stderr " yaml2yaml-dump reads YAML stream from STDIN and dumps YAML to STDOUT after a complete round-trip" 134 | hPutStrLn stderr " run-tml run/validate YAML-specific .tml file(s)" 135 | hPutStrLn stderr " run-tml2 run/validate YAML-specific .tml file(s) while preserving comments" 136 | hPutStrLn stderr " testml-compiler emulate testml-compiler" 137 | 138 | exitFailure 139 | 140 | 141 | 142 | cmdYaml2Token :: IO () 143 | cmdYaml2Token = do 144 | inYamlDat <- BS.L.getContents 145 | forM_ (groupBy (\x y -> YT.tLine x == YT.tLine y) $ YT.tokenize inYamlDat False) $ \lgrp -> do 146 | forM_ lgrp $ \YT.Token{..} -> do 147 | let tText' | null tText = "" 148 | | any (== ' ') tText = replicate tLineChar ' ' ++ show tText 149 | | otherwise = replicate (tLineChar+1) ' ' ++ drop 1 (init (show tText)) 150 | hPutStrLn stdout $ printf ":%d:%d: %-15s| %s" tLine tLineChar (show tCode) tText' 151 | hPutStrLn stdout "" 152 | hFlush stdout 153 | 154 | cmdYaml2Token0 :: IO () 155 | cmdYaml2Token0 = do 156 | inYamlDat <- BS.L.getContents 157 | print (length (YT.tokenize inYamlDat False)) 158 | 159 | cmdYaml2Yaml :: IO () 160 | cmdYaml2Yaml = do 161 | inYamlDat <- BS.L.getContents 162 | case sequence $ parseEvents inYamlDat of 163 | Left (ofs,msg) -> do 164 | hPutStrLn stderr ("Parsing error near byte offset " ++ show ofs ++ if null msg then "" else " (" ++ msg ++ ")") 165 | exitFailure 166 | Right events -> do 167 | BS.L.hPutStr stdout (writeEvents YT.UTF8 (map eEvent events)) 168 | hFlush stdout 169 | 170 | -- lazy streaming version 171 | cmdYaml2Yaml' :: IO () 172 | cmdYaml2Yaml' = do 173 | inYamlDat <- BS.L.getContents 174 | BS.L.hPutStr stdout $ writeEvents YT.UTF8 $ parseEvents' inYamlDat 175 | hFlush stdout 176 | where 177 | parseEvents' = map (either (\(ofs,msg) -> error ("parsing error near byte offset " ++ show ofs ++ " (" ++ msg ++ ")")) (\evPos -> eEvent evPos)). filter (not. isComment). parseEvents 178 | 179 | cmdYaml2Event :: IO () 180 | cmdYaml2Event = do 181 | inYamlDat <- BS.L.getContents 182 | forM_ (parseEvents inYamlDat) $ \ev -> case ev of 183 | Left (ofs,msg) -> do 184 | hPutStrLn stderr ("Parsing error near byte offset " ++ show ofs ++ if null msg then "" else " (" ++ msg ++ ")") 185 | exitFailure 186 | Right event -> do 187 | hPutStrLn stdout (ev2str True (eEvent event)) 188 | hFlush stdout 189 | 190 | cmdYaml2EventPos :: IO () 191 | cmdYaml2EventPos = do 192 | inYamlDat <- BS.L.getContents 193 | let inYamlDatTxt = T.decodeUtf8 (BS.L.toStrict inYamlDat) 194 | inYamlDatLns = T.lines inYamlDatTxt 195 | maxLine = length inYamlDatLns 196 | 197 | forM_ (parseEvents inYamlDat) $ \ev -> case ev of 198 | Left (ofs,msg) -> do 199 | hPutStrLn stderr (prettyPosWithSource ofs inYamlDat (" error [" ++ show ofs ++ "]") ++ msg) 200 | exitFailure 201 | Right event -> do 202 | let Pos{..} = ePos event 203 | 204 | putStrLn (prettyPosWithSource (ePos event) inYamlDat ("\t" ++ ev2str True (eEvent event))) 205 | 206 | cmdYaml2Event0 :: IO () 207 | cmdYaml2Event0 = do 208 | inYamlDat <- BS.L.getContents 209 | print (length (parseEvents' inYamlDat)) 210 | where 211 | parseEvents' = map (either (\(ofs,msg) -> error ("parsing error near byte offset " ++ show ofs ++ " (" ++ msg ++ ")")) id) . parseEvents 212 | 213 | cmdYaml2YamlVal :: IO() 214 | cmdYaml2YamlVal = do 215 | inYamlDat <- BS.L.getContents 216 | case sequence $ parseEvents inYamlDat of 217 | Left (ofs,msg) -> do 218 | hPutStrLn stderr ("Parsing error near byte offset " ++ show ofs ++ if null msg then "" else " (" ++ msg ++ ")") 219 | exitFailure 220 | Right oldEvents -> do 221 | let output = writeEvents YT.UTF8 (map eEvent oldEvents) 222 | BS.L.hPutStr stdout output 223 | hFlush stdout 224 | case sequence (parseEvents output) of 225 | Left (ofs',msg') -> do 226 | hPutStrLn stderr ("Parsing error in the generated YAML stream near byte offset " ++ show ofs' ++ if null msg' then "" else " (" ++ msg' ++ ")") 227 | exitFailure 228 | Right newEvents -> do 229 | hPutStrLn stdout $ printf "\nInput Event Stream Length: %d\nOutput Event Stream Length: %d\n" (length oldEvents) (length newEvents) 230 | let diffList = filter (uncurry (/=)) $ zipWith (\a b -> (eEvent a, eEvent b)) oldEvents newEvents 231 | hPutStrLn stdout $ printf "No of difference detected: %d\n" $ length diffList 232 | forM_ diffList $ \(old,new) -> do 233 | hPutStrLn stdout $ "Input > " ++ show old 234 | hPutStrLn stdout $ "Output < " ++ show new 235 | 236 | cmdPrintNode :: IO() 237 | cmdPrintNode = do 238 | str <- BS.L.getContents 239 | case decode str :: Either (Pos, String) [Node Pos] of 240 | Left (pos, s) -> do 241 | hPutStrLn stdout s 242 | hFlush stdout 243 | Right nodeSeq -> forM_ nodeSeq $ \node -> do 244 | printNode node 245 | putStrLn "" 246 | 247 | cmdDumpYAML :: IO() 248 | cmdDumpYAML = do 249 | str <- BS.L.getContents 250 | case decode str :: Either (Pos, String) [Node Pos] of 251 | Left (pos, str) -> do 252 | hPutStrLn stdout str 253 | hFlush stdout 254 | Right nodes -> do 255 | BS.L.hPutStrLn stdout $ encode nodes 256 | hFlush stdout 257 | 258 | -- | 'J.Value' look-alike 259 | data Value' = Object' (Map Text Value') 260 | | Array' [Value'] 261 | | String' !Text 262 | | NumberD' !Double 263 | | NumberI' !Integer 264 | | Bool' !Bool 265 | | Null' 266 | deriving Show 267 | 268 | toProperValue :: Value' -> J.Value 269 | toProperValue v = case v of 270 | Null' -> J.Null 271 | String' t -> J.String t 272 | NumberD' x -> J.Number x 273 | NumberI' x -> J.Number (fromInteger x) 274 | Bool' b -> J.Bool b 275 | Array' xs -> J.Array (map toProperValue xs) 276 | Object' xs -> J.Object (fmap toProperValue xs) 277 | 278 | instance FromYAML Value' where 279 | parseYAML (Y.Scalar _ s) = case s of 280 | SNull -> pure Null' 281 | SBool b -> pure (Bool' b) 282 | SFloat x -> pure (NumberD' x) 283 | SInt x -> pure (NumberI' x) 284 | SStr t -> pure (String' t) 285 | SUnknown _ t -> pure (String' t) -- HACK 286 | 287 | parseYAML (Y.Sequence _ _ xs) = Array' <$> mapM parseYAML xs 288 | 289 | parseYAML (Y.Mapping _ _ m) = Object' . Map.fromList <$> mapM parseKV (Map.toList m) 290 | where 291 | parseKV :: (Y.Node Pos,Y.Node Pos) -> Parser (Text,Value') 292 | parseKV (k,v) = (,) <$> parseK k <*> parseYAML v 293 | 294 | -- for numbers and !!null we apply implicit conversions 295 | parseK n = do 296 | k <- parseYAML n 297 | case k of 298 | NumberI' t -> pure (T.pack (show t)) 299 | NumberD' t -> pure (T.pack (show t)) 300 | String' t -> pure t 301 | Null' -> pure "" 302 | -- we stringify the key with an added risk of nameclashing 303 | _ -> pure $ T.decodeUtf8 $ J.encodeStrict $ toProperValue k 304 | -- _ -> fail ("dictionary entry had non-string key " ++ show k) 305 | 306 | decodeAeson :: BS.L.ByteString -> Either (Pos,String) [J.Value] 307 | decodeAeson = fmap (map toProperValue) . decode' 308 | where 309 | -- TODO 310 | decode' :: FromYAML v => BS.L.ByteString -> Either (Pos,String) [v] 311 | decode' bs0 = case decodeNode' coreSchemaResolver { schemaResolverMappingDuplicates = True } False False bs0 of 312 | Left (pos, err) -> Left (pos, err) 313 | Right a -> Right a >>= mapM (parseEither . parseYAML . (\(Doc x) -> x)) 314 | 315 | 316 | -- | Try to convert 'Double' into 'Int64', return 'Nothing' if not 317 | -- representable loss-free as integral 'Int64' value. 318 | doubleToInt64 :: Double -> Maybe Int64 319 | doubleToInt64 x 320 | | fromInteger x' == x 321 | , x' <= toInteger (maxBound :: Int64) 322 | , x' >= toInteger (minBound :: Int64) 323 | = Just (fromIntegral x') 324 | | otherwise = Nothing 325 | where 326 | x' = round x 327 | 328 | 329 | decodeNumber :: T.Text -> Maybe Double 330 | decodeNumber = readMaybe . T.unpack -- fixme 331 | 332 | cmdYaml2Json :: IO () 333 | cmdYaml2Json = do 334 | inYamlDat <- BS.L.getContents 335 | 336 | case decodeAeson inYamlDat of 337 | Left (_, e) -> fail e 338 | Right vs -> do 339 | forM_ vs $ \v -> BS.L.putStrLn (J.encode v) 340 | 341 | return () 342 | 343 | unescapeSpcTab :: T.Text -> T.Text 344 | unescapeSpcTab = T.replace "" " " . T.replace "" "\t" 345 | 346 | 347 | data TestPass = PassExpErr -- ^ expected parse fail 348 | | PassEvs -- ^ events ok 349 | | PassEvsJson -- ^ events+json ok 350 | | PassEvsJsonYaml 351 | deriving (Eq,Ord,Show) 352 | 353 | data TestFail = FailParse -- ^ unexpected parse fail 354 | | FailSuccess -- ^ unexpected parse success 355 | | FailEvs -- ^ events wrong/mismatched 356 | | FailJson -- ^ JSON wrong/mismatched 357 | | FailYaml -- ^ YAML wrong/mismatched 358 | deriving (Eq,Ord,Show) 359 | 360 | data TestRes 361 | = Pass !TestPass 362 | | Fail !TestFail 363 | deriving (Eq,Ord,Show) 364 | 365 | cmdRunTml :: [FilePath] -> IO () 366 | cmdRunTml args = do 367 | results <- forM args $ \fn -> do 368 | tml <- BS.readFile fn 369 | 370 | hPutStr stdout (fn ++ " : ") 371 | hFlush stdout 372 | 373 | TML.Document _ blocks <- either (fail . T.unpack) pure $ TML.parse fn (T.decodeUtf8 tml) 374 | 375 | forM blocks $ \(TML.Block label points) -> do 376 | 377 | let dats = [ (k,v) | TML.PointStr k v <- points ] 378 | 379 | let isErr = isJust (lookup "error" dats) 380 | 381 | Just inYamlDat = BS.L.fromStrict . T.encodeUtf8 . unescapeSpcTab <$> lookup "in-yaml" dats 382 | Just testEvDat = lines . T.unpack . unescapeSpcTab <$> lookup "test-event" dats 383 | 384 | mInJsonDat :: Maybe [J.Value] 385 | mInJsonDat = (maybe (error ("invalid JSON in " ++ show fn)) id . J.decodeStrictN . T.encodeUtf8) <$> lookup "in-json" dats 386 | 387 | mOutYamlDat = BS.L.fromStrict . T.encodeUtf8 . unescapeSpcTab <$> lookup "out-yaml" dats 388 | 389 | case sequence $ filter (not. isComment) (parseEvents inYamlDat) of 390 | Left err 391 | | isErr -> do 392 | putStrLn "OK! (error)" 393 | pure (Pass PassExpErr) 394 | | otherwise -> do 395 | putStrLn "FAIL!" 396 | putStrLn "" 397 | putStrLn "----------------------------------------------------------------------------" 398 | putStrLn' (T.unpack label) 399 | putStrLn "" 400 | putStrLn' (show err) 401 | putStrLn "" 402 | putStrLn' (show testEvDat) 403 | putStrLn "" 404 | BS.L.putStr inYamlDat 405 | putStrLn "" 406 | testParse inYamlDat 407 | putStrLn "" 408 | -- forM_ (parseEvents inYamlDat) (putStrLn' . show) 409 | putStrLn "" 410 | putStrLn "----------------------------------------------------------------------------" 411 | putStrLn "" 412 | pure (Fail FailParse) 413 | 414 | Right evs' -> do 415 | let events = map eEvent evs' 416 | evs'' = map (ev2str False) events 417 | if evs'' == testEvDat 418 | then do 419 | 420 | let outYamlDatIut = writeEvents YT.UTF8 (map toBlockStyle events) 421 | where toBlockStyle ev = case ev of 422 | SequenceStart a b _ -> SequenceStart a b Block 423 | MappingStart a b _ -> MappingStart a b Block 424 | otherwise -> ev 425 | Right ev = sequence $ filter (not. isComment) (parseEvents outYamlDatIut) 426 | outYamlEvsIut = either (const []) (map (ev2str False)) (Right (map eEvent ev)) 427 | 428 | unless (outYamlEvsIut == evs'') $ do 429 | putStrLn' ("\nWARNING: (iut /= ref)") 430 | 431 | putStrLn' ("iut[yaml] = " ++ show outYamlDatIut) 432 | putStrLn' ("ref[raw-evs] = " ++ show evs') 433 | putStrLn' ("ref[evs] = " ++ show evs'') 434 | putStrLn' ("iut[evs] = " ++ show outYamlEvsIut) 435 | 436 | putStrLn "" 437 | 438 | 439 | case mInJsonDat of 440 | Nothing -> do 441 | putStrLn "OK!" 442 | pure (Pass PassEvs) 443 | Just inJsonDat -> do 444 | iutJson <- either (fail. snd) pure $ decodeAeson inYamlDat 445 | 446 | if iutJson == inJsonDat 447 | then do 448 | case mOutYamlDat of 449 | Nothing -> do 450 | putStrLn "OK! (+JSON)" 451 | pure (Pass PassEvsJson) 452 | Just outYamlDat -> do 453 | case () of 454 | _ | outYamlDat == outYamlDatIut -> do 455 | putStrLn "OK! (+JSON+YAML)" 456 | pure (Pass PassEvsJsonYaml) 457 | 458 | | otherwise -> do 459 | 460 | putStrLn $ if outYamlEvsIut == evs'' then "OK (+JSON-YAML)" else "FAIL! (bad out-YAML)" 461 | 462 | putStrLn' ("ref = " ++ show outYamlDat) 463 | putStrLn' ("iut = " ++ show outYamlDatIut) 464 | putStrLn "" 465 | putStrLn' ("ref = " ++ show evs'') 466 | putStrLn' ("iut = " ++ show outYamlEvsIut) 467 | 468 | case outYamlEvsIut == evs'' of 469 | True -> do 470 | putStrLn' ("(iut == ref)") 471 | pure (Pass PassEvsJson) 472 | False -> pure (Fail FailYaml) 473 | 474 | 475 | else do 476 | putStrLn "FAIL! (bad JSON)" 477 | 478 | putStrLn' ("ref = " ++ show inJsonDat) 479 | putStrLn' ("iut = " ++ show iutJson) 480 | 481 | pure (Fail FailJson) 482 | 483 | else do 484 | if isErr 485 | then putStrLn "FAIL! (unexpected parser success)" 486 | else putStrLn "FAIL!" 487 | 488 | putStrLn "" 489 | putStrLn "----------------------------------------------------------------------------" 490 | putStrLn' (T.unpack label) 491 | putStrLn "" 492 | putStrLn' ("ref = " ++ show testEvDat) 493 | putStrLn' ("iut = " ++ show evs'') 494 | putStrLn "" 495 | BS.L.putStr inYamlDat 496 | putStrLn "" 497 | testParse inYamlDat 498 | putStrLn "" 499 | -- forM_ (parseEvents inYamlDat) (putStrLn' . show) 500 | putStrLn "" 501 | putStrLn "----------------------------------------------------------------------------" 502 | putStrLn "" 503 | pure (Fail (if isErr then FailSuccess else FailEvs)) 504 | 505 | putStrLn "" 506 | 507 | let ok = length [ () | Pass _ <- results' ] 508 | nok = length [ () | Fail _ <- results' ] 509 | 510 | stat j = show $ Map.findWithDefault 0 j $ Map.fromListWith (+) [ (k,1::Int) | k <- results' ] 511 | 512 | results' = concat results 513 | 514 | putStrLn $ concat 515 | [ "done -- passed: ", show ok 516 | , " (ev: ", stat (Pass PassEvs), ", ev+json: ", stat (Pass PassEvsJson), ", ev+json+yaml: ", stat (Pass PassEvsJsonYaml), ", err: ", stat (Pass PassExpErr), ") / " 517 | , "failed: ", show nok 518 | , " (err: ", stat (Fail FailParse), ", ev:", stat (Fail FailEvs), ", json:", stat (Fail FailJson), ", yaml:", stat (Fail FailYaml), ", ok:", stat (Fail FailSuccess), ")" 519 | ] 520 | 521 | cmdRunTml' :: [FilePath] -> IO () 522 | cmdRunTml' args = do 523 | results <- forM args $ \fn -> do 524 | tml <- BS.readFile fn 525 | 526 | hPutStr stdout (fn ++ " : ") 527 | hFlush stdout 528 | 529 | TML.Document _ blocks <- either (fail . T.unpack) pure $ TML.parse fn (T.decodeUtf8 tml) 530 | 531 | forM blocks $ \(TML.Block label points) -> do 532 | 533 | let dats = [ (k,v) | TML.PointStr k v <- points ] 534 | 535 | let isErr = isJust (lookup "error" dats) 536 | 537 | Just inYamlDat = BS.L.fromStrict . T.encodeUtf8 . unescapeSpcTab <$> lookup "in-yaml" dats 538 | Just testEvDat = lines . T.unpack . unescapeSpcTab <$> lookup "test-event" dats 539 | 540 | mInJsonDat :: Maybe [J.Value] 541 | mInJsonDat = (maybe (error ("invalid JSON in " ++ show fn)) id . J.decodeStrictN . T.encodeUtf8) <$> lookup "in-json" dats 542 | 543 | mOutYamlDat = BS.L.fromStrict . T.encodeUtf8 . unescapeSpcTab <$> lookup "out-yaml" dats 544 | 545 | case sequence $ parseEvents inYamlDat of -- allow parsing with comments 546 | Left err 547 | | isErr -> do 548 | putStrLn "OK! (error)" 549 | pure (Pass PassExpErr) 550 | | otherwise -> do 551 | putStrLn "FAIL!" 552 | putStrLn "" 553 | putStrLn "----------------------------------------------------------------------------" 554 | putStrLn' (T.unpack label) 555 | putStrLn "" 556 | putStrLn' (show err) 557 | putStrLn "" 558 | putStrLn' (show testEvDat) 559 | putStrLn "" 560 | BS.L.putStr inYamlDat 561 | putStrLn "" 562 | testParse inYamlDat 563 | putStrLn "" 564 | -- forM_ (parseEvents inYamlDat) (putStrLn' . show) 565 | putStrLn "" 566 | putStrLn "----------------------------------------------------------------------------" 567 | putStrLn "" 568 | pure (Fail FailParse) 569 | 570 | Right evs' -> do 571 | let events = map eEvent (filter (not. isComment'. eEvent) evs') -- filter comments before comparing 572 | evs'' = map (ev2str False) events 573 | if evs'' == testEvDat 574 | then do 575 | let outYamlDatIut = writeEvents YT.UTF8 (map eEvent evs') -- Allow both block and flow style 576 | -- let outYamlDatIut = writeEvents YT.UTF8 (map (toBlockStyle. eEvent) evs') -- Allow only Block style 577 | -- where toBlockStyle ev = case ev of 578 | -- SequenceStart a b _ -> SequenceStart a b Block 579 | -- MappingStart a b _ -> MappingStart a b Block 580 | -- otherwise -> ev 581 | Right ev = sequence $ parseEvents outYamlDatIut 582 | outYamlEvsIut = either (const []) (map (ev2str False)) (Right (map eEvent (filter (not. isComment'. eEvent) ev))) 583 | 584 | unless (outYamlEvsIut == evs'') $ do 585 | putStrLn' ("\nWARNING: (iut /= ref)") 586 | 587 | putStrLn' ("iut[yaml] = " ++ show outYamlDatIut) 588 | putStrLn' ("ref[raw-evs] = " ++ show evs') 589 | putStrLn' ("ref[evs] = " ++ show evs'') 590 | putStrLn' ("iut[evs] = " ++ show outYamlEvsIut) 591 | 592 | putStrLn "" 593 | 594 | 595 | case mInJsonDat of 596 | Nothing -> do 597 | putStrLn "OK!" 598 | pure (Pass PassEvs) 599 | Just inJsonDat -> do 600 | iutJson <- either (fail. snd) pure $ decodeAeson inYamlDat 601 | 602 | if iutJson == inJsonDat 603 | then do 604 | case mOutYamlDat of 605 | Nothing -> do 606 | putStrLn "OK! (+JSON)" 607 | pure (Pass PassEvsJson) 608 | Just outYamlDat -> do 609 | case () of 610 | _ | outYamlDat == outYamlDatIut -> do 611 | putStrLn "OK! (+JSON+YAML)" 612 | pure (Pass PassEvsJsonYaml) 613 | 614 | | otherwise -> do 615 | 616 | putStrLn $ if outYamlEvsIut == evs'' then "OK (+JSON-YAML)" else "FAIL! (bad out-YAML)" 617 | 618 | putStrLn' ("ref = " ++ show outYamlDat) 619 | putStrLn' ("iut = " ++ show outYamlDatIut) 620 | putStrLn "" 621 | putStrLn' ("ref = " ++ show evs'') 622 | putStrLn' ("iut = " ++ show outYamlEvsIut) 623 | 624 | case outYamlEvsIut == evs'' of 625 | True -> do 626 | putStrLn' ("(iut == ref)") 627 | pure (Pass PassEvsJson) 628 | False -> pure (Fail FailYaml) 629 | 630 | 631 | else do 632 | putStrLn "FAIL! (bad JSON)" 633 | 634 | putStrLn' ("ref = " ++ show inJsonDat) 635 | putStrLn' ("iut = " ++ show iutJson) 636 | 637 | pure (Fail FailJson) 638 | 639 | else do 640 | if isErr 641 | then putStrLn "FAIL! (unexpected parser success)" 642 | else putStrLn "FAIL!" 643 | 644 | putStrLn "" 645 | putStrLn "----------------------------------------------------------------------------" 646 | putStrLn' (T.unpack label) 647 | putStrLn "" 648 | putStrLn' ("ref = " ++ show testEvDat) 649 | putStrLn' ("iut = " ++ show evs'') 650 | putStrLn "" 651 | BS.L.putStr inYamlDat 652 | putStrLn "" 653 | testParse inYamlDat 654 | putStrLn "" 655 | -- forM_ (parseEvents inYamlDat) (putStrLn' . show) 656 | putStrLn "" 657 | putStrLn "----------------------------------------------------------------------------" 658 | putStrLn "" 659 | pure (Fail (if isErr then FailSuccess else FailEvs)) 660 | 661 | putStrLn "" 662 | 663 | let ok = length [ () | Pass _ <- results' ] 664 | nok = length [ () | Fail _ <- results' ] 665 | 666 | stat j = show $ Map.findWithDefault 0 j $ Map.fromListWith (+) [ (k,1::Int) | k <- results' ] 667 | 668 | results' = concat results 669 | 670 | putStrLn $ concat 671 | [ "done -- passed: ", show ok 672 | , " (ev: ", stat (Pass PassEvs), ", ev+json: ", stat (Pass PassEvsJson), ", ev+json+yaml: ", stat (Pass PassEvsJsonYaml), ", err: ", stat (Pass PassExpErr), ") / " 673 | , "failed: ", show nok 674 | , " (err: ", stat (Fail FailParse), ", ev:", stat (Fail FailEvs), ", json:", stat (Fail FailJson), ", yaml:", stat (Fail FailYaml), ", ok:", stat (Fail FailSuccess), ")" 675 | ] 676 | 677 | -- | Incomplete proof-of-concept 'testml-compiler' operation 678 | cmdTestmlCompiler :: [FilePath] -> IO () 679 | cmdTestmlCompiler [fn0] = do 680 | (fn,raw) <- case fn0 of 681 | "-" -> (,) "" <$> T.getContents 682 | _ -> (,) fn0 <$> T.readFile fn0 683 | 684 | case TML.parse fn raw of 685 | Left e -> T.hPutStrLn stderr e >> exitFailure 686 | Right doc -> BS.putStrLn (J.encodeStrict doc) 687 | cmdTestmlCompiler _ = do 688 | hPutStrLn stderr ("Usage: yaml-test testml-compiler [ | - ]") 689 | exitFailure 690 | 691 | 692 | putStrLn' :: String -> IO () 693 | putStrLn' msg = putStrLn (" " ++ msg) 694 | 695 | printNode :: Node loc -> IO () 696 | printNode node = case node of 697 | (Y.Scalar _ a) -> hPutStrLn stdout $ "Scalar " ++ show a 698 | (Y.Mapping _ a b) -> do 699 | hPutStrLn stdout $ "Mapping " ++ show a 700 | printMap b 701 | (Y.Sequence _ a b) -> do 702 | hPutStrLn stdout $ "Sequence " ++ show a 703 | mapM_ printNode b 704 | (Y.Anchor _ a b) -> do 705 | hPutStr stdout $ "Anchor " ++ show a ++ " " 706 | printNode b 707 | 708 | printMap :: Map (Node loc) (Node loc) -> IO () 709 | printMap b = forM_ (Map.toList b) $ \(k,v) -> do 710 | hPutStr stdout "Key: " 711 | printNode k 712 | hPutStr stdout "Value: " 713 | printNode v 714 | 715 | isComment evPos = case evPos of 716 | Right (YE.EvPos {eEvent = (YE.Comment _), ePos = _}) -> True 717 | _ -> False 718 | 719 | isComment' ev = case ev of 720 | (Comment _) -> True 721 | _ -> False 722 | 723 | ev2str :: Bool -> Event -> String 724 | ev2str withColSty = \case 725 | StreamStart -> "+STR" 726 | DocumentStart NoDirEndMarker-> "+DOC" 727 | DocumentStart _ -> "+DOC ---" 728 | MappingEnd -> "-MAP" 729 | (MappingStart manc mtag Flow) 730 | | withColSty -> "+MAP {}" ++ ancTagStr manc mtag 731 | (MappingStart manc mtag _) -> "+MAP" ++ ancTagStr manc mtag 732 | SequenceEnd -> "-SEQ" 733 | (SequenceStart manc mtag Flow) 734 | | withColSty -> "+SEQ []" ++ ancTagStr manc mtag 735 | SequenceStart manc mtag _ -> "+SEQ" ++ ancTagStr manc mtag 736 | DocumentEnd True -> "-DOC ..." 737 | DocumentEnd False -> "-DOC" 738 | StreamEnd -> "-STR" 739 | Alias a -> "=ALI *" ++ T.unpack a 740 | YE.Scalar manc mtag sty v -> "=VAL" ++ ancTagStr manc mtag ++ styStr sty ++ quote2 v 741 | Comment comment -> "=COMMENT "++ quote2 comment 742 | where 743 | styStr = \case 744 | Plain -> " :" 745 | DoubleQuoted -> " \"" 746 | Literal _ _ -> " |" 747 | Folded _ _ -> " >" 748 | SingleQuoted -> " '" 749 | 750 | ancTagStr manc mtag = anc' ++ tag' 751 | where 752 | anc' = case manc of 753 | Nothing -> "" 754 | Just anc -> " &" ++ T.unpack anc 755 | 756 | tag' = case tagToText mtag of 757 | Nothing -> "" 758 | Just t -> " <" ++ T.unpack t ++ ">" 759 | 760 | 761 | quote2 :: T.Text -> String 762 | quote2 = concatMap go . T.unpack 763 | where 764 | go c | c == '\n' = "\\n" 765 | | c == '\t' = "\\t" 766 | | c == '\b' = "\\b" 767 | | c == '\r' = "\\r" 768 | | c == '\\' = "\\\\" 769 | | otherwise = [c] 770 | 771 | 772 | 773 | testParse :: BS.L.ByteString -> IO () 774 | testParse bs0 = mapM_ (putStrLn' . showT) $ YT.tokenize bs0 False 775 | where 776 | showT :: YT.Token -> String 777 | showT t = replicate (YT.tLineChar t) ' ' ++ show (YT.tText t) ++ " " ++ show (YT.tCode t) 778 | --------------------------------------------------------------------------------