tomland 0.2.1 → 0.3
raw patch · 26 files changed
+1110/−521 lines, 26 filesdep +hspec-megaparsecdep ~megaparsec
Dependencies added: hspec-megaparsec
Dependency ranges changed: megaparsec
Files
- CHANGELOG.md +24/−0
- examples/Playground.hs +23/−42
- src/Toml.hs +2/−0
- src/Toml/Bi/Code.hs +4/−4
- src/Toml/Bi/Combinators.hs +20/−60
- src/Toml/Edsl.hs +40/−0
- src/Toml/Parser.hs +45/−20
- src/Toml/PrefixTree.hs +24/−2
- src/Toml/Printer.hs +6/−6
- src/Toml/Prism.hs +103/−0
- src/Toml/Type.hs +8/−299
- src/Toml/Type/AnyValue.hs +81/−0
- src/Toml/Type/TOML.hs +43/−0
- src/Toml/Type/UValue.hs +46/−0
- src/Toml/Type/Value.hs +210/−0
- test/Spec.hs +1/−11
- test/Test/Toml/Gen.hs +25/−9
- test/Test/Toml/Parsing.hs +0/−10
- test/Test/Toml/Parsing/Property.hs +6/−13
- test/Test/Toml/Parsing/Unit.hs +307/−0
- test/Test/Toml/PrefixTree.hs +0/−13
- test/Test/Toml/PrefixTree/Property.hs +18/−17
- test/Test/Toml/PrefixTree/Unit.hs +2/−8
- test/Test/Toml/Property.hs +39/−0
- test/Test/Toml/TOML/Property.hs +15/−0
- tomland.cabal +18/−7
CHANGELOG.md view
@@ -4,6 +4,30 @@ tomland uses [PVP Versioning][1]. The change log is available [on GitHub][2]. +0.3+=====++* [#8](https://github.com/kowainik/tomland/issues/8):+ Create EDSL for easier TOML data type writing.+* [#10](https://github.com/kowainik/tomland/issues/10):+ Add `Semigroup` and `Monoid` instances for `PrefixTree` and `TOML`.+ Add property tests on laws.+* [#20](https://github.com/kowainik/tomland/issues/20):+ Add parsing of hexadecimal, octal, and binary integer numbers.+* [#26](https://github.com/kowainik/tomland/issues/26):+ Implement unit tests for TOML parsers.+ Allow terminating commas inside an array.+ Allow comments before and after any value inside an array.+ Allow keys to be literal strings.+* **Breaking change:** [#60](https://github.com/kowainik/tomland/issues/60):+ Replace `Valuer` with `Prism`.++ _Migration guide:_ replace any `fooV` with corresponding prism `_Foo`.+* **Breaking change:** [#66](https://github.com/kowainik/tomland/issues/66):+ Introduce consistent names according to Haskell types.++ _Migration guide:_ see issue details to know which names to use.+ 0.2.1 ===== * Make `table` parser work with `maybeP`.
examples/Playground.hs view
@@ -4,12 +4,11 @@ import Data.Time (fromGregorian) import Toml.Bi (BiToml, (.=))+import Toml.Edsl (mkToml, table, (=:)) import Toml.Parser (ParseException (..), parse)-import Toml.PrefixTree (PrefixMap, fromList) import Toml.Printer (prettyToml)-import Toml.Type (AnyValue (..), DateTime (..), TOML (..), Value (..))+import Toml.Type (DateTime (..), TOML (..), Value (..)) -import qualified Data.HashMap.Strict as HashMap import qualified Data.Text.IO as TIO import qualified Toml @@ -27,18 +26,18 @@ newtype TestInside = TestInside { unInside :: Text } insideT :: BiToml TestInside-insideT = Toml.dimap unInside TestInside $ Toml.str "inside"+insideT = Toml.dimap unInside TestInside $ Toml.text "inside" testT :: BiToml Test testT = Test- <$> Toml.bool "testB" .= testB- <*> Toml.int "testI" .= testI+ <$> Toml.bool "testB" .= testB+ <*> Toml.int "testI" .= testI <*> Toml.double "testF" .= testF- <*> Toml.str "testS" .= testS- <*> Toml.arrayOf Toml.strV "testA" .= testA- <*> Toml.maybeP Toml.bool "testM" .= testM+ <*> Toml.text "testS" .= testS+ <*> Toml.arrayOf Toml._Text "testA" .= testA+ <*> Toml.maybeT Toml.bool "testM" .= testM <*> Toml.table insideT "testX" .= testX- <*> Toml.maybeP (Toml.table insideT) "testY" .= testY+ <*> Toml.maybeT (Toml.table insideT) "testY" .= testY main :: IO () main = do@@ -58,35 +57,17 @@ Right test -> Toml.encode testT test myToml :: TOML-myToml = TOML (HashMap.fromList- [ ("a" , AnyValue $ Bool True)- , ("list", AnyValue $ Array [String "one", String "two"])- , ("time", AnyValue $ Array [Date $ Day (fromGregorian 2018 3 29)])- ] ) myInnerToml--myInnerToml :: PrefixMap TOML-myInnerToml = fromList- [ ( "table.name.1"- , TOML (HashMap.fromList- [ ("aInner" , AnyValue $ Int 1)- , ("listInner", AnyValue $ Array [Bool True, Bool False])- ]) myInnerInnerToml- )- , ( "table.name.2"- , TOML (HashMap.fromList [("2Inner", AnyValue $ Int 42)]) mempty- )- ]---myInnerInnerToml :: PrefixMap TOML-myInnerInnerToml = fromList- [ ( "table.name.1.1"- , TOML (HashMap.fromList- [ ("aInner" , AnyValue $ Int 1)- , ("listInner", AnyValue $ Array [Bool True, Bool False])- ]) mempty- )- , ( "table.name.1.2"- , TOML (HashMap.fromList [("Inner1.2", AnyValue $ Int 42)]) mempty- )- ]+myToml = mkToml $ do+ "a" =: Bool True+ "list" =: Array ["one", "two"]+ "time" =: Array [Date $ Day (fromGregorian 2018 3 29)]+ table "table.name.1" $ do+ "aInner" =: 1+ "listInner" =: Array [Bool True, Bool False]+ table "1" $ do+ "aInner11" =: 11+ "listInner11" =: Array [0, 1]+ table "2" $+ "Inner12" =: "12"+ table "table.name.2" $+ "Inner2" =: 42
src/Toml.hs view
@@ -11,6 +11,7 @@ , module Toml.Parser , module Toml.PrefixTree , module Toml.Printer+ , module Toml.Prism , module Toml.Type ) where @@ -18,4 +19,5 @@ import Toml.Parser import Toml.PrefixTree import Toml.Printer+import Toml.Prism import Toml.Type
src/Toml/Bi/Code.hs view
@@ -17,15 +17,15 @@ import Control.Monad.Reader (Reader, runReader) import Control.Monad.State (State, execState) import Data.Bifunctor (first)+import Data.Foldable (toList) import Data.Semigroup ((<>)) import Data.Text (Text)-import Data.Foldable (toList) import Toml.Bi.Monad (Bi, Bijection (..)) import Toml.Parser (ParseException (..), parse) import Toml.PrefixTree (Key (..), unPiece) import Toml.Printer (prettyToml)-import Toml.Type (TOML (..), ValueType, showType)+import Toml.Type (TOML (..), TValue, showType) import qualified Data.Text as Text @@ -33,7 +33,7 @@ data DecodeException = KeyNotFound Key -- ^ No such key | TableNotFound Key -- ^ No such table- | TypeMismatch Key Text ValueType -- ^ Expected type vs actual type+ | TypeMismatch Key Text TValue -- ^ Expected type vs actual type | ParseError ParseException -- ^ Exception during parsing deriving (Eq, Show) -- TODO: manual pretty show instances @@ -69,4 +69,4 @@ -- | Convert object to textual representation. encode :: BiToml a -> a -> Text-encode bi obj = prettyToml $ execState (biWrite bi obj) (TOML mempty mempty)+encode bi obj = prettyToml $ execState (biWrite bi obj) mempty
src/Toml/Bi/Combinators.hs view
@@ -19,18 +19,10 @@ , int , integer , double- , str+ , text , arrayOf- , maybeP+ , maybeT , table-- -- * Value parsers- , Valuer (..)- , boolV- , integerV- , doubleV- , strV- , arrV ) where import Control.Monad.Except (MonadError, catchError, throwError)@@ -46,8 +38,9 @@ import Toml.Bi.Monad (Bi, Bijection (..), dimap) import Toml.Parser (ParseException (..)) import Toml.PrefixTree (Key)-import Toml.Type (AnyValue (..), TOML (..), Value (..), ValueType (..), matchArray, matchBool,- matchDouble, matchInteger, matchText, valueType)+import Toml.Prism (Prism (..), match, _Array)+import Toml.Type (AnyValue (..), TOML (..), TValue (..), Value (..), insertKeyVal, insertTable,+ matchBool, matchDouble, matchInteger, matchText, valueType) import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as Text@@ -78,9 +71,7 @@ Nothing -> throwError $ TypeMismatch key (typeName @a) (valueType val) output :: a -> St a- output a = do- let val = AnyValue (toVal a)- a <$ modify (\(TOML vals nested) -> TOML (HashMap.insert key val vals) nested)+ output a = a <$ modify (insertKeyVal key (toVal a)) -- | Helper dimapper to turn 'integer' parser into parser for 'Int', 'Natural', 'Word', etc. dimapNum :: forall n r w . (Integral n, Functor r, Functor w)@@ -126,36 +117,6 @@ } ------------------------------------------------------------------------------- Value parsers--------------------------------------------------------------------------------- | This data type describes how to convert value of type @a@ into and from 'Value'.-data Valuer (tag :: ValueType) a = Valuer- { valFrom :: forall t . Value t -> Maybe a- , valTo :: a -> Value tag- }---- | 'Bool' parser for array element. Use with 'arrayOf' parser.-boolV :: Valuer 'TBool Bool-boolV = Valuer matchBool Bool---- | 'Int' parser for array element. Use with 'arrayOf' parser.-integerV :: Valuer 'TInt Integer-integerV = Valuer matchInteger Int---- | 'Double' parser for array element. Use with 'arrayOf' parser.-doubleV :: Valuer 'TFloat Double-doubleV = Valuer matchDouble Float---- | 'Text' parser for array element. Use with 'arrayOf' parser.-strV :: Valuer 'TString Text-strV = Valuer matchText String---- | Parser for array element which is an array itself. Use with 'arrayOf' parser.-arrV :: forall a t . Valuer t a -> Valuer 'TArray [a]-arrV Valuer{..} = Valuer (matchArray valFrom) (Array . map valTo)------------------------------------------------------------------------------ -- Toml parsers ---------------------------------------------------------------------------- @@ -165,7 +126,7 @@ -- | Parser for integer values. integer :: Key -> BiToml Integer-integer = bijectionMaker matchInteger Int+integer = bijectionMaker matchInteger Integer -- | Parser for integer values. int :: Key -> BiToml Int@@ -173,17 +134,17 @@ -- | Parser for floating values. double :: Key -> BiToml Double-double = bijectionMaker matchDouble Float+double = bijectionMaker matchDouble Double -- | Parser for string values.-str :: Key -> BiToml Text-str = bijectionMaker matchText String+text :: Key -> BiToml Text+text = bijectionMaker matchText Text -- TODO: implement using bijectionMaker -- | Parser for array of values. Takes converter for single array element and -- returns list of values.-arrayOf :: forall a t . Typeable a => Valuer t a -> Key -> BiToml [a]-arrayOf valuer key = Bijection input output+arrayOf :: forall a . Typeable a => Prism AnyValue a -> Key -> BiToml [a]+arrayOf prism key = Bijection input output where input :: Env [a] input = do@@ -191,21 +152,20 @@ case mVal of Nothing -> throwError $ KeyNotFound key Just (AnyValue (Array arr)) -> case arr of- [] -> pure []- x:xs -> case mapM (valFrom valuer) (x:xs) of- Nothing -> throwError $ TypeMismatch key (typeName @a) (valueType x) -- TODO: different error for array element+ [] -> pure []+ l@(x:_) -> case mapM (match prism) l of+ Nothing -> throwError $ TypeMismatch key (typeName @a) (valueType x) Just vals -> pure vals Just _ -> throwError $ TypeMismatch key (typeName @a) TArray output :: [a] -> St [a] output a = do- let val = AnyValue $ Array $ map (valTo valuer) a+ let val = review (_Array prism) a a <$ modify (\(TOML vals tables) -> TOML (HashMap.insert key val vals) tables) --- TODO: maybe conflicts from maybe in Prelude, maybe we should add C or P suffix or something else?... -- | Bidirectional converter for @Maybe smth@ values.-maybeP :: forall a . (Key -> BiToml a) -> Key -> BiToml (Maybe a)-maybeP converter key = let bi = converter key in Bijection+maybeT :: forall a . (Key -> BiToml a) -> Key -> BiToml (Maybe a)+maybeT converter key = let bi = converter key in Bijection { biRead = (Just <$> biRead bi) `catchError` handleNotFound , biWrite = \case Nothing -> pure Nothing@@ -231,9 +191,9 @@ output :: a -> St a output a = do mTable <- gets $ Prefix.lookup key . tomlTables- let toml = fromMaybe (TOML mempty mempty) mTable+ let toml = fromMaybe mempty mTable let newToml = execState (biWrite bi a) toml- a <$ modify (\(TOML vals tables) -> TOML vals (Prefix.insert key newToml tables))+ a <$ modify (insertTable key newToml) handleTableName :: DecodeException -> Env a handleTableName (KeyNotFound name) = throwError $ KeyNotFound (key <> name)
+ src/Toml/Edsl.hs view
@@ -0,0 +1,40 @@+{- | This module introduces EDSL for manually specifying 'TOML' data types.++__Example:__++@+exampleToml :: TOML+exampleToml = mkToml $ do+ "key1" =: 1+ "key2" =: Bool True+ table "tableName" $+ "tableKey" =: Array ["Oh", "Hi", "Mark"]+@++-}++module Toml.Edsl+ ( mkToml+ , (=:)+ , table+ ) where++import Control.Monad.State (State, execState, modify)++import Toml.PrefixTree (Key)+import Toml.Type (TOML (..), Value, insertKeyVal, insertTable)+++type TDSL = State TOML ()++-- | Creates 'TOML' from the 'TDSL'.+mkToml :: TDSL -> TOML+mkToml env = execState env mempty++-- | Adds key-value pair to the 'TDSL'.+(=:) :: Key -> Value a -> TDSL+(=:) k v = modify $ insertKeyVal k v++-- | Adds table to the 'TDSL'.+table :: Key -> TDSL -> TDSL+table k = modify . insertTable k . mkToml
src/Toml/Parser.hs view
@@ -3,17 +3,28 @@ module Toml.Parser ( ParseException (..) , parse+ , arrayP+ , boolP+ , doubleP+ , integerP+ , keyP+ , keyValP+ , textP+ , tableHeaderP+ , tomlP ) 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.Applicative.Combinators (between, manyTill, sepEndBy, skipMany) import Control.Monad (void)+import Data.Char (digitToInt)+import Data.List (foldl') 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 Text.Megaparsec.Char (alphaNumChar, anyChar, char, oneOf, space1) import Toml.PrefixTree (Key (..), Piece (..), fromList) import Toml.Type (AnyValue, TOML (..), UValue (..), typeCheck)@@ -48,11 +59,8 @@ 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+doubleP :: Parser Double+doubleP = L.signed sc $ lexeme L.float ---------------------------------------------------------------------------- -- TOML parser@@ -70,15 +78,18 @@ literalStringP = lexeme $ Text.pack <$> (char '\'' *> anyChar `manyTill` char '\'') -- TODO: this parser is incorrect, it doesn't recognize all strings-stringP :: Parser Text-stringP = lexeme $ Text.pack <$> (char '"' *> anyChar `manyTill` char '"')+basicStringP :: Parser Text+basicStringP = lexeme $ Text.pack <$> (char '"' *> anyChar `manyTill` char '"') --- adds " to both sides-quote :: Text -> Text-quote t = "\"" <> t <> "\""+textP :: Parser Text+textP = literalStringP <|> basicStringP +-- adds " or ' to both sides+quote :: Text -> Text -> Text+quote q t = q <> t <> q+ keyComponentP :: Parser Piece-keyComponentP = Piece <$> (bareKeyP <|> (quote <$> stringP))+keyComponentP = Piece <$> (bareKeyP <|> (quote "\"" <$> basicStringP) <|> (quote "'" <$> literalStringP)) keyP :: Parser Key keyP = Key <$> NC.sepBy1 keyComponentP (char '.')@@ -88,6 +99,17 @@ -- Values +integerP :: Parser Integer+integerP = lexeme $ binary <|> octal <|> hexadecimal <|> decimal+ where+ decimal = L.signed sc L.decimal+ binary = try (char '0' >> char 'b') >> mkNum 2 <$> (some binDigitChar)+ octal = try (char '0' >> char 'o') >> L.octal+ hexadecimal = try (char '0' >> char 'x') >> L.hexadecimal+ binDigitChar = oneOf ['0', '1']+ mkNum b = foldl' (step b) 0+ step b a c = a * b + fromIntegral (digitToInt c)+ boolP :: Parser Bool boolP = False <$ text "false" <|> True <$ text "true"@@ -96,18 +118,21 @@ -- dateTimeP = error "Not implemented!" arrayP :: Parser [UValue]-arrayP = lexeme $ between (char '[' *> space) (char ']') (valueP `sepBy` spComma)+arrayP = lexeme $ between (char '[' *> sc) (char ']') elements where+ elements :: Parser [UValue]+ elements = valueP `sepEndBy` spComma <* skipMany (text ",")+ spComma :: Parser ()- spComma = char ',' *> space+ spComma = char ',' *> sc valueP :: Parser UValue-valueP = UBool <$> boolP- <|> UFloat <$> try float- <|> UInt <$> integer- <|> UString <$> (literalStringP <|> stringP)+valueP = UBool <$> boolP+ <|> UDouble <$> try doubleP+ <|> UInteger <$> integerP+ <|> UText <$> textP -- <|> UDate <$> dateTimeP- <|> UArray <$> arrayP+ <|> UArray <$> arrayP -- TOML
src/Toml/PrefixTree.hs view
@@ -6,12 +6,14 @@ , singleT , insertT , lookupT+ , toListT , PrefixMap , single , insert , lookup , fromList+ , toList -- * Types , Piece (..)@@ -24,12 +26,13 @@ import Prelude hiding (lookup) import Control.Arrow ((&&&))+import Data.Bifunctor (first) import Data.Coerce (coerce) import Data.Foldable (foldl') import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty (..))-import Data.Semigroup (Semigroup)+import Data.Semigroup (Semigroup (..)) import Data.String (IsString (..)) import Data.Text (Text) import GHC.Generics (Generic)@@ -96,6 +99,9 @@ } deriving (Show, Eq) +instance Semigroup (PrefixTree a) where+ a <> b = foldl' (\tree (k, v) -> insertT k v tree) a (toListT b)+ data KeysDiff -- | Keys are equal = Equal@@ -126,6 +132,10 @@ then listSame fs ss (pr ++ [f]) else Diff (x :|| pr) (f :|| fs) (s :|| ss) +-- | Prepends 'Piece' to the beginning of the 'Key'.+(<|) :: Piece -> Key -> Key+(<|) p k = Key (p NonEmpty.<| unKey k)+ -- | Creates a 'PrefixTree' of one key-value element. singleT :: Key -> a -> PrefixTree a singleT = Leaf@@ -177,9 +187,21 @@ 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.+-- | Constructs 'PrefixMap' 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++-- | Converts 'PrefixTree' to the list of pairs.+toListT :: PrefixTree a -> [(Key, a)]+toListT (Leaf k v) = [(k, v)]+toListT (Branch pref ma prefMap) = case ma of+ Just a -> (:) (pref, a)+ Nothing -> id+ $ map (\(k, v) -> (pref <> k, v)) $ toList prefMap++-- | Converts 'PrefixMap' to the list of pairs.+toList :: PrefixMap a -> [(Key, a)]+toList = concatMap (\(p, tr) -> first (p <|) <$> toListT tr) . HashMap.toList
src/Toml/Printer.hs view
@@ -70,12 +70,12 @@ 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) <> "]"+ valText (Bool b) = Text.toLower $ showText b+ valText (Integer n) = showText n+ valText (Double d) = showText d+ valText (Text s) = showText s+ valText (Date d) = timeText d+ valText (Array a) = "[" <> Text.intercalate ", " (map valText a) <> "]" timeText :: DateTime -> Text timeText (Zoned z) = showText z
+ src/Toml/Prism.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE Rank2Types #-}++-- | Naive implementation of data-prism approach.++module Toml.Prism+ ( -- * Prism idea+ Prism (..)+ , match+ , mkAnyValuePrism++ -- * Value prisms+ , _Bool+ , _Integer+ , _Double+ , _Text+ , _Array++ -- * Useful utility functions+ , unsafeArray+ ) where++import Control.Monad ((>=>))+import Data.Text (Text)++import Toml.Type (AnyValue (..), TValue (TArray), Value (..), liftMatch, matchArray, matchBool,+ matchDouble, matchInteger, matchText, reifyAnyValues)++import qualified Control.Category as Cat++----------------------------------------------------------------------------+-- Prism concepts and ideas+----------------------------------------------------------------------------++{- | Implementation of prism idea using simple data prism approach. Single value+of type 'Prism' has two capabilities:++1. 'preview': first-class pattern-matching (deconstruct @object@ to possible @field@).+2. 'review': constructor of @object@ from @field@.+-}+data Prism object field = Prism+ { preview :: object -> Maybe field+ , review :: field -> object+ }++instance Cat.Category Prism where+ id :: Prism object object+ id = Prism { preview = Just, review = id }++ (.) :: Prism field subfield -> Prism object field -> Prism object subfield+ fieldPrism . objectPrism = Prism+ { preview = preview objectPrism >=> preview fieldPrism+ , review = review objectPrism . review fieldPrism+ }++-- | Creates prism for 'AnyValue'.+mkAnyValuePrism :: (forall t . Value t -> Maybe a)+ -> (a -> Value tag)+ -> Prism AnyValue a+mkAnyValuePrism matchValue toValue = Prism+ { review = AnyValue . toValue+ , preview = \(AnyValue value) -> matchValue value+ }++-- | Allows to match against given 'Value' using provided prism for 'AnyValue'.+match :: Prism AnyValue a -> Value t -> Maybe a+match = liftMatch . preview++----------------------------------------------------------------------------+-- Prisms for value+----------------------------------------------------------------------------++-- | 'Bool' prism for 'AnyValue'. Usually used with 'arrayOf' combinator.+_Bool :: Prism AnyValue Bool+_Bool = mkAnyValuePrism matchBool Bool++-- | 'Integer' prism for 'AnyValue'. Usually used with 'arrayOf' combinator.+_Integer :: Prism AnyValue Integer+_Integer = mkAnyValuePrism matchInteger Integer++-- | 'Double' prism for 'AnyValue'. Usually used with 'arrayOf' combinator.+_Double :: Prism AnyValue Double+_Double = mkAnyValuePrism matchDouble Double++-- | 'Text' prism for 'AnyValue'. Usually used with 'arrayOf' combinator.+_Text :: Prism AnyValue Text+_Text = mkAnyValuePrism matchText Text++-- | 'Array' prism for 'AnyValue'. Usually used with 'arrayOf' combinator.+_Array :: Prism AnyValue a -> Prism AnyValue [a]+_Array elementPrism = mkAnyValuePrism (matchArray $ preview elementPrism)+ (unsafeArray . map (review elementPrism))++-- TODO: put this in 'Toml.Type' module?+-- | Unsafe function for creating 'Array' from list of 'AnyValue'. This function+-- assumes that every element in this list has the same type. Usually used when+-- list of 'AnyValue' is created using single prism.+unsafeArray :: [AnyValue] -> Value 'TArray+unsafeArray [] = Array []+unsafeArray (AnyValue x : xs) = case reifyAnyValues x xs of+ Left err -> error $ "Can't create Array from list AnyValues: " ++ show err+ Right vals -> Array (x : vals)
src/Toml/Type.hs view
@@ -1,302 +1,11 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeOperators #-}--{- | Contains specification of TOML via Haskell ADT. -}- module Toml.Type- ( -- * Main type- TOML (..)-- -- * Values- , ValueType (..)- , Value (..)- , AnyValue (..)- , UValue (..)- , DateTime (..)- , matchBool- , matchInteger- , matchDouble- , matchText- , matchDate- , matchArray- , showType- , valueType-- -- * Internal functions- , typeCheck+ ( module Toml.Type.AnyValue+ , module Toml.Type.TOML+ , module Toml.Type.UValue+ , module Toml.Type.Value ) 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- deriving (Eq, Show)--showType :: ValueType -> String-showType = drop 1 . show---- 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- Right Refl -> x == y && eqValueList xs ys- Left _ -> False-eqValueList _ _ = False---- | Reifies type of 'Value' into 'ValueType'. Unfortunately, there's no way to--- guarante that 'valueType' will return @t@ for object with type @Value \'t@.-valueType :: Value t -> ValueType-valueType (Bool _) = TBool-valueType (Int _) = TInt-valueType (Float _) = TFloat-valueType (String _) = TString-valueType (Date _) = TDate-valueType (Array _) = TArray--------------------------------------------------------------------------------- Matching functions for values--------------------------------------------------------------------------------- | Extract 'Bool' from 'Value'.-matchBool :: Value f -> Maybe Bool-matchBool (Bool b) = Just b-matchBool _ = Nothing---- | Extract 'Integer' from 'Value'.-matchInteger :: Value f -> Maybe Integer-matchInteger (Int n) = Just n-matchInteger _ = Nothing---- | Extract 'Double' from 'Value'.-matchDouble :: Value f -> Maybe Double-matchDouble (Float f) = Just f-matchDouble _ = Nothing---- | Extract 'Text' from 'Value'.-matchText :: Value f -> Maybe Text-matchText (String s) = Just s-matchText _ = Nothing---- | Extract 'DateTime' from 'Value'.-matchDate :: Value f -> Maybe DateTime-matchDate (Date d) = Just d-matchDate _ = Nothing---- | Extract list of elements of type @a@ from array.-matchArray :: (forall t . Value t -> Maybe a) -> Value f -> Maybe [a]-matchArray matchElement (Array a) = mapM matchElement a-matchArray _ _ = Nothing--------------------------------------------------------------------------------- Untyped value--------------------------------------------------------------------------------- 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---- | Data type that holds expected vs. actual type.-data TypeMismatchError = TypeMismatchError- { typeExpected :: ValueType- , typeActual :: ValueType- } deriving (Eq)--instance Show TypeMismatchError where- show TypeMismatchError{..} = "Expected type '" ++ showType typeExpected- ++ "' but actual type: '" ++ showType typeActual ++ "'"---- | Ensures that 'UValue's represents type-safe version of @toml@.-typeCheck :: UValue -> Either TypeMismatchError AnyValue-typeCheck (UBool b) = rightAny $ Bool b-typeCheck (UInt n) = rightAny $ Int n-typeCheck (UFloat f) = rightAny $ Float f-typeCheck (UString s) = rightAny $ String s-typeCheck (UDate d) = rightAny $ Date d-typeCheck (UArray a) = case a of- [] -> rightAny $ Array []- x:xs -> do- AnyValue v <- typeCheck x- AnyValue . Array <$> checkElem v xs- where- checkElem :: Value t -> [UValue] -> Either TypeMismatchError [Value t]- checkElem v [] = Right [v]- checkElem v (x:xs) = do- AnyValue vx <- typeCheck x- Refl <- sameValue v vx- (v :) <$> checkElem vx xs--rightAny :: Value t -> Either l AnyValue-rightAny = Right . AnyValue--sameValue :: Value a -> Value b -> Either TypeMismatchError (a :~: b)-sameValue Bool{} Bool{} = Right Refl-sameValue Int{} Int{} = Right Refl-sameValue Float{} Float{} = Right Refl-sameValue String{} String{} = Right Refl-sameValue Date{} Date{} = Right Refl-sameValue Array{} Array{} = Right Refl-sameValue l r = Left $ TypeMismatchError- { typeExpected = valueType l- , typeActual = valueType r- }+import Toml.Type.AnyValue+import Toml.Type.TOML+import Toml.Type.UValue+import Toml.Type.Value
+ src/Toml/Type/AnyValue.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}++module Toml.Type.AnyValue+ ( AnyValue (..)+ , reifyAnyValues++ -- * Matching+ , liftMatch+ , matchBool+ , matchInteger+ , matchDouble+ , matchText+ , matchDate+ , matchArray+ ) where++import Data.Text (Text)+import Data.Type.Equality ((:~:) (..))++import Toml.Type.Value (DateTime, TValue, TypeMismatchError, Value (..), eqValueList, sameValue)++-- | Existential wrapper for 'Value'.+data AnyValue = forall (t :: TValue) . 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 (Integer i1)) == (AnyValue (Integer i2)) = i1 == i2+ (AnyValue (Double f1)) == (AnyValue (Double f2)) = f1 == f2+ (AnyValue (Text s1)) == (AnyValue (Text s2)) = s1 == s2+ (AnyValue (Date d1)) == (AnyValue (Date d2)) = d1 == d2+ (AnyValue (Array a1)) == (AnyValue (Array a2)) = eqValueList a1 a2+ _ == _ = False++----------------------------------------------------------------------------+-- Matching functions for values+----------------------------------------------------------------------------++-- | Extract 'Bool' from 'Value'.+matchBool :: Value t -> Maybe Bool+matchBool (Bool b) = Just b+matchBool _ = Nothing++-- | Extract 'Integer' from 'Value'.+matchInteger :: Value t -> Maybe Integer+matchInteger (Integer n) = Just n+matchInteger _ = Nothing++-- | Extract 'Double' from 'Value'.+matchDouble :: Value t -> Maybe Double+matchDouble (Double f) = Just f+matchDouble _ = Nothing++-- | Extract 'Text' from 'Value'.+matchText :: Value t -> Maybe Text+matchText (Text s) = Just s+matchText _ = Nothing++-- | Extract 'DateTime' from 'Value'.+matchDate :: Value t -> Maybe DateTime+matchDate (Date d) = Just d+matchDate _ = Nothing++-- | Extract list of elements of type @a@ from array.+matchArray :: (AnyValue -> Maybe a) -> Value t -> Maybe [a]+matchArray matchValue (Array a) = mapM (liftMatch matchValue) a+matchArray _ _ = Nothing++liftMatch :: (AnyValue -> Maybe a) -> (Value t -> Maybe a)+liftMatch fromAnyValue = fromAnyValue . AnyValue++-- | Checks whether all elements inside given list of 'AnyValue' have the same+-- type as given 'Value'. Returns list of @Value t@ without given 'Value'.+reifyAnyValues :: Value t -> [AnyValue] -> Either TypeMismatchError [Value t]+reifyAnyValues _ [] = Right []+reifyAnyValues v (AnyValue av : xs) = sameValue v av >>= \Refl -> (av :) <$> reifyAnyValues v xs
+ src/Toml/Type/TOML.hs view
@@ -0,0 +1,43 @@+module Toml.Type.TOML+ ( TOML (..)+ , insertKeyVal+ , insertTable+ ) where++import Data.HashMap.Strict (HashMap)+import Data.Semigroup (Semigroup (..))++import Toml.PrefixTree (Key (..), PrefixMap)+import Toml.Type.AnyValue (AnyValue (..))+import Toml.Type.Value (Value)++import qualified Data.HashMap.Strict as HashMap+import qualified Toml.PrefixTree as Prefix+++-- 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)++instance Semigroup TOML where+ (TOML pairsA tablesA) <> (TOML pairsB tablesB) = TOML+ (pairsA <> pairsB)+ (HashMap.unionWith (<>) tablesA tablesB)++instance Monoid TOML where+ mappend = (<>)+ mempty = TOML mempty mempty++-- | Inserts given key-value into the 'TOML'.+insertKeyVal :: Key -> Value a -> TOML -> TOML+insertKeyVal k v toml = toml {tomlPairs = HashMap.insert k (AnyValue v) (tomlPairs toml)}++-- | Inserts given table into the 'TOML'.+insertTable :: Key -> TOML -> TOML -> TOML+insertTable k inToml toml = toml+ { tomlTables = Prefix.insert k inToml (tomlTables toml)+ }
+ src/Toml/Type/UValue.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE GADTs #-}++module Toml.Type.UValue+ ( UValue (..)+ , typeCheck+ ) where++import Data.Text (Text)+import Data.Type.Equality ((:~:) (..))++import Toml.Type.AnyValue (AnyValue (..))+import Toml.Type.Value (DateTime, TypeMismatchError, Value (..), sameValue)++-- | Untyped value of 'TOML'. You shouldn't use this type in your code. Use+-- 'Value' instead.+data UValue+ = UBool !Bool+ | UInteger !Integer+ | UDouble !Double+ | UText !Text+ | UDate !DateTime+ | UArray ![UValue]+ deriving (Eq, Show)++-- | Ensures that 'UValue's represents type-safe version of @toml@.+typeCheck :: UValue -> Either TypeMismatchError AnyValue+typeCheck (UBool b) = rightAny $ Bool b+typeCheck (UInteger n) = rightAny $ Integer n+typeCheck (UDouble f) = rightAny $ Double f+typeCheck (UText s) = rightAny $ Text s+typeCheck (UDate d) = rightAny $ Date d+typeCheck (UArray a) = case a of+ [] -> rightAny $ Array []+ x:xs -> do+ AnyValue v <- typeCheck x+ AnyValue . Array <$> checkElem v xs+ where+ checkElem :: Value t -> [UValue] -> Either TypeMismatchError [Value t]+ checkElem v [] = Right [v]+ checkElem v (x:xs) = do+ AnyValue vx <- typeCheck x+ Refl <- sameValue v vx+ (v :) <$> checkElem vx xs++rightAny :: Value t -> Either l AnyValue+rightAny = Right . AnyValue
+ src/Toml/Type/Value.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}++module Toml.Type.Value+ ( -- * Type of value+ TValue (..)+ , showType++ -- * Value+ , Value (..)+ , DateTime (..)+ , eqValueList+ , valueType++ -- * Type checking+ , TypeMismatchError (..)+ , sameValue+ ) where++import Data.String (IsString (..))+import Data.Text (Text)+import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime, zonedTimeToUTC)+import Data.Type.Equality ((:~:) (..))++-- | Needed for GADT parameterization+data TValue = TBool | TInteger | TDouble | TText | TDate | TArray+ deriving (Eq, Show)++showType :: TValue -> String+showType = drop 1 . show++-- 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 :: TValue) 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+@+ -}+ Integer :: Integer -> Value 'TInteger++ {- | Floating point number:++@+flt1 = -3.1415 # fractional+flt2 = 1e6 # exponent+flt3 = 6.626e-34 # both+flt4 = 9_224_617.445_991_228_313+@+ -}+ Double :: Double -> Value 'TDouble++ {- | String value:++@+key = "value"+bare_key = "value"+bare-key = "value"+@+ -}+ Text :: Text -> Value 'TText++ -- | 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 (t ~ 'TInteger) => Num (Value t) where+ (Integer a) + (Integer b) = Integer $ a + b+ (Integer a) * (Integer b) = Integer $ a * b+ abs (Integer a) = Integer (abs a)+ signum (Integer a) = Integer (signum a)+ fromInteger = Integer+ negate (Integer a) = Integer (negate a)++instance (t ~ 'TText) => IsString (Value t) where+ fromString = Text . fromString @Text++instance Eq (Value t) where+ (Bool b1) == (Bool b2) = b1 == b2+ (Integer i1) == (Integer i2) = i1 == i2+ (Double f1) == (Double f2) = f1 == f2+ (Text s1) == (Text 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+ Right Refl -> x == y && eqValueList xs ys+ Left _ -> False+eqValueList _ _ = False++-- | Reifies type of 'Value' into 'ValueType'. Unfortunately, there's no way to+-- guarante that 'valueType' will return @t@ for object with type @Value \'t@.+valueType :: Value t -> TValue+valueType (Bool _) = TBool+valueType (Integer _) = TInteger+valueType (Double _) = TDouble+valueType (Text _) = TText+valueType (Date _) = TDate+valueType (Array _) = TArray++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++----------------------------------------------------------------------------+-- Typechecking values+----------------------------------------------------------------------------++-- | Data type that holds expected vs. actual type.+data TypeMismatchError = TypeMismatchError+ { typeExpected :: TValue+ , typeActual :: TValue+ } deriving (Eq)++instance Show TypeMismatchError where+ show TypeMismatchError{..} = "Expected type '" ++ showType typeExpected+ ++ "' but actual type: '" ++ showType typeActual ++ "'"++sameValue :: Value a -> Value b -> Either TypeMismatchError (a :~: b)+sameValue Bool{} Bool{} = Right Refl+sameValue Integer{} Integer{} = Right Refl+sameValue Double{} Double{} = Right Refl+sameValue Text{} Text{} = Right Refl+sameValue Date{} Date{} = Right Refl+sameValue Array{} Array{} = Right Refl+sameValue l r = Left $ TypeMismatchError+ { typeExpected = valueType l+ , typeActual = valueType r+ }
test/Spec.hs view
@@ -1,11 +1,1 @@-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]+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}
test/Test/Toml/Gen.hs view
@@ -5,7 +5,12 @@ -- | This module contains all generators for @tomland@ testing. module Test.Toml.Gen- ( genVal+ ( -- * Property+ PropertyTest+ , prop++ -- * Generators+ , genVal , genKey , genPrefixMap , genToml@@ -13,8 +18,10 @@ import Control.Applicative (liftA2) import Control.Monad (forM)--import Hedgehog (MonadGen)+import GHC.Stack (HasCallStack)+import Hedgehog (MonadGen, PropertyT, property)+import Test.Tasty (TestName, TestTree)+import Test.Tasty.Hedgehog (testProperty) import Toml.PrefixTree (pattern (:||), Key (..), Piece (..), PrefixMap, PrefixTree (..), fromList) import Toml.Type (AnyValue (..), TOML (..), Value (..))@@ -24,6 +31,15 @@ import qualified Hedgehog.Range as Range ----------------------------------------------------------------------------+-- Property test creator+----------------------------------------------------------------------------++type PropertyTest = [TestTree]++prop :: HasCallStack => TestName -> PropertyT IO () -> [TestTree]+prop testName = pure . testProperty testName . property++---------------------------------------------------------------------------- -- Common generators ---------------------------------------------------------------------------- @@ -38,13 +54,13 @@ 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+ let randD = Gen.double $ Range.constant @Double (-1000000.0) 1000000.0+ let randT = Gen.text (Range.constant 0 256) Gen.alphaNum Gen.choice- [ AnyValue . Bool <$> randB- , AnyValue . Int <$> randI- , AnyValue . Float <$> randF- , AnyValue . String <$> randS+ [ AnyValue . Bool <$> randB+ , AnyValue . Integer <$> randI+ , AnyValue . Double <$> randD+ , AnyValue . Text <$> randT ] -- TODO: unicode support
− test/Test/Toml/Parsing.hs
@@ -1,10 +0,0 @@-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
@@ -1,20 +1,13 @@-module Test.Toml.Parsing.Property- ( propertyTests- ) where+module Test.Toml.Parsing.Property where -import Hedgehog (Property, forAll, property, (===))-import Test.Tasty (TestTree)-import Test.Tasty.Hedgehog (testProperty)+import Hedgehog (forAll, tripping) import Toml.Parser (parse) import Toml.Printer (prettyToml) -import Test.Toml.Gen (genToml)--propertyTests :: [TestTree]-propertyTests = [ testProperty "parse . prettyPrint == id" prop_parsePrint ]+import Test.Toml.Gen (PropertyTest, genToml, prop) -prop_parsePrint :: Property-prop_parsePrint = property $ do+test_tomlRoundtrip :: PropertyTest+test_tomlRoundtrip = prop "parse . prettyPrint == id" $ do toml <- forAll genToml- parse (prettyToml toml) === Right toml+ tripping toml prettyToml parse
+ test/Test/Toml/Parsing/Unit.hs view
@@ -0,0 +1,307 @@+{-# LANGUAGE FlexibleContexts #-}++module Test.Toml.Parsing.Unit where++import Data.Semigroup ((<>))+import Test.Hspec.Megaparsec (shouldFailOn, shouldParse)+import Test.Tasty.Hspec (Spec, context, describe, it)+import Text.Megaparsec (parse)++import Toml.Parser (arrayP, boolP, doubleP, integerP, keyP, keyValP, tableHeaderP, textP, tomlP)+import Toml.PrefixTree (Key (..), Piece (..), fromList)+import Toml.Type (AnyValue (..), TOML (..), UValue (..), Value (..))++import qualified Data.HashMap.Lazy as HashMap+import qualified Data.List.NonEmpty as NE++spec_Parser :: Spec+spec_Parser = do+ let parseX p given expected = parse p "" given `shouldParse` expected+ failOn p given = parse p "" `shouldFailOn` given++ parseArray = parseX arrayP+ parseBool = parseX boolP+ parseDouble = parseX doubleP+ parseInteger = parseX integerP+ parseKey = parseX keyP+ parseKeyVal = parseX keyValP+ parseText = parseX textP+ parseTable = parseX tableHeaderP+ parseToml = parseX tomlP++ arrayFailOn = failOn arrayP+ boolFailOn = failOn boolP+ keyValFailOn = failOn keyValP+ textFailOn = failOn textP++ quoteWith q t = q <> t <> q+ squote = quoteWith "'"+ dquote = quoteWith "\""++ makeKey k = (Key . NE.fromList) (map Piece k)++ tomlFromList kv = TOML (HashMap.fromList kv) mempty+++ describe "arrayP" $ do+ it "can parse arrays" $ do+ parseArray "[]" []+ parseArray "[1]" [UInteger 1]+ parseArray "[1, 2, 3]" [UInteger 1, UInteger 2, UInteger 3]+ parseArray "[1.2, 2.3, 3.4]" [UDouble 1.2, UDouble 2.3, UDouble 3.4]+ parseArray "['x', 'y']" [UText "x", UText "y"]+ parseArray "[[1], [2]]" [UArray [UInteger 1], UArray [UInteger 2]]+ --xit "can parse arrays of dates" $ do+ -- let makeDay y m d = (UDate . Day) (fromGregorian y m d)+ -- makeHours h m s = (UDate . Hours) (TimeOfDay h m s)+ -- parseArray "[1920-12-10, 10:15:30]" [makeDay 1920 12 10, makeHours 10 15 30]+ it "can parse multiline arrays" $ do+ parseArray "[\n1,\n2\n]" [UInteger 1, UInteger 2]+ it "can parse an array of arrays" $ do+ parseArray "[[1], [2.3, 5.1]]" [UArray [UInteger 1], UArray [UDouble 2.3, UDouble 5.1]]+ it "can parse an array with terminating commas (trailing commas)" $ do+ parseArray "[1, 2,]" [UInteger 1, UInteger 2]+ parseArray "[1, 2, 3, , ,]" [UInteger 1, UInteger 2, UInteger 3]+ it "allows an arbitrary number of comments and newlines before or after a value" $ do+ parseArray "[\n\n#c\n1, #c 2 \n 2, \n\n\n 3, #c \n #c \n 4]" [UInteger 1, UInteger 2, UInteger 3, UInteger 4]+ it "ignores white spaces" $ do+ parseArray "[ 1 , 2,3, 4 ]" [UInteger 1, UInteger 2, UInteger 3, UInteger 4]+ it "fails if the elements are not surrounded by square brackets" $ do+ arrayFailOn "1, 2, 3"+ arrayFailOn "[1, 2, 3"+ arrayFailOn "1, 2, 3]"+ arrayFailOn "{'x', 'y', 'z'}"+ arrayFailOn "(\"ab\", \"cd\")"+ arrayFailOn "<true, false>"+ it "fails if the elements are not separated by commas" $ do+ arrayFailOn "[1 2 3]"+ arrayFailOn "[1 . 2 . 3]"+ arrayFailOn "['x' - 'y' - 'z']"++ describe "boolP" $ do+ it "can parse `true` and `false`" $ do+ parseBool "true" True+ parseBool "false" False+ parseBool "true " True+ it "fails if `true` or `false` are not all lowercase" $ do+ boolFailOn "True"+ boolFailOn "False"+ boolFailOn "TRUE"+ boolFailOn "FALSE"+ boolFailOn "tRuE"+ boolFailOn "fAlSE"++ describe "doubleP" $ do+ it "can parse a number which consists of an integral part, and a fractional part" $ do+ parseDouble "+1.0" 1.0+ parseDouble "3.1415" 3.1415+ parseDouble "0.0" 0.0+ parseDouble "-0.01" (-0.01)+ it "can parse a number which consists of an integral part, and an exponent part" $ do+ parseDouble "5e+22" 5e+22+ parseDouble "1e6" 1e6+ parseDouble "-2E-2" (-2E-2)+ it "can parse a number which consists of an integral, a fractional, and an exponent part" $ do+ parseDouble "6.626e-34" 6.626e-34+ it "can parse sign-prefixed zero" $ do+ parseDouble "+0.0" 0.0+ parseDouble "-0.0" (-0.0)++ describe "integerP" $ do+ context "when the integer is in decimal representation" $ do+ it "can parse positive integer numbers" $ do+ parseInteger "10" 10+ parseInteger "+3" 3+ parseInteger "0" 0+ it "can parse negative integer numbers" $ do+ parseInteger "-123" (-123)+ it "can parse sign-prefixed zero as an unprefixed zero" $ do+ parseInteger "+0" 0+ parseInteger "-0" 0+ it "can parse both the minimum and maximum numbers in the 64 bit range" $ do+ parseInteger "-9223372036854775808" (-9223372036854775808)+ parseInteger "9223372036854775807" 9223372036854775807+ --xit "can parse numbers with underscores between digits" $ do+ -- parseInt "1_000" 1000+ -- parseInt "5_349_221" 5349221+ -- parseInt "1_2_3_4_5" 12345+ -- parseInt "1_2_3_" 1+ -- parseInt "13_" 13+ -- intFailOn "_123_"+ -- intFailOn "_13"+ -- intFailOn "_"+ --xit "does not parse numbers with leading zeros" $ do+ -- parseInt "0123" 0+ -- parseInt "-023" 0+ context "when the integer is in binary representation" $ do+ it "can parse numbers prefixed with `0b`" $ do+ parseInteger "0b1101" 13+ parseInteger "0b0" 0+ it "does not parse numbers prefixed with `0B`" $ do+ parseInteger "0B1101" 0+ it "can parse numbers with leading zeros after the prefix" $ do+ parseInteger "0b000" 0+ parseInteger "0b00011" 3+ it "does not parse negative numbers" $ do+ parseInteger "-0b101" 0+ it "does not parse numbers with non-valid binary digits" $ do+ parseInteger "0b123" 1+ context "when the integer is in octal representation" $ do+ it "can parse numbers prefixed with `0o`" $ do+ parseInteger "0o567" 0o567+ parseInteger "0o0" 0+ it "does not parse numbers prefixed with `0O`" $ do+ parseInteger "0O567" 0+ it "can parse numbers with leading zeros after the prefix" $ do+ parseInteger "0o000000" 0+ parseInteger "0o000567" 0o567+ it "does not parse negative numbers" $ do+ parseInteger "-0o123" 0+ it "does not parse numbers with non-valid octal digits" $ do+ parseInteger "0o789" 0o7+ context "when the integer is in hexadecimal representation" $ do+ it "can parse numbers prefixed with `0x`" $ do+ parseInteger "0x12af" 0x12af+ parseInteger "0x0" 0+ it "does not parse numbers prefixed with `0X`" $ do+ parseInteger "0Xfff" 0+ it "can parse numbers with leading zeros after the prefix" $ do+ parseInteger "0x00000" 0+ parseInteger "0x012af" 0x12af+ it "does not parse negative numbers" $ do+ parseInteger "-0xfff" 0+ it "does not parse numbers with non-valid hexadecimal digits" $ do+ parseInteger "0xfgh" 0xf+ it "can parse numbers when hex digits are lowercase" $ do+ parseInteger "0xabcdef" 0xabcdef+ it "can parse numbers when hex digits are uppercase" $ do+ parseInteger "0xABCDEF" 0xABCDEF+ it "can parse numbers when hex digits are in both lowercase and uppercase" $ do+ parseInteger "0xAbCdEf" 0xAbCdEf+ parseInteger "0xaBcDeF" 0xaBcDeF++ describe "keyP" $ do+ context "when the key is a bare key" $ do+ it "can parse keys which contain ASCII letters, digits, underscores, and dashes" $ do+ parseKey "key" (makeKey ["key"])+ parseKey "bare_key1" (makeKey ["bare_key1"])+ parseKey "bare-key2" (makeKey ["bare-key2"])+ it "can parse keys which contain only digits" $ do+ parseKey "1234" (makeKey ["1234"])+ context "when the key is a quoted key" $ do+ it "can parse keys that follow the exact same rules as basic strings" $ do+ parseKey (dquote "127.0.0.1") (makeKey [dquote "127.0.0.1"])+ parseKey (dquote "character encoding") (makeKey [dquote "character encoding"])+ parseKey (dquote "ʎǝʞ") (makeKey [dquote "ʎǝʞ"])+ it "can parse keys that follow the exact same rules as literal strings" $ do+ parseKey (squote "key2") (makeKey [squote "key2"])+ parseKey (squote "quoted \"value\"") (makeKey [squote "quoted \"value\""])+ context "when the key is a dotted key" $ do+ it "can parse a sequence of bare or quoted keys joined with a dot" $ do+ parseKey "name" (makeKey ["name"])+ parseKey "physical.color" (makeKey ["physical", "color"])+ parseKey "physical.shape" (makeKey ["physical", "shape"])+ parseKey "site.\"google.com\"" (makeKey ["site", dquote "google.com"])+ --xit "ignores whitespaces around dot-separated parts" $ do+ -- parseKey "a . b . c. d" (makeKey ["a", "b", "c", "d"])++ describe "keyValP" $ do+ it "can parse key/value pairs" $ do+ parseKeyVal "x='abcdef'" (makeKey ["x"], AnyValue (Text "abcdef"))+ parseKeyVal "x=1" (makeKey ["x"], AnyValue (Integer 1))+ parseKeyVal "x=5.2" (makeKey ["x"], AnyValue (Double 5.2))+ parseKeyVal "x=true" (makeKey ["x"], AnyValue (Bool True))+ parseKeyVal "x=[1, 2, 3]" (makeKey ["x"], AnyValue (Array [Integer 1, Integer 2, Integer 3]))+ --xit "can parse a key/value pair when the value is a date" $ do+ -- let makeDay y m d = (AnyValue .Date . Day) (fromGregorian y m d)++ -- parseKeyVal "x = 1920-12-10" (makeKey ["x"], makeDay 1920 12 10)+ --xit "can parse a key/value pair when the value is an inline table" $ do+ -- pending+ it "ignores white spaces around key names and values" $ do+ parseKeyVal "x=1 " (makeKey ["x"], AnyValue (Integer 1))+ parseKeyVal "x= 1" (makeKey ["x"], AnyValue (Integer 1))+ parseKeyVal "x =1" (makeKey ["x"], AnyValue (Integer 1))+ parseKeyVal "x\t= 1 " (makeKey ["x"], AnyValue (Integer 1))+ parseKeyVal "\"x\" = 1" (makeKey [dquote "x"], AnyValue (Integer 1))+ --xit "fails if the key, equals sign, and value are not on the same line" $ do+ -- keyValFailOn "x\n=\n1"+ -- keyValFailOn "x=\n1"+ -- keyValFailOn "\"x\"\n=\n1"+ it "works if the value is broken over multiple lines" $ do+ parseKeyVal "x=[1, \n2\n]" (makeKey ["x"], AnyValue (Array [Integer 1, Integer 2]))+ it "fails if the value is not specified" $ do+ keyValFailOn "x="++ describe "textP" $ do+ context "when the string is a basic string" $ do+ it "can parse strings surrounded by double quotes" $ do+ parseText (dquote "xyz") "xyz"+ parseText (dquote "") ""+ textFailOn "\"xyz"+ textFailOn "xyz\""+ textFailOn "xyz"+ --xit "can parse escaped quotation marks, backslashes, and control characters" $ do+ -- parseString (dquote "backspace: \\b") "backspace: \b"+ -- parseString (dquote "tab: \\t") "tab: \t"+ -- parseString (dquote "linefeed: \\n") "linefeed: \n"+ -- parseString (dquote "form feed: \\f") "form feed: \f"+ -- parseString (dquote "carriage return: \\r") "carriage return: \r"+ -- parseString (dquote "quote: \\\"") "quote: \""+ -- parseString (dquote "backslash: \\\\") "backslash: \\"+ -- parseString (dquote "a\\uD7FFxy\\U0010FFFF\\uE000") "a\55295xy\1114111\57344"+ --xit "fails if the string has an unescaped backslash, or control character" $ do+ -- stringFailOn (dquote "new \n line")+ -- stringFailOn (dquote "back \\ slash")+ --xit "fails if the string has an escape sequence that is not listed in the TOML specification" $ do+ -- stringFailOn (dquote "xy\\z \\abc")+ --xit "fails if the string is not on a single line" $ do+ -- stringFailOn (dquote "\nabc")+ -- stringFailOn (dquote "ab\r\nc")+ -- stringFailOn (dquote "abc\n")+ --xit "fails if escape codes are not valid Unicode scalar values" $ do+ -- stringFailOn (dquote "\\u1")+ -- stringFailOn (dquote "\\uxyzw")+ -- stringFailOn (dquote "\\U0000")+ -- stringFailOn (dquote "\\uD8FF")+ -- stringFailOn (dquote "\\U001FFFFF")+ context "when the string is a literal string" $ do+ it "can parse strings surrounded by single quotes" $ do+ parseText (squote "C:\\Users\\nodejs\\templates") "C:\\Users\\nodejs\\templates"+ parseText (squote "\\\\ServerX\\admin$\\system32\\") "\\\\ServerX\\admin$\\system32\\"+ parseText (squote "Tom \"Dubs\" Preston-Werner") "Tom \"Dubs\" Preston-Werner"+ parseText (squote "<\\i\\c*\\s*>") "<\\i\\c*\\s*>"+ parseText (squote "a \t tab") "a \t tab"+ --xit "fails if the string is not on a single line" $ do+ -- stringFailOn (squote "\nabc")+ -- stringFailOn (squote "ab\r\nc")+ -- stringFailOn (squote "abc\n")++ describe "tableHeaderP" $ do+ it "can parse a TOML table" $ do+ let key1KV = (makeKey ["key1"], AnyValue (Text "some string"))+ key2KV = (makeKey ["key2"], AnyValue (Integer 123))+ table = (makeKey ["table-1"], tomlFromList [key1KV, key2KV])++ parseTable "[table-1]\nkey1 = \"some string\"\nkey2 = 123" table+ it "can parse an empty TOML table" $ do+ parseTable "[table]" (makeKey ["table"], tomlFromList [])+ it "allows the name of the table to be any valid TOML key" $ do+ parseTable "[dog.\"tater.man\"]" (makeKey ["dog", dquote "tater.man"], tomlFromList [])+ parseTable "[j.\"ʞ\".'l']" (makeKey ["j", dquote "ʞ", squote "l"], tomlFromList [])++ describe "tomlP" $ do+ it "can parse TOML files" $ do+ let tomlString = " # This is a TOML document.\n\n \+ \ title = \"TOML Example\" # Comment \n\n \+ \ [owner]\n \+ \ name = \"Tom Preston-Werner\" \+ \ enabled = true # First class dates"++ titleKV = (makeKey ["title"], AnyValue (Text "TOML Example"))+ nameKV = (makeKey ["name"], AnyValue (Text "Tom Preston-Werner"))+ enabledKV = (makeKey ["enabled"], AnyValue (Bool True))+ tomlPairs = HashMap.fromList [titleKV]+ tomlTables = fromList [(makeKey ["owner"], tomlFromList [nameKV, enabledKV])]++ parseToml tomlString (TOML tomlPairs tomlTables)
− test/Test/Toml/PrefixTree.hs
@@ -1,13 +0,0 @@-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
@@ -1,27 +1,18 @@-module Test.Toml.PrefixTree.Property- ( propertyTests- ) where+module Test.Toml.PrefixTree.Property where -import Hedgehog (Property, forAll, property, (===))-import Test.Tasty (TestTree)-import Test.Tasty.Hedgehog (testProperty)+import Hedgehog (forAll, (===)) -import Test.Toml.Gen (genKey, genPrefixMap, genVal)+import Test.Toml.Gen (PropertyTest, genKey, genPrefixMap, genVal, prop)+import Test.Toml.Property (assocLaw, identityLaw) 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+test_PrefixTreeInsertLookup :: PropertyTest+test_PrefixTreeInsertLookup = prop "lookup k (insert k v m) == Just v" $ do t <- forAll genPrefixMap key <- forAll genKey val <- forAll genVal@@ -35,8 +26,8 @@ -- InsertInsert ---------------------------------------------------------------------------- -prop_InsertInsert :: Property-prop_InsertInsert = property $ do+test_PrefixTreeInsertInsert :: PropertyTest+test_PrefixTreeInsertInsert = prop "insert x a . insert x b == insert x a" $ do t <- forAll genPrefixMap x <- forAll genKey a <- forAll genVal@@ -57,3 +48,13 @@ -- depthT :: PrefixTree a -> Int -- depthT (Leaf _ _) = 1 -- depthT (Branch _ _ prefMap) = 1 + depth prefMap++----------------------------------------------------------------------------+-- Laws+----------------------------------------------------------------------------++test_PrefixTreeAssocLaw :: PropertyTest+test_PrefixTreeAssocLaw = assocLaw genPrefixMap++test_PrefixTreeIdentityLaw :: PropertyTest+test_PrefixTreeIdentityLaw = identityLaw genPrefixMap
test/Test/Toml/PrefixTree/Unit.hs view
@@ -1,19 +1,13 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeApplications #-} -module Test.Toml.PrefixTree.Unit- ( unitTests- ) where+module Test.Toml.PrefixTree.Unit where -import Test.Tasty (TestTree)-import Test.Tasty.Hspec (Spec, describe, it, shouldBe, testSpec)+import Test.Tasty.Hspec (Spec, describe, it, shouldBe) 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
+ test/Test/Toml/Property.hs view
@@ -0,0 +1,39 @@+module Test.Toml.Property+ ( assocLaw+ , identityLaw+ ) where++import Data.Semigroup (Semigroup ((<>)))+import Hedgehog (Gen, forAll, (===))++import Test.Toml.Gen (PropertyTest, prop)++{- | The semigroup associativity axiom:++@+x <> (y <> z) ≡ (x <> y) <> z+@++-}+assocLaw :: (Eq a, Show a, Semigroup a) => Gen a -> PropertyTest+assocLaw gen = prop "Semigroup associativity law" $ do+ x <- forAll gen+ y <- forAll gen+ z <- forAll gen++ (x <> (y <> z)) === ((x <> y) <> z)++{- | Identity law for Monoid++@+mempty <> x = x+x <> mempty = x+@++-}+identityLaw :: (Eq a, Show a, Semigroup a, Monoid a) => Gen a -> PropertyTest+identityLaw gen = prop "Monoid identity laws" $ do+ x <- forAll gen++ x <> mempty === x+ mempty <> x === x
+ test/Test/Toml/TOML/Property.hs view
@@ -0,0 +1,15 @@+module Test.Toml.TOML.Property where++import Test.Toml.Gen (PropertyTest, genToml)+import Test.Toml.Property (assocLaw, identityLaw)+++----------------------------------------------------------------------------+-- Laws+----------------------------------------------------------------------------++test_TomlAssocLaw :: PropertyTest+test_TomlAssocLaw = assocLaw genToml++test_TomlIdentityLaw :: PropertyTest+test_TomlIdentityLaw = identityLaw genToml
tomland.cabal view
@@ -1,5 +1,5 @@ name: tomland-version: 0.2.1+version: 0.3 synopsis: TOML parser description: See README.md for details. homepage: https://github.com/kowainik/tomland@@ -25,11 +25,16 @@ Toml.Bi.Code Toml.Bi.Combinators Toml.Bi.Monad+ Toml.Edsl Toml.Parser Toml.PrefixTree Toml.Printer+ Toml.Prism Toml.Type-+ Toml.Type.AnyValue+ Toml.Type.TOML+ Toml.Type.UValue+ Toml.Type.Value build-depends: base >= 4.9 && < 5 , hashable@@ -68,20 +73,26 @@ 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+ other-modules: Test.Toml.Property+ Test.Toml.Parsing.Property+ Test.Toml.Parsing.Unit+ Test.Toml.PrefixTree.Property+ Test.Toml.PrefixTree.Unit+ Test.Toml.TOML.Property + build-tool-depends: tasty-discover:tasty-discover build-depends: base , tomland , hedgehog+ , hspec-megaparsec+ , megaparsec , tasty , tasty-hedgehog , tasty-hspec , text+ , time , unordered-containers ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N