diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/examples/Playground.hs b/examples/Playground.hs --- a/examples/Playground.hs +++ b/examples/Playground.hs @@ -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 ) ] diff --git a/src/Toml.hs b/src/Toml.hs --- a/src/Toml.hs +++ b/src/Toml.hs @@ -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 diff --git a/src/Toml/Bi/Combinators.hs b/src/Toml/Bi/Combinators.hs --- a/src/Toml/Bi/Combinators.hs +++ b/src/Toml/Bi/Combinators.hs @@ -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 diff --git a/src/Toml/Bi/Monad.hs b/src/Toml/Bi/Monad.hs --- a/src/Toml/Bi/Monad.hs +++ b/src/Toml/Bi/Monad.hs @@ -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: diff --git a/src/Toml/Parser.hs b/src/Toml/Parser.hs --- a/src/Toml/Parser.hs +++ b/src/Toml/Parser.hs @@ -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 diff --git a/src/Toml/PrefixTree.hs b/src/Toml/PrefixTree.hs --- a/src/Toml/PrefixTree.hs +++ b/src/Toml/PrefixTree.hs @@ -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)) diff --git a/src/Toml/Type.hs b/src/Toml/Type.hs --- a/src/Toml/Type.hs +++ b/src/Toml/Type.hs @@ -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 + } diff --git a/tomland.cabal b/tomland.cabal --- a/tomland.cabal +++ b/tomland.cabal @@ -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