tomland 0.0.0 → 0.1.0

raw patch · 9 files changed

+289/−85 lines, 9 filessetup-changedPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Setup.hs +0/−2
• examples/Playground.hs +28/−28
• src/Toml.hs +2/−0
• src/Toml/Bi/Combinators.hs +113/−23
• src/Toml/Bi/Monad.hs +16/−0
• src/Toml/Parser.hs +8/−4
• src/Toml/PrefixTree.hs +16/−1
• src/Toml/Type.hs +101/−25
• tomland.cabal +5/−2

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -5,28 +5,31 @@  import Toml.Bi (BiToml, (.=)) import Toml.Parser (ParseException (..), parse)-import Toml.PrefixTree (Key (..), Piece (..), PrefixMap, fromList)+import Toml.PrefixTree (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-  }+    { testB :: Bool+    , testI :: Int+    , testF :: Double+    , testS :: Text+    , testA :: [Text]+    , testM :: Maybe Bool+    }  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+    <$> 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  main :: IO () main = do@@ -42,42 +45,39 @@     TIO.putStrLn "=== Testing bidirectional conversion ==="     biFile <- TIO.readFile "examples/biTest.toml"     case Toml.encode testT biFile of-        Left _     -> putStrLn "Some error"+        Left msg   -> print msg         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)])+    [ ("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-    [ ( key ["table", "name", "1"]+    [ ( "table.name.1"       , TOML (HashMap.fromList-            [ (key ["aInner"]   , AnyValue $ Int 1)-            , (key ["listInner"], AnyValue $ Array [Bool True, Bool False])+            [ ("aInner"   , AnyValue $ Int 1)+            , ("listInner", AnyValue $ Array [Bool True, Bool False])             ]) myInnerInnerToml       )-    , ( key ["table", "name", "2"]-      , TOML (HashMap.fromList [(key ["2Inner"], AnyValue $ Int 42)]) mempty+    , ( "table.name.2"+      , TOML (HashMap.fromList [("2Inner", AnyValue $ Int 42)]) mempty       )     ]   myInnerInnerToml :: PrefixMap TOML myInnerInnerToml = fromList-    [ ( key ["table", "name", "1", "1"]+    [ ( "table.name.1.1"       , TOML (HashMap.fromList-            [ (key ["aInner"]   , AnyValue $ Int 1)-            , (key ["listInner"], AnyValue $ Array [Bool True, Bool False])+            [ ("aInner"   , AnyValue $ Int 1)+            , ("listInner", AnyValue $ Array [Bool True, Bool False])             ]) mempty       )-    , ( key ["table", "name", "1", "2"]-      , TOML (HashMap.fromList [(key ["Inner1.2"], AnyValue $ Int 42)]) mempty+    , ( "table.name.1.2"+      , TOML (HashMap.fromList [("Inner1.2", AnyValue $ Int 42)]) mempty       )     ]

@@ -9,11 +9,13 @@ module Toml     ( module Toml.Bi     , module Toml.Parser+    , module Toml.PrefixTree     , module Toml.Printer     , module Toml.Type     ) where  import Toml.Bi import Toml.Parser+import Toml.PrefixTree import Toml.Printer import Toml.Type

@@ -1,4 +1,6 @@+{-# LANGUAGE DataKinds           #-} {-# LANGUAGE GADTs               #-}+{-# LANGUAGE KindSignatures      #-} {-# LANGUAGE Rank2Types          #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -21,23 +23,38 @@           -- * Converters        , bijectionMaker+       , dimapNum++         -- * Toml parsers        , bool        , int+       , integer        , double        , str+       , arrayOf+       , maybeP++         -- * Value parsers+       , Valuer (..)+       , boolV+       , integerV+       , doubleV+       , strV+       , arrV        ) where -import Control.Monad.Except (ExceptT, runExceptT, throwError)+import Control.Monad.Except (ExceptT, catchError, 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.Bi.Monad (Bi, Bijection (..), dimapBijection) import Toml.Parser (ParseException, parse) import Toml.PrefixTree (Key) import Toml.Printer (prettyToml)-import Toml.Type (AnyValue (..), TOML (..), Value (..))+import Toml.Type (AnyValue (..), TOML (..), Value (..), ValueType (..), matchArray, matchBool,+                  matchDouble, matchInteger, matchText)  import qualified Data.HashMap.Strict as HashMap @@ -61,7 +78,8 @@ -- This is @w@ type variable in 'Bijection' data type. type St = ExceptT DecodeException (State TOML) --- | Specialied for 'Toml' monad.+-- | Specialied 'Bi' type alias for 'Toml' monad. Keeps 'TOML' object either as+-- environment or state. type BiToml a = Bi Env St a  -- | Convert textual representation of toml into user data type.@@ -90,6 +108,10 @@ unsafeDecode :: BiToml a -> a -> Text unsafeDecode biToml text = fromRight (error "Unsafe decode") $ decode biToml text +----------------------------------------------------------------------------+-- Generalized versions of parsers+----------------------------------------------------------------------------+ -- | General function to create bidirectional converters for values. bijectionMaker :: forall a t .                  Text                              -- ^ Name of expected type@@ -116,34 +138,102 @@             Nothing -> a <$ modify (\(TOML vals nested) -> TOML (HashMap.insert key val vals) nested)             Just _  -> throwError $ DuplicateKey key val +-- | Helper dimapper to turn 'integer' parser into parser for 'Int', 'Natural', 'Word', etc.+dimapNum :: forall n r w . (Integral n, Functor r, Functor w)+         => Bi r w Integer+         -> Bi r w n+dimapNum = dimapBijection toInteger fromIntegral++----------------------------------------------------------------------------+-- 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+----------------------------------------------------------------------------+ -- | 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+bool = bijectionMaker "Boolean" matchBool Bool  -- | Parser for integer values.+integer :: Key -> BiToml Integer+integer = bijectionMaker "Int" matchInteger Int++-- | 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+int = dimapNum . integer  -- | 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+double = bijectionMaker "Double" matchDouble Float  -- | Parser for string values. str :: Key -> BiToml Text-str = bijectionMaker "String" fromString String+str = bijectionMaker "String" matchText String++-- TODO: implement using bijectionMaker+-- | Parser for array of values. Takes converter for single array element and+-- returns list of values.+arrayOf :: forall a t . Valuer t a -> Key -> BiToml [a]+arrayOf valuer key = Bijection input output   where-    fromString :: Value f -> Maybe Text-    fromString (String s) = Just s-    fromString _          = Nothing+    input :: Env [a]+    input = do+        mVal <- asks $ HashMap.lookup key . tomlPairs+        case mVal of+            Nothing -> throwError $ KeyNotFound key+            Just (AnyValue (Array arr)) -> case arr of+                [] -> pure []+                xs -> case mapM (valFrom valuer) xs of+                    Nothing   -> throwError $ TypeMismatch "Some type of element"  -- TODO: better type+                    Just vals -> pure vals+            Just _ -> throwError $ TypeMismatch "Array of smth"++    output :: [a] -> St [a]+    output a = do+        let val = AnyValue $ Array $ map (valTo valuer) 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++-- 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+    { biRead  = (Just <$> biRead bi) `catchError` handleNotFound+    , biWrite = \case+        Nothing -> pure Nothing+        Just v  -> biWrite bi v >> pure (Just v)+    }+  where+    handleNotFound :: EncodeException -> Env (Maybe a)+    handleNotFound (KeyNotFound _) = pure Nothing+    handleNotFound e               = throwError e

@@ -3,6 +3,7 @@ module Toml.Bi.Monad        ( Bijection (..)        , Bi+       , dimapBijection        , (.=)        ) where @@ -65,6 +66,21 @@         { biRead  = biRead bi >>= \a -> biRead (f a)         , biWrite = \c -> biWrite bi c >>= \a -> biWrite (f a) c         }++{- | This is an instance of 'Profunctor' for 'Bijection'. But since there's no+@Profunctor@ type class in @base@ or package with no dependencies (and we don't+want to bring extra dependencies) this instance is implemented as a single+top-level function.+-}+dimapBijection :: (Functor r, Functor w)+               => (c -> d)  -- ^ Mapper for consumer+               -> (a -> b)  -- ^ Mapper for producer+               -> Bijection r w d a  -- ^ Source 'Bijection' object+               -> Bijection r w c b+dimapBijection f g bi = Bijection+  { biRead  = g <$> biRead bi+  , biWrite = fmap g . biWrite bi . f+  }  {- | Operator to connect two operations: 

@@ -66,6 +66,10 @@     bareStrP :: Parser String     bareStrP = some $ alphaNumChar <|> char '_' <|> char '-' +literalStringP :: Parser Text+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 '"') @@ -92,7 +96,7 @@ -- dateTimeP = error "Not implemented!"  arrayP :: Parser [UValue]-arrayP = lexeme $ between (char '[') (char ']') (valueP `sepBy` spComma)+arrayP = lexeme $ between (char '[' *> space) (char ']') (valueP `sepBy` spComma)   where     spComma :: Parser ()     spComma = char ',' *> space@@ -101,7 +105,7 @@ valueP = UBool   <$> boolP      <|> UFloat  <$> try float      <|> UInt    <$> integer-     <|> UString <$> stringP+     <|> UString <$> (literalStringP <|> stringP) --     <|> UDate   <$> dateTimeP      <|> UArray  <$> arrayP @@ -113,8 +117,8 @@     text_ "="     uval <- valueP     case typeCheck uval of-        Nothing -> fail "Can't type check value!"-        Just v  -> pure (k, v)+        Left err -> fail $ show err+        Right v  -> pure (k, v)  tableHeaderP :: Parser (Key, TOML) tableHeaderP = do

@@ -24,16 +24,18 @@ import Prelude hiding (lookup)  import Control.Arrow ((&&&))+import Data.Coerce (coerce) import Data.Foldable (foldl') import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty (..))-import Data.String (IsString)+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+import qualified Data.Text as Text  -- | Represents the key piece of some layer. newtype Piece = Piece { unPiece :: Text }@@ -57,6 +59,19 @@     deriving (Show, Eq, Ord, Generic)  instance Hashable Key++{- | Split a dot-separated string into 'Key'. Empty string turns into a 'Key'+with single element - empty 'Piece'. This instance is not safe for now. Use+carefully. If you try to use as a key string like this @site.\"google.com\"@ you+will have list of three components instead of desired two.+-}+instance IsString Key where+    fromString :: String -> Key+    fromString = \case+        "" -> Key ("" :| [])+        s  -> case Text.splitOn "." (fromString s) of+            []   -> error "Text.splitOn returned empty string"  -- can't happen+            x:xs -> coerce @(NonEmpty Text) @Key (x :| xs)  pattern (:||) :: Piece -> [Piece] -> Key pattern x :|| xs <- ((NonEmpty.head &&& NonEmpty.tail) . unKey -> (x, xs))

@@ -2,18 +2,31 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs                     #-} {-# LANGUAGE KindSignatures            #-}+{-# LANGUAGE Rank2Types                #-} {-# LANGUAGE StandaloneDeriving        #-} {-# LANGUAGE TypeOperators             #-}  {- | Contains specification of TOML via Haskell ADT. -}  module Toml.Type-       ( TOML (..)-       , UValue (..)+       ( -- * Main type+         TOML (..)++         -- * Values        , ValueType (..)        , Value (..)        , AnyValue (..)+       , UValue (..)        , DateTime (..)+       , matchBool+       , matchInteger+       , matchDouble+       , matchText+       , matchDate+       , matchArray+       , valueType++         -- * Internal functions        , typeCheck        ) where @@ -32,9 +45,13 @@     -- tomlTableArrays :: HashMap Key (NonEmpty TOML)     } deriving (Show, Eq) --- Needed for GADT parameterization+-- | 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.@@ -114,11 +131,58 @@ 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+    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.@@ -191,35 +255,47 @@     (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 -> 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 :: 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-    []     -> justAny $ Array []-    (x:xs) -> do+    []   -> rightAny $ 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 :: 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 -justAny :: Value t -> Maybe AnyValue-justAny = Just . AnyValue+rightAny :: Value t -> Either l AnyValue+rightAny = Right . 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+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+                                         }

@@ -1,5 +1,5 @@ name:                tomland-version:             0.0.0+version:             0.1.0 description:         TOML parser synopsis:            TOML parser homepage:            https://github.com/kowainik/tomland@@ -13,7 +13,8 @@ build-type:          Simple extra-doc-files:     README.md cabal-version:       1.24-tested-with:         GHC == 8.2.2, GHC == 8.0.2+tested-with:         GHC == 8.2.2+                   , GHC == 8.0.2  library   hs-source-dirs:      src@@ -42,8 +43,10 @@   default-extensions:  DeriveGeneric                        GeneralizedNewtypeDeriving                        InstanceSigs+                       LambdaCase                        OverloadedStrings                        RecordWildCards+                       TypeApplications  executable play-tomland   main-is:             Playground.hs