tomland (empty) → 0.0.0
raw patch · 20 files changed
+1746/−0 lines, 20 filesdep +basedep +hashabledep +hedgehogsetup-changed
Dependencies added: base, hashable, hedgehog, megaparsec, mtl, parser-combinators, tasty, tasty-hedgehog, tasty-hspec, text, time, tomland, unordered-containers
Files
- LICENSE +373/−0
- README.md +8/−0
- Setup.hs +2/−0
- examples/Playground.hs +83/−0
- src/Toml.hs +19/−0
- src/Toml/Bi.hs +9/−0
- src/Toml/Bi/Combinators.hs +149/−0
- src/Toml/Bi/Monad.hs +87/−0
- src/Toml/Parser.hs +149/−0
- src/Toml/PrefixTree.hs +169/−0
- src/Toml/Printer.hs +116/−0
- src/Toml/Type.hs +225/−0
- test/Spec.hs +11/−0
- test/Test/Toml/Gen.hs +105/−0
- test/Test/Toml/Parsing.hs +10/−0
- test/Test/Toml/Parsing/Property.hs +20/−0
- test/Test/Toml/PrefixTree.hs +13/−0
- test/Test/Toml/PrefixTree/Property.hs +59/−0
- test/Test/Toml/PrefixTree/Unit.hs +49/−0
- tomland.cabal +90/−0
+ LICENSE view
@@ -0,0 +1,373 @@+Mozilla Public License Version 2.0+==================================++1. Definitions+--------------++1.1. "Contributor"+ means each individual or legal entity that creates, contributes to+ the creation of, or owns Covered Software.++1.2. "Contributor Version"+ means the combination of the Contributions of others (if any) used+ by a Contributor and that particular Contributor's Contribution.++1.3. "Contribution"+ means Covered Software of a particular Contributor.++1.4. "Covered Software"+ means Source Code Form to which the initial Contributor has attached+ the notice in Exhibit A, the Executable Form of such Source Code+ Form, and Modifications of such Source Code Form, in each case+ including portions thereof.++1.5. "Incompatible With Secondary Licenses"+ means++ (a) that the initial Contributor has attached the notice described+ in Exhibit B to the Covered Software; or++ (b) that the Covered Software was made available under the terms of+ version 1.1 or earlier of the License, but not also under the+ terms of a Secondary License.++1.6. "Executable Form"+ means any form of the work other than Source Code Form.++1.7. "Larger Work"+ means a work that combines Covered Software with other material, in+ a separate file or files, that is not Covered Software.++1.8. "License"+ means this document.++1.9. "Licensable"+ means having the right to grant, to the maximum extent possible,+ whether at the time of the initial grant or subsequently, any and+ all of the rights conveyed by this License.++1.10. "Modifications"+ means any of the following:++ (a) any file in Source Code Form that results from an addition to,+ deletion from, or modification of the contents of Covered+ Software; or++ (b) any new file in Source Code Form that contains any Covered+ Software.++1.11. "Patent Claims" of a Contributor+ means any patent claim(s), including without limitation, method,+ process, and apparatus claims, in any patent Licensable by such+ Contributor that would be infringed, but for the grant of the+ License, by the making, using, selling, offering for sale, having+ made, import, or transfer of either its Contributions or its+ Contributor Version.++1.12. "Secondary License"+ means either the GNU General Public License, Version 2.0, the GNU+ Lesser General Public License, Version 2.1, the GNU Affero General+ Public License, Version 3.0, or any later versions of those+ licenses.++1.13. "Source Code Form"+ means the form of the work preferred for making modifications.++1.14. "You" (or "Your")+ means an individual or a legal entity exercising rights under this+ License. For legal entities, "You" includes any entity that+ controls, is controlled by, or is under common control with You. For+ purposes of this definition, "control" means (a) the power, direct+ or indirect, to cause the direction or management of such entity,+ whether by contract or otherwise, or (b) ownership of more than+ fifty percent (50%) of the outstanding shares or beneficial+ ownership of such entity.++2. License Grants and Conditions+--------------------------------++2.1. Grants++Each Contributor hereby grants You a world-wide, royalty-free,+non-exclusive license:++(a) under intellectual property rights (other than patent or trademark)+ Licensable by such Contributor to use, reproduce, make available,+ modify, display, perform, distribute, and otherwise exploit its+ Contributions, either on an unmodified basis, with Modifications, or+ as part of a Larger Work; and++(b) under Patent Claims of such Contributor to make, use, sell, offer+ for sale, have made, import, and otherwise transfer either its+ Contributions or its Contributor Version.++2.2. Effective Date++The licenses granted in Section 2.1 with respect to any Contribution+become effective for each Contribution on the date the Contributor first+distributes such Contribution.++2.3. Limitations on Grant Scope++The licenses granted in this Section 2 are the only rights granted under+this License. No additional rights or licenses will be implied from the+distribution or licensing of Covered Software under this License.+Notwithstanding Section 2.1(b) above, no patent license is granted by a+Contributor:++(a) for any code that a Contributor has removed from Covered Software;+ or++(b) for infringements caused by: (i) Your and any other third party's+ modifications of Covered Software, or (ii) the combination of its+ Contributions with other software (except as part of its Contributor+ Version); or++(c) under Patent Claims infringed by Covered Software in the absence of+ its Contributions.++This License does not grant any rights in the trademarks, service marks,+or logos of any Contributor (except as may be necessary to comply with+the notice requirements in Section 3.4).++2.4. Subsequent Licenses++No Contributor makes additional grants as a result of Your choice to+distribute the Covered Software under a subsequent version of this+License (see Section 10.2) or under the terms of a Secondary License (if+permitted under the terms of Section 3.3).++2.5. Representation++Each Contributor represents that the Contributor believes its+Contributions are its original creation(s) or it has sufficient rights+to grant the rights to its Contributions conveyed by this License.++2.6. Fair Use++This License is not intended to limit any rights You have under+applicable copyright doctrines of fair use, fair dealing, or other+equivalents.++2.7. Conditions++Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted+in Section 2.1.++3. Responsibilities+-------------------++3.1. Distribution of Source Form++All distribution of Covered Software in Source Code Form, including any+Modifications that You create or to which You contribute, must be under+the terms of this License. You must inform recipients that the Source+Code Form of the Covered Software is governed by the terms of this+License, and how they can obtain a copy of this License. You may not+attempt to alter or restrict the recipients' rights in the Source Code+Form.++3.2. Distribution of Executable Form++If You distribute Covered Software in Executable Form then:++(a) such Covered Software must also be made available in Source Code+ Form, as described in Section 3.1, and You must inform recipients of+ the Executable Form how they can obtain a copy of such Source Code+ Form by reasonable means in a timely manner, at a charge no more+ than the cost of distribution to the recipient; and++(b) You may distribute such Executable Form under the terms of this+ License, or sublicense it under different terms, provided that the+ license for the Executable Form does not attempt to limit or alter+ the recipients' rights in the Source Code Form under this License.++3.3. Distribution of a Larger Work++You may create and distribute a Larger Work under terms of Your choice,+provided that You also comply with the requirements of this License for+the Covered Software. If the Larger Work is a combination of Covered+Software with a work governed by one or more Secondary Licenses, and the+Covered Software is not Incompatible With Secondary Licenses, this+License permits You to additionally distribute such Covered Software+under the terms of such Secondary License(s), so that the recipient of+the Larger Work may, at their option, further distribute the Covered+Software under the terms of either this License or such Secondary+License(s).++3.4. Notices++You may not remove or alter the substance of any license notices+(including copyright notices, patent notices, disclaimers of warranty,+or limitations of liability) contained within the Source Code Form of+the Covered Software, except that You may alter any license notices to+the extent required to remedy known factual inaccuracies.++3.5. Application of Additional Terms++You may choose to offer, and to charge a fee for, warranty, support,+indemnity or liability obligations to one or more recipients of Covered+Software. However, You may do so only on Your own behalf, and not on+behalf of any Contributor. You must make it absolutely clear that any+such warranty, support, indemnity, or liability obligation is offered by+You alone, and You hereby agree to indemnify every Contributor for any+liability incurred by such Contributor as a result of warranty, support,+indemnity or liability terms You offer. You may include additional+disclaimers of warranty and limitations of liability specific to any+jurisdiction.++4. Inability to Comply Due to Statute or Regulation+---------------------------------------------------++If it is impossible for You to comply with any of the terms of this+License with respect to some or all of the Covered Software due to+statute, judicial order, or regulation then You must: (a) comply with+the terms of this License to the maximum extent possible; and (b)+describe the limitations and the code they affect. Such description must+be placed in a text file included with all distributions of the Covered+Software under this License. Except to the extent prohibited by statute+or regulation, such description must be sufficiently detailed for a+recipient of ordinary skill to be able to understand it.++5. Termination+--------------++5.1. The rights granted under this License will terminate automatically+if You fail to comply with any of its terms. However, if You become+compliant, then the rights granted under this License from a particular+Contributor are reinstated (a) provisionally, unless and until such+Contributor explicitly and finally terminates Your grants, and (b) on an+ongoing basis, if such Contributor fails to notify You of the+non-compliance by some reasonable means prior to 60 days after You have+come back into compliance. Moreover, Your grants from a particular+Contributor are reinstated on an ongoing basis if such Contributor+notifies You of the non-compliance by some reasonable means, this is the+first time You have received notice of non-compliance with this License+from such Contributor, and You become compliant prior to 30 days after+Your receipt of the notice.++5.2. If You initiate litigation against any entity by asserting a patent+infringement claim (excluding declaratory judgment actions,+counter-claims, and cross-claims) alleging that a Contributor Version+directly or indirectly infringes any patent, then the rights granted to+You by any and all Contributors for the Covered Software under Section+2.1 of this License shall terminate.++5.3. In the event of termination under Sections 5.1 or 5.2 above, all+end user license agreements (excluding distributors and resellers) which+have been validly granted by You or Your distributors under this License+prior to termination shall survive termination.++************************************************************************+* *+* 6. Disclaimer of Warranty *+* ------------------------- *+* *+* Covered Software is provided under this License on an "as is" *+* basis, without warranty of any kind, either expressed, implied, or *+* statutory, including, without limitation, warranties that the *+* Covered Software is free of defects, merchantable, fit for a *+* particular purpose or non-infringing. The entire risk as to the *+* quality and performance of the Covered Software is with You. *+* Should any Covered Software prove defective in any respect, You *+* (not any Contributor) assume the cost of any necessary servicing, *+* repair, or correction. This disclaimer of warranty constitutes an *+* essential part of this License. No use of any Covered Software is *+* authorized under this License except under this disclaimer. *+* *+************************************************************************++************************************************************************+* *+* 7. Limitation of Liability *+* -------------------------- *+* *+* Under no circumstances and under no legal theory, whether tort *+* (including negligence), contract, or otherwise, shall any *+* Contributor, or anyone who distributes Covered Software as *+* permitted above, be liable to You for any direct, indirect, *+* special, incidental, or consequential damages of any character *+* including, without limitation, damages for lost profits, loss of *+* goodwill, work stoppage, computer failure or malfunction, or any *+* and all other commercial damages or losses, even if such party *+* shall have been informed of the possibility of such damages. This *+* limitation of liability shall not apply to liability for death or *+* personal injury resulting from such party's negligence to the *+* extent applicable law prohibits such limitation. Some *+* jurisdictions do not allow the exclusion or limitation of *+* incidental or consequential damages, so this exclusion and *+* limitation may not apply to You. *+* *+************************************************************************++8. Litigation+-------------++Any litigation relating to this License may be brought only in the+courts of a jurisdiction where the defendant maintains its principal+place of business and such litigation shall be governed by laws of that+jurisdiction, without reference to its conflict-of-law provisions.+Nothing in this Section shall prevent a party's ability to bring+cross-claims or counter-claims.++9. Miscellaneous+----------------++This License represents the complete agreement concerning the subject+matter hereof. If any provision of this License is held to be+unenforceable, such provision shall be reformed only to the extent+necessary to make it enforceable. Any law or regulation which provides+that the language of a contract shall be construed against the drafter+shall not be used to construe this License against a Contributor.++10. Versions of the License+---------------------------++10.1. New Versions++Mozilla Foundation is the license steward. Except as provided in Section+10.3, no one other than the license steward has the right to modify or+publish new versions of this License. Each version will be given a+distinguishing version number.++10.2. Effect of New Versions++You may distribute the Covered Software under the terms of the version+of the License under which You originally received the Covered Software,+or under the terms of any subsequent version published by the license+steward.++10.3. Modified Versions++If you create software not governed by this License, and you want to+create a new license for such software, you may create and use a+modified version of this License if you rename the license and remove+any references to the name of the license steward (except to note that+such modified license differs from this License).++10.4. Distributing Source Code Form that is Incompatible With Secondary+Licenses++If You choose to distribute Source Code Form that is Incompatible With+Secondary Licenses under the terms of this version of the License, the+notice described in Exhibit B of this License must be attached.++Exhibit A - Source Code Form License Notice+-------------------------------------------++ This Source Code Form is subject to the terms of the Mozilla Public+ License, v. 2.0. If a copy of the MPL was not distributed with this+ file, You can obtain one at http://mozilla.org/MPL/2.0/.++If it is not possible or desirable to put the notice in a particular+file, then You may include the notice in a location (such as a LICENSE+file in a relevant directory) where a recipient would be likely to look+for such a notice.++You may add additional accurate notices of copyright ownership.++Exhibit B - "Incompatible With Secondary Licenses" Notice+---------------------------------------------------------++ This Source Code Form is "Incompatible With Secondary Licenses", as+ defined by the Mozilla Public License, v. 2.0.
+ README.md view
@@ -0,0 +1,8 @@+# tomland++[](https://hackage.haskell.org/package/tomland)+[](https://travis-ci.org/kowainik/tomland)+[](https://ci.appveyor.com/project/kowainik/tomland)+[](https://github.com/kowainik/tomland/blob/master/LICENSE)++TOML parser
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Playground.hs view
@@ -0,0 +1,83 @@+module Main where++import Data.Text (Text)+import Data.Time (fromGregorian)++import Toml.Bi (BiToml, (.=))+import Toml.Parser (ParseException (..), parse)+import Toml.PrefixTree (Key (..), Piece (..), PrefixMap, fromList)+import Toml.Printer (prettyToml)+import Toml.Type (AnyValue (..), DateTime (..), TOML (..), Value (..))++import qualified Data.HashMap.Strict as HashMap+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Text.IO as TIO+import qualified Toml++data Test = Test+ { testB :: Bool+ , testI :: Int+ , testF :: Double+ , testS :: Text+ }++testT :: BiToml Test+testT = Test+ <$> Toml.bool (key ["testB"]) .= testB+ <*> Toml.int (key ["testI"]) .= testI+ <*> Toml.double (key ["testF"]) .= testF+ <*> Toml.str (key ["testS"]) .= testS++main :: IO ()+main = do+ TIO.putStrLn "=== Printing manually specified TOML ==="+ TIO.putStrLn $ prettyToml myToml++ TIO.putStrLn "=== Printing parsed TOML ==="+ content <- TIO.readFile "test.toml"+ case parse content of+ Left (ParseException e) -> TIO.putStrLn e+ Right toml -> TIO.putStrLn $ prettyToml toml++ TIO.putStrLn "=== Testing bidirectional conversion ==="+ biFile <- TIO.readFile "examples/biTest.toml"+ case Toml.encode testT biFile of+ Left _ -> putStrLn "Some error"+ Right test -> TIO.putStrLn $ Toml.unsafeDecode testT test++key :: [Text] -> Key+key = Key . NonEmpty.fromList . map Piece++myToml :: TOML+myToml = TOML (HashMap.fromList+ [ (key ["a"] , AnyValue $ Bool True)+ , (key ["list"], AnyValue $ Array [String "one", String "two"])+ , (key ["time"], AnyValue $ Array [Date $ Day (fromGregorian 2018 3 29)])+ ] ) myInnerToml++myInnerToml :: PrefixMap TOML+myInnerToml = fromList+ [ ( key ["table", "name", "1"]+ , TOML (HashMap.fromList+ [ (key ["aInner"] , AnyValue $ Int 1)+ , (key ["listInner"], AnyValue $ Array [Bool True, Bool False])+ ]) myInnerInnerToml+ )+ , ( key ["table", "name", "2"]+ , TOML (HashMap.fromList [(key ["2Inner"], AnyValue $ Int 42)]) mempty+ )+ ]+++myInnerInnerToml :: PrefixMap TOML+myInnerInnerToml = fromList+ [ ( key ["table", "name", "1", "1"]+ , TOML (HashMap.fromList+ [ (key ["aInner"] , AnyValue $ Int 1)+ , (key ["listInner"], AnyValue $ Array [Bool True, Bool False])+ ]) mempty+ )+ , ( key ["table", "name", "1", "2"]+ , TOML (HashMap.fromList [(key ["Inner1.2"], AnyValue $ Int 42)]) mempty+ )+ ]
+ src/Toml.hs view
@@ -0,0 +1,19 @@+{- | This module reexports all functionality of @tomland@ package. It's+suggested to import this module qualified, like this:++@+import qualified Toml+@+-}++module Toml+ ( module Toml.Bi+ , module Toml.Parser+ , module Toml.Printer+ , module Toml.Type+ ) where++import Toml.Bi+import Toml.Parser+import Toml.Printer+import Toml.Type
+ src/Toml/Bi.hs view
@@ -0,0 +1,9 @@+-- | Reexports functions under @Toml.Bi.*@.++module Toml.Bi+ ( module Toml.Bi.Combinators+ , module Toml.Bi.Monad+ ) where++import Toml.Bi.Combinators+import Toml.Bi.Monad
+ src/Toml/Bi/Combinators.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Contains TOML-specific combinators for converting between TOML and user data types.++module Toml.Bi.Combinators+ ( -- * Types+ BiToml+ , Env+ , St++ -- * Exceptions+ , EncodeException+ , DecodeException++ -- * Encode/Decode+ , encode+ , decode+ , unsafeDecode++ -- * Converters+ , bijectionMaker+ , bool+ , int+ , double+ , str+ ) where++import Control.Monad.Except (ExceptT, runExceptT, throwError)+import Control.Monad.Reader (Reader, asks, runReader)+import Control.Monad.State (State, gets, modify, runState)+import Data.Bifunctor (first)+import Data.Text (Text)++import Toml.Bi.Monad (Bi, Bijection (..))+import Toml.Parser (ParseException, parse)+import Toml.PrefixTree (Key)+import Toml.Printer (prettyToml)+import Toml.Type (AnyValue (..), TOML (..), Value (..))++import qualified Data.HashMap.Strict as HashMap++-- | Type of exception for converting from 'Toml' to user custom data type.+data EncodeException+ = KeyNotFound Key -- ^ such key is not present in 'Toml'+ | TypeMismatch Text -- ^ Expected type; TODO: add actual type+ | ParseError ParseException -- ^ Exception during parsing+ deriving (Eq, Show) -- TODO: manual pretty show instances++-- | Immutable environment for 'Toml' conversion.+-- This is @r@ type variable in 'Bijection' data type.+type Env = ExceptT EncodeException (Reader TOML)++-- | Write exception for convertion to 'Toml' from user custom data type.+data DecodeException+ = DuplicateKey Key AnyValue -- ^ Key is already in table for some value+ deriving (Eq, Show) -- TODO: manual pretty show instances++-- | Mutable context for 'Toml' conversion.+-- This is @w@ type variable in 'Bijection' data type.+type St = ExceptT DecodeException (State TOML)++-- | Specialied for 'Toml' monad.+type BiToml a = Bi Env St a++-- | Convert textual representation of toml into user data type.+encode :: BiToml a -> Text -> Either EncodeException a+encode biToml text = do+ toml <- first ParseError (parse text)+ runReader (runExceptT $ biRead biToml) toml++-- | Convert object to textual representation.+decode :: BiToml a -> a -> Either DecodeException Text+decode biToml obj = do+ -- this pair has type (TOML, Either DecodeException a)+ let (result, toml) = runState (runExceptT $ biWrite biToml obj) (TOML mempty mempty)++ -- just to trigger error if Left+ _ <- result++ pure $ prettyToml toml++fromRight :: b -> Either a b -> b+fromRight b (Left _) = b+fromRight _ (Right b) = b++-- | Unsafe version of 'decode' function if you're sure that you decoding+-- of structure is correct.+unsafeDecode :: BiToml a -> a -> Text+unsafeDecode biToml text = fromRight (error "Unsafe decode") $ decode biToml text++-- | General function to create bidirectional converters for values.+bijectionMaker :: forall a t .+ Text -- ^ Name of expected type+ -> (forall f . Value f -> Maybe a) -- ^ How to convert from 'AnyValue' to @a@+ -> (a -> Value t) -- ^ Convert @a@ to 'Anyvale'+ -> Key -- ^ Key of the value+ -> BiToml a+bijectionMaker typeTag fromVal toVal key = Bijection input output+ where+ input :: Env a+ input = do+ mVal <- asks $ HashMap.lookup key . tomlPairs+ case mVal of+ Nothing -> throwError $ KeyNotFound key+ Just (AnyValue val) -> case fromVal val of+ Just v -> pure v+ Nothing -> throwError $ TypeMismatch typeTag++ output :: a -> St a+ output a = do+ let val = AnyValue (toVal a)+ mVal <- gets $ HashMap.lookup key . tomlPairs+ case mVal of+ Nothing -> a <$ modify (\(TOML vals nested) -> TOML (HashMap.insert key val vals) nested)+ Just _ -> throwError $ DuplicateKey key val++-- | Parser for boolean values.+bool :: Key -> BiToml Bool+bool = bijectionMaker "Boolean" fromBool Bool+ where+ fromBool :: Value f -> Maybe Bool+ fromBool (Bool b) = Just b+ fromBool _ = Nothing++-- | Parser for integer values.+int :: Key -> BiToml Int+int = bijectionMaker "Int" fromInt (Int . toInteger)+ where+ fromInt :: Value f -> Maybe Int+ fromInt (Int n) = Just (fromIntegral n)+ fromInt _ = Nothing++-- | Parser for floating values.+double :: Key -> BiToml Double+double = bijectionMaker "Double" fromDouble Float+ where+ fromDouble :: Value f -> Maybe Double+ fromDouble (Float f) = Just f+ fromDouble _ = Nothing++-- | Parser for string values.+str :: Key -> BiToml Text+str = bijectionMaker "String" fromString String+ where+ fromString :: Value f -> Maybe Text+ fromString (String s) = Just s+ fromString _ = Nothing
+ src/Toml/Bi/Monad.hs view
@@ -0,0 +1,87 @@+-- | Contains general underlying monad for bidirectional TOML converion.++module Toml.Bi.Monad+ ( Bijection (..)+ , Bi+ , (.=)+ ) where++{- | Monad for bidirectional Toml conversion. Contains pair of functions:++1. How to read value of type @a@ from immutable environment context @r@?+2. How to store value of type @a@ in stateful context @w@?++In practice instead of @r@ we will use some @Reader Toml@ and instead of @w@ we will+use @State Toml@. This approach with the bunch of utility functions allows to+have single description for from/to 'Toml' conversion.++In practice this type will always be used in the following way:++@+type 'Bi' r w a = 'Bijection' r w a a+@++Type parameter @c@ if fictional. Here some trick is used. This trick is+implemented in [codec](http://hackage.haskell.org/package/codec) and+described in more details in [related blog post](https://blog.poisson.chat/posts/2016-10-12-bidirectional-serialization.html).++-}+data Bijection r w c a = Bijection+ { -- | Extract value of type @a@ from monadic context @r@.+ biRead :: r a++ -- | Store value of type @c@ inside monadic context @w@ and returning+ -- value of type @a@. Type of this function actually should be @a -> w ()@ but with+ -- such type it's impossible to have 'Monad' and other instances.+ , biWrite :: c -> w a+ }++-- | Specialized version of 'Bijection' data type. This type alias is used in practice.+type Bi r w a = Bijection r w a a++instance (Functor r, Functor w) => Functor (Bijection r w c) where+ fmap :: (a -> b) -> Bijection r w c a -> Bijection r w c b+ fmap f bi = Bijection+ { biRead = f <$> biRead bi+ , biWrite = fmap f . biWrite bi+ }++instance (Applicative r, Applicative w) => Applicative (Bijection r w c) where+ pure :: a -> Bijection r w c a+ pure a = Bijection+ { biRead = pure a+ , biWrite = \_ -> pure a+ }++ (<*>) :: Bijection r w c (a -> b) -> Bijection r w c a -> Bijection r w c b+ bif <*> bia = Bijection+ { biRead = biRead bif <*> biRead bia+ , biWrite = \c -> biWrite bif c <*> biWrite bia c+ }++instance (Monad r, Monad w) => Monad (Bijection r w c) where+ (>>=) :: Bijection r w c a -> (a -> Bijection r w c b) -> Bijection r w c b+ bi >>= f = Bijection+ { biRead = biRead bi >>= \a -> biRead (f a)+ , biWrite = \c -> biWrite bi c >>= \a -> biWrite (f a) c+ }++{- | Operator to connect two operations:++1. How to get field from object?+2. How to write this field to toml?++In code this should be used like this:++@+data Foo = Foo { fooBar :: Int, fooBaz :: String }++foo :: BiToml Foo+foo = Foo+ <$> int "bar" .= fooBar+ <*> str "baz" .= fooBaz+@+-}+infixl 5 .=+(.=) :: Bijection r w field a -> (object -> field) -> Bijection r w object a+bijection .= getter = bijection { biWrite = biWrite bijection . getter }
+ src/Toml/Parser.hs view
@@ -0,0 +1,149 @@+{- | Parser of TOML language. Implemented with the help of @megaparsec@ package. -}++module Toml.Parser+ ( ParseException (..)+ , parse+ ) where++-- I hate default Prelude... Do I really need to import all this stuff manually?..+import Control.Applicative (Alternative (..))+import Control.Applicative.Combinators (between, manyTill, sepBy)+import Control.Monad (void)+import Data.Semigroup ((<>))+import Data.Text (Text)+import Data.Void (Void)+import Text.Megaparsec (Parsec, parseErrorPretty', try)+import Text.Megaparsec.Char (alphaNumChar, anyChar, char, space, space1)++import Toml.PrefixTree (Key (..), Piece (..), fromList)+import Toml.Type (AnyValue, TOML (..), UValue (..), typeCheck)++import qualified Control.Applicative.Combinators.NonEmpty as NC+import qualified Data.HashMap.Lazy as HashMap+import qualified Data.Text as Text+import qualified Text.Megaparsec as Mega (parse)+import qualified Text.Megaparsec.Char.Lexer as L++----------------------------------------------------------------------------+-- Library for parsing (boilerplate copy-pasted from megaparsec tutorial)+----------------------------------------------------------------------------++type Parser = Parsec Void Text++-- space consumer+sc :: Parser ()+sc = L.space space1 lineComment blockComment+ where+ lineComment = L.skipLineComment "#"+ blockComment = empty++-- wrapper for consuming spaces after every lexeme (not before it!)+lexeme :: Parser a -> Parser a+lexeme = L.lexeme sc++-- parser for "fixed" string+text :: Text -> Parser Text+text = L.symbol sc++text_ :: Text -> Parser ()+text_ = void . text++integer :: Parser Integer+integer = L.signed sc (lexeme L.decimal)++float :: Parser Double+float = L.signed sc $ lexeme L.float++----------------------------------------------------------------------------+-- TOML parser+----------------------------------------------------------------------------++-- Keys++bareKeyP :: Parser Text+bareKeyP = lexeme $ Text.pack <$> bareStrP+ where+ bareStrP :: Parser String+ bareStrP = some $ alphaNumChar <|> char '_' <|> char '-'++stringP :: Parser Text+stringP = lexeme $ Text.pack <$> (char '"' *> anyChar `manyTill` char '"')++-- adds " to both sides+quote :: Text -> Text+quote t = "\"" <> t <> "\""++keyComponentP :: Parser Piece+keyComponentP = Piece <$> (bareKeyP <|> (quote <$> stringP))++keyP :: Parser Key+keyP = Key <$> NC.sepBy1 keyComponentP (char '.')++tableNameP :: Parser Key+tableNameP = lexeme $ between (char '[') (char ']') keyP++-- Values++boolP :: Parser Bool+boolP = False <$ text "false"+ <|> True <$ text "true"++-- dateTimeP :: Parser DateTime+-- dateTimeP = error "Not implemented!"++arrayP :: Parser [UValue]+arrayP = lexeme $ between (char '[') (char ']') (valueP `sepBy` spComma)+ where+ spComma :: Parser ()+ spComma = char ',' *> space++valueP :: Parser UValue+valueP = UBool <$> boolP+ <|> UFloat <$> try float+ <|> UInt <$> integer+ <|> UString <$> stringP+-- <|> UDate <$> dateTimeP+ <|> UArray <$> arrayP++-- TOML++keyValP :: Parser (Key, AnyValue)+keyValP = do+ k <- keyP+ text_ "="+ uval <- valueP+ case typeCheck uval of+ Nothing -> fail "Can't type check value!"+ Just v -> pure (k, v)++tableHeaderP :: Parser (Key, TOML)+tableHeaderP = do+ k <- tableNameP+ toml <- makeToml <$> many keyValP+ pure (k, toml)+ where+ makeToml :: [(Key, AnyValue)] -> TOML+ makeToml kv = TOML (HashMap.fromList kv) mempty++tomlP :: Parser TOML+tomlP = do+ sc+ kvs <- many keyValP+ tables <- many tableHeaderP+ pure TOML { tomlPairs = HashMap.fromList kvs+ , tomlTables = fromList tables+ }++---------------------------------------------------------------------------+-- Exposed API+----------------------------------------------------------------------------++-- | Pretty parse exception for parsing toml.+newtype ParseException = ParseException Text+ deriving (Show, Eq)++-- | Parses 'Text' as 'TOML' object.+parse :: Text -> Either ParseException TOML+parse t = case Mega.parse tomlP "" t of+ Left err -> Left $ ParseException $ Text.pack $ parseErrorPretty' t err+ Right toml -> Right toml
+ src/Toml/PrefixTree.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++module Toml.PrefixTree+ ( PrefixTree (..)+ , singleT+ , insertT+ , lookupT++ , PrefixMap+ , single+ , insert+ , lookup+ , fromList++ -- * Types+ , Piece (..)+ , Key (..)+ , pattern (:||)+ , Prefix+ , KeysDiff (..)+ ) where++import Prelude hiding (lookup)++import Control.Arrow ((&&&))+import Data.Foldable (foldl')+import Data.Hashable (Hashable)+import Data.HashMap.Strict (HashMap)+import Data.List.NonEmpty (NonEmpty (..))+import Data.String (IsString)+import Data.Text (Text)+import GHC.Generics (Generic)++import qualified Data.HashMap.Strict as HashMap+import qualified Data.List.NonEmpty as NonEmpty++-- | Represents the key piece of some layer.+newtype Piece = Piece { unPiece :: Text }+ deriving (Show, Eq, Ord, Hashable, IsString)++{- | Key of value in @key = val@ pair. Represents as non-empty list of key+components -- 'Piece's. Key like++@+site."google.com"+@++is represented like++@+Key (Piece "site" :| [Piece "\\"google.com\\""])+@++-}+newtype Key = Key { unKey :: NonEmpty Piece }+ deriving (Show, Eq, Ord, Generic)++instance Hashable Key++pattern (:||) :: Piece -> [Piece] -> Key+pattern x :|| xs <- ((NonEmpty.head &&& NonEmpty.tail) . unKey -> (x, xs))+ where+ x :|| xs = Key $ x :| xs++{-# COMPLETE (:||) #-}++-- | Type synonym for 'Key'.+type Prefix = Key++-- | Map of layer names and corresponding 'PrefixTree's.+type PrefixMap a = HashMap Piece (PrefixTree a)++-- | Data structure to represent table tree for @toml@.+data PrefixTree a+ = Leaf !Key !a+ | Branch { bCommonPref :: !Prefix -- ^ greatest common prefix+ , bVal :: !(Maybe a) -- ^ value by key = prefix+ , bPrefixMap :: !(PrefixMap a) -- ^ suffixes of prefix+ }+ deriving (Show, Eq)++data KeysDiff+ -- | Keys are equal+ = Equal+ -- | Keys don't have any common part.+ | NoPrefix+ -- | The first key is the prefix for the second one.+ | FstIsPref { diff :: !Key}+ -- | The second key is the prefix for the first one.+ | SndIsPref { diff :: !Key}+ -- | Key have same prefix.+ | Diff { pref :: !Key+ , diffFst :: !Key+ , diffSnd :: !Key+ }+ deriving (Show, Eq)++keysDiff :: Key -> Key -> KeysDiff+keysDiff (x :|| xs) (y :|| ys)+ | x == y = listSame xs ys []+ | otherwise = NoPrefix+ where+ listSame :: [Piece] -> [Piece] -> [Piece] -> KeysDiff+ listSame [] [] _ = Equal+ listSame [] (s:ss) _ = FstIsPref $ s :|| ss+ listSame (f:fs) [] _ = SndIsPref $ f :|| fs+ listSame (f:fs) (s:ss) pr =+ if f == s+ then listSame fs ss (pr ++ [f])+ else Diff (x :|| pr) (f :|| fs) (s :|| ss)++-- | Creates a 'PrefixTree' of one key-value element.+singleT :: Key -> a -> PrefixTree a+singleT = Leaf++-- | Creates a 'PrefixMap' of one key-value element.+single :: Key -> a -> PrefixMap a+single k@(p :|| _) = HashMap.singleton p . singleT k++-- | Inserts key-value element into the given 'PrefixTree'.+insertT :: Key -> a -> PrefixTree a -> PrefixTree a+insertT newK newV (Leaf k v) =+ case keysDiff k newK of+ Equal -> Leaf k newV+ NoPrefix -> error "Algorithm error: can't be equal prefixes in insertT:Leaf case"+ FstIsPref rK -> Branch k (Just v) $ single rK newV+ SndIsPref lK -> Branch newK (Just newV) $ single lK v+ Diff p k1@(f :|| _) k2@(s :|| _) ->+ Branch p Nothing $ HashMap.fromList [(f, Leaf k1 v), (s, Leaf k2 newV)]+insertT newK newV (Branch pref mv prefMap) =+ case keysDiff pref newK of+ Equal -> Branch pref (Just newV) prefMap+ NoPrefix -> error "Algorithm error: can't be equal prefixes in insertT:Branch case"+ FstIsPref rK -> Branch pref mv $ insert rK newV prefMap+ SndIsPref lK@(piece :|| _) ->+ Branch newK (Just newV) $ HashMap.singleton piece (Branch lK mv prefMap)+ Diff p k1@(f :|| _) k2@(s :|| _) ->+ Branch p Nothing $ HashMap.fromList [ (f, Branch k1 mv prefMap)+ , (s, Leaf k2 newV)+ ]++-- | Inserts key-value element into the given 'PrefixMap'.+insert :: Key -> a -> PrefixMap a -> PrefixMap a+insert k@(p :|| _) v prefMap = case HashMap.lookup p prefMap of+ Just tree -> HashMap.insert p (insertT k v tree) prefMap+ Nothing -> HashMap.insert p (singleT k v) prefMap++-- | Looks up the value at a key in the 'PrefixTree'.+lookupT :: Key -> PrefixTree a -> Maybe a+lookupT lk (Leaf k v) = if lk == k then Just v else Nothing+lookupT lk (Branch pref mv prefMap) =+ case keysDiff pref lk of+ Equal -> mv+ NoPrefix -> Nothing+ Diff _ _ _ -> Nothing+ SndIsPref _ -> Nothing+ FstIsPref k -> lookup k prefMap++-- | Looks up the value at a key in the 'PrefixMap'.+lookup :: Key -> PrefixMap a -> Maybe a+lookup k@(p :|| _) prefMap = HashMap.lookup p prefMap >>= lookupT k++-- | Constructs 'PrettyMap' structure from the given list of 'Key' and value pairs.+fromList :: [(Key, a)] -> PrefixMap a+fromList = foldl' insertPair mempty+ where+ insertPair :: PrefixMap a -> (Key, a) -> PrefixMap a+ insertPair prefMap (k, v) = insert k v prefMap
+ src/Toml/Printer.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE TypeFamilies #-}++{- | Contains functions for pretty printing @toml@ types. -}++module Toml.Printer+ ( prettyToml+ , prettyTomlInd+ ) where++import Data.HashMap.Strict (HashMap)+import Data.Monoid ((<>))+import Data.Text (Text)++import Toml.PrefixTree (Key (..), Piece (..), PrefixMap, PrefixTree (..))+import Toml.Type (AnyValue (..), DateTime (..), TOML (..), Value (..))++import qualified Data.HashMap.Strict as HashMap+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Text as Text++-- Tab is equal to 2 spaces now.+tab :: Int -> Text+tab n = Text.cons '\n' (Text.replicate (2*n) " ")++{- | Converts 'TOML' type into 'Text'.++For example, this++@+TOML+ { tomlPairs = HashMap.fromList [(Key "title", String "TOML example")]+ , tomlTables = HashMap.fromList+ [( TableId (NonEmpty.fromList ["example", "owner"])+ , TOML+ { tomlPairs = HashMap.fromList [(Key "name", String "Kowainik")]+ , tomlTables = mempty+ , tomlTableArrays = mempty+ }+ )]+ , tomlTableArrays = mempty+ }+@++will be translated to this++@+title = "TOML Example"++[example.owner]+ name = "Kowainik"++@+-}+prettyToml :: TOML -> Text+prettyToml = Text.drop 1 . prettyTomlInd 0 ""++-- | Converts 'TOML' into 'Text' with the given indent.+prettyTomlInd :: Int -- ^ Number of spaces for indentation+ -> Text -- ^ Accumulator for table names+ -> TOML -- ^ Given 'TOML'+ -> Text -- ^ Pretty result+prettyTomlInd i prefix TOML{..} = prettyKeyValue i tomlPairs <> "\n"+ <> prettyTables i prefix tomlTables++-- | Returns pretty formatted key-value pairs of the 'TOML'.+prettyKeyValue :: Int -> HashMap Key AnyValue -> Text+prettyKeyValue i = Text.concat . map kvText . HashMap.toList+ where+ kvText :: (Key, AnyValue) -> Text+ kvText (k, AnyValue v) = tab i <> prettyKey k <> " = " <> valText v++ valText :: Value t -> Text+ valText (Bool b) = Text.toLower $ showText b+ valText (Int n) = showText n+ valText (Float d) = showText d+ valText (String s) = showText s+ valText (Date d) = timeText d+ valText (Array a) = "[" <> Text.intercalate ", " (map valText a) <> "]"++ timeText :: DateTime -> Text+ timeText (Zoned z) = showText z+ timeText (Local l) = showText l+ timeText (Day d) = showText d+ timeText (Hours h) = showText h++ showText :: Show a => a -> Text+ showText = Text.pack . show++-- | Returns pretty formatted tables section of the 'TOML'.+prettyTables :: Int -> Text -> PrefixMap TOML -> Text+prettyTables i pref = Text.concat . map prettyTable . HashMap.elems+ where+ prettyTable :: PrefixTree TOML -> Text+ prettyTable (Leaf k toml) =+ let name = getPref k in+ tab i <> prettyTableName name+ <> prettyTomlInd (succ i) name toml+ prettyTable (Branch k mToml prefMap) =+ let name = getPref k+ nextI = succ i+ toml = case mToml of+ Nothing -> ""+ Just t -> prettyTomlInd nextI name t+ in tab i <> prettyTableName name <> toml <> prettyTables nextI name prefMap++ -- Adds next part of the table name to the accumulator.+ getPref :: Key -> Text+ getPref k = case pref of+ "" -> prettyKey k+ _ -> pref <> "." <> prettyKey k++ prettyTableName :: Text -> Text+ prettyTableName n = "[" <> n <> "]"++prettyKey :: Key -> Text+prettyKey (Key k) = Text.intercalate "." $ map unPiece (NonEmpty.toList k)
+ src/Toml/Type.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}++{- | Contains specification of TOML via Haskell ADT. -}++module Toml.Type+ ( TOML (..)+ , UValue (..)+ , ValueType (..)+ , Value (..)+ , AnyValue (..)+ , DateTime (..)+ , typeCheck+ ) where++import Data.HashMap.Strict (HashMap)+import Data.Text (Text)+import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime, zonedTimeToUTC)+import Data.Type.Equality ((:~:) (..))++import Toml.PrefixTree (Key (..), PrefixMap)++-- TODO: describe how some TOML document will look like with this type+{- | Represents TOML configuration value. -}+data TOML = TOML+ { tomlPairs :: HashMap Key AnyValue+ , tomlTables :: PrefixMap TOML+ -- tomlTableArrays :: HashMap Key (NonEmpty TOML)+ } deriving (Show, Eq)++-- Needed for GADT parameterization+data ValueType = TBool | TInt | TFloat | TString | TDate | TArray++-- TODO: examples are copy-pasted from TOML specification. Probably most of them+-- will be moved into parsing module in future.+-- | Value in @key = value@ pair.+data Value (t :: ValueType) where+ {- | Boolean value:++@+bool1 = true+bool2 = false+@+ -}+ Bool :: Bool -> Value 'TBool++ {- | Integer value:++@+int1 = +99+int2 = 42+int3 = 0+int4 = -17+int5 = 5_349_221+hex1 = 0xDEADBEEF+oct2 = 0o755 # useful for Unix file permissions+bin1 = 0b11010110+@+ -}+ Int :: Integer -> Value 'TInt++ {- | Floating point number:++@+flt1 = -3.1415 # fractional+flt2 = 1e6 # exponent+flt3 = 6.626e-34 # both+flt4 = 9_224_617.445_991_228_313+@+ -}+ Float :: Double -> Value 'TFloat++ {- | String value:++@+key = "value"+bare_key = "value"+bare-key = "value"+@+ -}+ String :: Text -> Value 'TString++ -- | Date-time. See documentation for 'DateTime' type.+ Date :: DateTime -> Value 'TDate++ {- | Array of values. According to TOML specification all values in array+ should have the same type. This is guaranteed statically with this type.++@+arr1 = [ 1, 2, 3 ]+arr2 = [ "red", "yellow", "green" ]+arr3 = [ [ 1, 2 ], [3, 4, 5] ]+arr4 = [ "all", 'strings', """are the same""", '''type''']+arr5 = [ [ 1, 2 ], ["a", "b", "c"] ]++arr6 = [ 1, 2.0 ] # INVALID+@+ -}+ Array :: [Value t] -> Value 'TArray++deriving instance Show (Value t)+instance Eq (Value t) where+ (Bool b1) == (Bool b2) = b1 == b2+ (Int i1) == (Int i2) = i1 == i2+ (Float f1) == (Float f2) = f1 == f2+ (String s1) == (String s2) = s1 == s2+ (Date d1) == (Date d2) = d1 == d2+ (Array a1) == (Array a2) = eqValueList a1 a2++eqValueList :: [Value a] -> [Value b] -> Bool+eqValueList [] [] = True+eqValueList (x:xs) (y:ys) = case sameValue x y of+ Just Refl -> x == y && eqValueList xs ys+ Nothing -> False+eqValueList _ _ = False+++-- TODO: move into Toml.Type.Internal module then?.. But it uses 'DateTime' which is not internal...+-- | Untyped value of 'TOML'. You shouldn't use this type in your code. Use+-- 'Value' instead.+data UValue+ = UBool !Bool+ | UInt !Integer+ | UFloat !Double+ | UString !Text+ | UDate !DateTime+ | UArray ![UValue]++-- | Existential wrapper for 'Value'.+data AnyValue = forall (t :: ValueType) . AnyValue (Value t)++instance Show AnyValue where+ show (AnyValue v) = show v++instance Eq AnyValue where+ (AnyValue (Bool b1)) == (AnyValue (Bool b2)) = b1 == b2+ (AnyValue (Int i1)) == (AnyValue (Int i2)) = i1 == i2+ (AnyValue (Float f1)) == (AnyValue (Float f2)) = f1 == f2+ (AnyValue (String s1)) == (AnyValue (String s2)) = s1 == s2+ (AnyValue (Date d1)) == (AnyValue (Date d2)) = d1 == d2+ (AnyValue (Array a1)) == (AnyValue (Array a2)) = eqValueList a1 a2+ _ == _ = False+++data DateTime+ {- | Offset date-time:++@+odt1 = 1979-05-27T07:32:00Z+odt2 = 1979-05-27T00:32:00-07:00+@+ -}+ = Zoned !ZonedTime++ {- | Local date-time (without offset):++@+ldt1 = 1979-05-27T07:32:00+ldt2 = 1979-05-27T00:32:00.999999+@+ -}+ | Local !LocalTime++ {- | Local date (only day):++@+ld1 = 1979-05-27+@+ -}+ | Day !Day++ {- | Local time (time of the day):++@+lt1 = 07:32:00+lt2 = 00:32:00.999999++@+ -}+ | Hours !TimeOfDay+ deriving (Show)++instance Eq DateTime where+ (Zoned a) == (Zoned b) = zonedTimeToUTC a == zonedTimeToUTC b+ (Local a) == (Local b) = a == b+ (Day a) == (Day b) = a == b+ (Hours a) == (Hours b) = a == b+ _ == _ = False+++-- | Ensures that 'UValue's represents type-safe version of @toml@.+typeCheck :: UValue -> Maybe AnyValue+typeCheck (UBool b) = justAny $ Bool b+typeCheck (UInt n) = justAny $ Int n+typeCheck (UFloat f) = justAny $ Float f+typeCheck (UString s) = justAny $ String s+typeCheck (UDate d) = justAny $ Date d+typeCheck (UArray a) = case a of+ [] -> justAny $ Array []+ (x:xs) -> do+ AnyValue v <- typeCheck x+ AnyValue . Array <$> checkElem v xs+ where+ checkElem :: Value t -> [UValue] -> Maybe [Value t]+ checkElem v [] = Just [v]+ checkElem v (x:xs) = do+ AnyValue vx <- typeCheck x+ Refl <- sameValue v vx+ (v :) <$> checkElem vx xs++justAny :: Value t -> Maybe AnyValue+justAny = Just . AnyValue++sameValue :: Value a -> Value b -> Maybe (a :~: b)+sameValue Bool{} Bool{} = Just Refl+sameValue Int{} Int{} = Just Refl+sameValue Float{} Float{} = Just Refl+sameValue String{} String{} = Just Refl+sameValue Date{} Date{} = Just Refl+sameValue Array{} Array{} = Just Refl+sameValue _ _ = Nothing
+ test/Spec.hs view
@@ -0,0 +1,11 @@+module Main where++import Test.Tasty (defaultMain, testGroup)++import Test.Toml.Parsing (parsingTests)+import Test.Toml.PrefixTree (prefixTreeTests)++main :: IO ()+main = do+ prefixTreeTest <- prefixTreeTests+ defaultMain $ testGroup "Tomland tests" [parsingTests, prefixTreeTest]
+ test/Test/Toml/Gen.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | This module contains all generators for @tomland@ testing.++module Test.Toml.Gen+ ( genVal+ , genKey+ , genPrefixMap+ , genToml+ ) where++import Control.Applicative (liftA2)+import Control.Monad (forM)++import Hedgehog (MonadGen)++import Toml.PrefixTree (pattern (:||), Key (..), Piece (..), PrefixMap, PrefixTree (..), fromList)+import Toml.Type (AnyValue (..), TOML (..), Value (..))++import qualified Data.HashMap.Strict as HashMap+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++----------------------------------------------------------------------------+-- Common generators+----------------------------------------------------------------------------++type V = Int++genVal :: MonadGen m => m V+genVal = Gen.int (Range.constant 0 256)++-- TODO: Arrays and Date.+-- | Generates random value of 'AnyValue' type.+genAnyValue :: MonadGen m => m AnyValue+genAnyValue = do+ let randB = Gen.bool+ let randI = toInteger <$> Gen.int (Range.constantBounded @Int)+ let randF = Gen.double $ Range.constant @Double (-1000000.0) 1000000.0+ let randS = Gen.text (Range.constant 0 256) Gen.alphaNum+ Gen.choice+ [ AnyValue . Bool <$> randB+ , AnyValue . Int <$> randI+ , AnyValue . Float <$> randF+ , AnyValue . String <$> randS+ ]++-- TODO: unicode support+genPiece :: MonadGen m => m Piece+genPiece = Piece <$> Gen.text (Range.constant 1 50) Gen.alphaNum++genKey :: MonadGen m => m Key+genKey = Key <$> Gen.nonEmpty (Range.constant 1 10) genPiece++genKeyAnyValue :: MonadGen m => m (Key, AnyValue)+genKeyAnyValue = liftA2 (,) genKey genAnyValue++genKeyAnyValueList :: MonadGen m => m [(Key, AnyValue)]+genKeyAnyValueList = Gen.list (Range.linear 0 10) genKeyAnyValue++-- Generates key-value pair for PrefixMap+genEntry :: MonadGen m => m (Piece, Key)+genEntry = do+ key@(piece :|| _) <- genKey+ pure (piece, key)++genPrefixMap :: MonadGen m => m (PrefixMap V)+genPrefixMap = do+ entries <- Gen.list (Range.linear 0 10) genEntry+ kvps <- forM entries $ \(piece, key) -> do+ tree <- genPrefixTree key+ pure (piece, tree)++ pure $ HashMap.fromList kvps++genPrefixTree :: forall m . MonadGen m => Key -> m (PrefixTree V)+genPrefixTree key = Gen.recursive+ -- list picker generator combinator+ Gen.choice+ -- non-recursive generators+ [ Leaf key <$> genVal ]+ -- recursive generators+ [ genPrefixMap >>= genBranch ]+ where+ genBranch :: PrefixMap V -> m (PrefixTree V)+ genBranch prefMap = do+ prefVal <- Gen.maybe genVal+ pure $ Branch key prefVal prefMap++genTableHeader :: MonadGen m => m (Key, TOML)+genTableHeader = do+ k <- genKey+ toml <- makeToml <$> genKeyAnyValueList+ pure (k, toml)+ where+ makeToml :: [(Key, AnyValue)] -> TOML+ makeToml kv = TOML (HashMap.fromList kv) mempty++genToml :: MonadGen m => m TOML+genToml = do+ kv <- HashMap.fromList <$> genKeyAnyValueList+ tables <- Gen.list (Range.linear 0 10) genTableHeader+ pure $ TOML kv (fromList tables)
+ test/Test/Toml/Parsing.hs view
@@ -0,0 +1,10 @@+module Test.Toml.Parsing+ ( parsingTests+ ) where++import Test.Tasty (TestTree, testGroup)++import Test.Toml.Parsing.Property (propertyTests)++parsingTests :: TestTree+parsingTests = testGroup "Parsing tests" propertyTests
+ test/Test/Toml/Parsing/Property.hs view
@@ -0,0 +1,20 @@+module Test.Toml.Parsing.Property+ ( propertyTests+ ) where++import Hedgehog (Property, forAll, property, (===))+import Test.Tasty (TestTree)+import Test.Tasty.Hedgehog (testProperty)++import Toml.Parser (parse)+import Toml.Printer (prettyToml)++import Test.Toml.Gen (genToml)++propertyTests :: [TestTree]+propertyTests = [ testProperty "parse . prettyPrint == id" prop_parsePrint ]++prop_parsePrint :: Property+prop_parsePrint = property $ do+ toml <- forAll genToml+ parse (prettyToml toml) === Right toml
+ test/Test/Toml/PrefixTree.hs view
@@ -0,0 +1,13 @@+module Test.Toml.PrefixTree+ ( prefixTreeTests+ ) where++import Test.Tasty (TestTree, testGroup)++import Test.Toml.PrefixTree.Property (propertyTests)+import Test.Toml.PrefixTree.Unit (unitTests)++prefixTreeTests :: IO TestTree+prefixTreeTests = do+ uTests <- unitTests+ pure $ testGroup "Prefix Tree tests" $ uTests : propertyTests
+ test/Test/Toml/PrefixTree/Property.hs view
@@ -0,0 +1,59 @@+module Test.Toml.PrefixTree.Property+ ( propertyTests+ ) where++import Hedgehog (Property, forAll, property, (===))+import Test.Tasty (TestTree)+import Test.Tasty.Hedgehog (testProperty)++import Test.Toml.Gen (genKey, genPrefixMap, genVal)++import qualified Toml.PrefixTree as Prefix++propertyTests :: [TestTree]+propertyTests =+ [ testProperty "lookup k (insert k v m) == Just v" prop_InsertLookup+ , testProperty "insert x a . insert x b == insert x a" prop_InsertInsert+ ]++----------------------------------------------------------------------------+-- InsertLookup+----------------------------------------------------------------------------++prop_InsertLookup :: Property+prop_InsertLookup = property $ do+ t <- forAll genPrefixMap+ key <- forAll genKey+ val <- forAll genVal++ Prefix.lookup key (Prefix.insert key val t) === Just val++ -- DEBUG: ensures that trees of depth at least 5 are generated+ -- assert $ depth prefMap < 5++----------------------------------------------------------------------------+-- InsertInsert+----------------------------------------------------------------------------++prop_InsertInsert :: Property+prop_InsertInsert = property $ do+ t <- forAll genPrefixMap+ x <- forAll genKey+ a <- forAll genVal+ b <- forAll genVal++ Prefix.lookup x (Prefix.insert x a $ Prefix.insert x b t) === Just a++----------------------------------------------------------------------------+-- DEBUG+----------------------------------------------------------------------------++-- useful functions to test generators+-- TODO: commented to avoid warnings++-- depth :: PrefixMap a -> Int+-- depth = HashMap.foldl' (\acc t -> max acc (depthT t)) 0+--+-- depthT :: PrefixTree a -> Int+-- depthT (Leaf _ _) = 1+-- depthT (Branch _ _ prefMap) = 1 + depth prefMap
+ test/Test/Toml/PrefixTree/Unit.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeApplications #-}++module Test.Toml.PrefixTree.Unit+ ( unitTests+ ) where++import Test.Tasty (TestTree)+import Test.Tasty.Hspec (Spec, describe, it, shouldBe, testSpec)++import Toml.PrefixTree (pattern (:||))++import qualified Toml.PrefixTree as Prefix++unitTests :: IO TestTree+unitTests = testSpec "PrefixTree unit tests" spec_PrefixTree++spec_PrefixTree :: Spec+spec_PrefixTree = do+ -- some test keys+ let a = "a" :|| []+ let b = "b" :|| []+ let c = "c" :|| []+ let ab = "a" :|| ["b"]++ describe "Insert and lookup unit tests" $ do+ it "Lookup on empty map returns Nothing" $+ Prefix.lookup @Bool a mempty `shouldBe` Nothing+ it "Lookup in single map returns this element" $ do+ let t = Prefix.single a True+ Prefix.lookup a t `shouldBe` Just True+ Prefix.lookup b t `shouldBe` Nothing+ it "Lookup after insert returns this element" $ do+ let t = Prefix.insert a True mempty+ Prefix.lookup a t `shouldBe` Just True+ Prefix.lookup b t `shouldBe` Nothing+ it "Lookup after multiple non-overlapping inserts" $ do+ let t = Prefix.insert a True $ Prefix.insert b False mempty+ Prefix.lookup a t `shouldBe` Just True+ Prefix.lookup b t `shouldBe` Just False+ Prefix.lookup c t `shouldBe` Nothing+ it "Prefix lookup" $ do+ let t = Prefix.insert ab True mempty+ Prefix.lookup a t `shouldBe` Nothing+ Prefix.lookup ab t `shouldBe` Just True+ it "Composite key lookup" $ do+ let t = Prefix.insert a True $ Prefix.insert ab False mempty+ Prefix.lookup a t `shouldBe` Just True+ Prefix.lookup ab t `shouldBe` Just False
+ tomland.cabal view
@@ -0,0 +1,90 @@+name: tomland+version: 0.0.0+description: TOML parser+synopsis: TOML parser+homepage: https://github.com/kowainik/tomland+bug-reports: https://github.com/kowainik/tomland/issues+license: MPL-2.0+license-file: LICENSE+author: Kowainik+maintainer: xrom.xkov@gmail.com+copyright: 2018 Kowainik+category: Data, Text, Configuration, TOML+build-type: Simple+extra-doc-files: README.md+cabal-version: 1.24+tested-with: GHC == 8.2.2, GHC == 8.0.2++library+ hs-source-dirs: src++ exposed-modules: Toml+ Toml.Bi+ Toml.Bi.Combinators+ Toml.Bi.Monad+ Toml.Parser+ Toml.PrefixTree+ Toml.Printer+ Toml.Type+++ build-depends: base >= 4.9 && < 5+ , hashable+ , megaparsec+ , mtl+ , parser-combinators+ , text+ , time+ , unordered-containers++ ghc-options: -Wall+ default-language: Haskell2010+ default-extensions: DeriveGeneric+ GeneralizedNewtypeDeriving+ InstanceSigs+ OverloadedStrings+ RecordWildCards++executable play-tomland+ main-is: Playground.hs+ build-depends: base+ , tomland+ , text+ , time+ , unordered-containers++ hs-source-dirs: examples+ default-language: Haskell2010+ ghc-options: -threaded -Wall+ default-extensions: OverloadedStrings+ RecordWildCards++test-suite tomland-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Test.Toml.Gen+ Test.Toml.Parsing+ Test.Toml.Parsing.Property+ Test.Toml.PrefixTree+ Test.Toml.PrefixTree.Property+ Test.Toml.PrefixTree.Unit++ build-depends: base+ , tomland+ , hedgehog+ , tasty+ , tasty-hedgehog+ , tasty-hspec+ , text+ , unordered-containers++ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N++ default-language: Haskell2010+ default-extensions: OverloadedStrings+ RecordWildCards++source-repository head+ type: git+ location: https://github.com/kowainik/tomland.git