diff --git a/bench/SalakYamlBench.hs b/bench/SalakYamlBench.hs new file mode 100644 --- /dev/null +++ b/bench/SalakYamlBench.hs @@ -0,0 +1,14 @@ +module SalakYamlBench where + +import Criterion.Main +import Salak +import Salak.Yaml + + +main = defaultMain + [ bgroup "load" + [ bench "loadYaml" $ whnfIO $ loadAndRunSalak (loadYaml "salak.yml") action + ] + ] + +action = return () diff --git a/salak-yaml.cabal b/salak-yaml.cabal --- a/salak-yaml.cabal +++ b/salak-yaml.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: salak-yaml -version: 0.3.4 +version: 0.3.4.1 license: MIT license-file: LICENSE copyright: 2019 Daniel YU @@ -12,7 +12,7 @@ build-type: Simple extra-source-files: README.md - test/salak.yml + salak.yml library exposed-modules: @@ -22,28 +22,29 @@ Paths_salak_yaml default-language: Haskell2010 default-extensions: RecordWildCards TupleSections OverloadedStrings - ScopedTypeVariables FlexibleInstances MultiParamTypeClasses - DeriveGeneric + NoOverloadedLists ScopedTypeVariables FlexibleInstances + MultiParamTypeClasses DeriveGeneric FlexibleContexts RankNTypes ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures build-depends: base >=4.10 && <5, conduit >=1.3.1.1 && <1.4, libyaml >=0.1.1.0 && <0.2, - salak >=0.3.4 && <0.4, + salak >=0.3.4.1 && <0.4, text >=1.2.3.1 && <1.3 -test-suite spec +test-suite salak-yaml-spec type: exitcode-stdio-1.0 - main-is: Spec.hs + main-is: SalakYamlSpec.hs hs-source-dirs: test src other-modules: Salak.Yaml Paths_salak_yaml default-language: Haskell2010 default-extensions: RecordWildCards TupleSections OverloadedStrings - ScopedTypeVariables FlexibleInstances MultiParamTypeClasses - DeriveGeneric + NoOverloadedLists ScopedTypeVariables FlexibleInstances + MultiParamTypeClasses DeriveGeneric FlexibleContexts RankNTypes ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures + -main-is SalakYamlSpec.main build-depends: QuickCheck >=2.13.2 && <2.14, base >=4.10 && <5, @@ -52,5 +53,26 @@ hspec ==2.*, libyaml >=0.1.1.0 && <0.2, mtl >=2.2.2 && <2.3, - salak >=0.3.4 && <0.4, + salak >=0.3.4.1 && <0.4, + text >=1.2.3.1 && <1.3 + +benchmark salak-yaml-bench + type: exitcode-stdio-1.0 + main-is: SalakYamlBench.hs + hs-source-dirs: bench src + other-modules: + Salak.Yaml + Paths_salak_yaml + default-language: Haskell2010 + default-extensions: RecordWildCards TupleSections OverloadedStrings + NoOverloadedLists ScopedTypeVariables FlexibleInstances + MultiParamTypeClasses DeriveGeneric FlexibleContexts RankNTypes + ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures + -main-is SalakYamlBench.main -rtsopts -threaded -with-rtsopts=-K1K + build-depends: + base >=4.10 && <5, + conduit >=1.3.1.1 && <1.4, + criterion >=1.5.5.0 && <1.6, + libyaml >=0.1.1.0 && <0.2, + salak >=0.3.4.1 && <0.4, text >=1.2.3.1 && <1.3 diff --git a/salak.yml b/salak.yml new file mode 100644 --- /dev/null +++ b/salak.yml @@ -0,0 +1,20 @@ +array: + - a + - b + - d + - c +hello: + world +a: + b: c + +me.icymint.conf: + name: daniel + age: 18 + male: yes + det: + hello: abc + +xyz: + - bcd: hello + - bcd: world diff --git a/src/Salak/Yaml.hs b/src/Salak/Yaml.hs --- a/src/Salak/Yaml.hs +++ b/src/Salak/Yaml.hs @@ -4,7 +4,7 @@ -- | -- Module: Salak.Yaml -- Copyright: (c) 2019 Daniel YU --- License: BSD3 +-- License: MIT -- Maintainer: leptonyu@gmail.com -- Stability: experimental -- Portability: portable @@ -42,14 +42,17 @@ loadYAML :: MonadIO m => Int -> TraceSource -> ConduitM MarkedEvent o m TraceSource loadYAML i = start where + {-# INLINE start #-} start ts = await >>= maybe (return ts) (go ts) + {-# INLINE go #-} go _ (MarkedEvent (EventAlias a) _ ee) = ge ee $ "alias " ++ a ++ " not supported by salak" go ts (MarkedEvent (EventScalar a _ _ _) _ _) = return $ setVal i a ts go ts (MarkedEvent EventSequenceStart{} _ _) = goS 0 ts go ts (MarkedEvent EventMappingStart{} _ _) = goM ts go ts _ = start ts + {-# INLINE goS #-} goS j ts = do v <- await case v of @@ -59,6 +62,7 @@ val <- go T.empty e goS (j+1) (T.modify (KI j) (const val) ts) + {-# INLINE goM #-} goM ts = do v <- await case v of @@ -66,7 +70,9 @@ Just (MarkedEvent EventMappingEnd _ _) -> return ts Just (MarkedEvent (EventScalar a _ _ _) _ _) -> do val <- start T.empty - goM $ T.modify' (simpleKeys $ decodeUtf8 a) (const val) ts + goM $ T.modify' (const val) (simpleKeys $ decodeUtf8 a) ts Just e -> ge (yamlStartMark e) ("suppose scalar and mapping end, but is " ++ show (yamlEvent e)) + + {-# INLINE ge #-} ge YamlMark{..} e = liftIO $ throwIO $ YamlException $ "(" ++ show yamlLine ++ "," ++ show yamlColumn ++ ")" ++ e diff --git a/test/SalakYamlSpec.hs b/test/SalakYamlSpec.hs new file mode 100644 --- /dev/null +++ b/test/SalakYamlSpec.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module SalakYamlSpec where + +import Control.Monad.Reader +import Data.List (intercalate) +import Data.Text (Text, pack) +import Debug.Trace +import GHC.Generics +import Salak +import Salak.Internal +import Salak.Yaml +import Test.Hspec +import Test.QuickCheck + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Salak.Yaml" jsonProperty + +newtype SKey = SKey { unKey :: Text } deriving Show + +instance Arbitrary SKey where + arbitrary = do + key <- choose (1,20) + vs <- vectorOf key $ do + k <- choose (1,20) + v <- vectorOf k $ choose ('a','z') + b <- choose (0,10) :: Gen Int + if b > 0 then return v else do + x <- choose (0,10) :: Gen Int + return (v ++ "[" ++ show x ++ "]") + return (SKey $ pack $ intercalate "." vs) + +data Conf = Conf + { name :: String + , age :: Int + , male :: Bool + , det :: SubConf + } deriving (Eq, Show, Generic) + +data SubConf = SubConf + { hello :: String } deriving (Eq, Show, Generic) + +instance FromProp m SubConf where + fromProp = SubConf <$> "hello" .?= "yyy" + +instance FromProp m Conf + +jsonProperty :: SpecWith () +jsonProperty = do + context "load json" $ do + it "salak.yml" $ do + loadAndRunSalak (loadYaml "salak.yml") $ do + SourcePack{..} <- ask + as <- trace (show source) $ require "array" + cf <- require "me.icymint.conf" + lift $ do + as `shouldBe` (["a","b","d","c"] :: [String]) + name cf `shouldBe` "daniel" + age cf `shouldBe` 18 + male cf `shouldBe` True + det cf `shouldBe` SubConf "abc" + + + + + diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Main where - -import Control.Monad.Reader -import Data.List (intercalate) -import Data.Text (Text, pack) -import Debug.Trace -import GHC.Generics -import Salak -import Salak.Internal -import Salak.Yaml -import Test.Hspec -import Test.QuickCheck - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "Salak.Yaml" jsonProperty - -newtype SKey = SKey { unKey :: Text } deriving Show - -instance Arbitrary SKey where - arbitrary = do - key <- choose (1,20) - vs <- vectorOf key $ do - k <- choose (1,20) - v <- vectorOf k $ choose ('a','z') - b <- choose (0,10) :: Gen Int - if b > 0 then return v else do - x <- choose (0,10) :: Gen Int - return (v ++ "[" ++ show x ++ "]") - return (SKey $ pack $ intercalate "." vs) - -data Conf = Conf - { name :: String - , age :: Int - , male :: Bool - , det :: SubConf - } deriving (Eq, Show, Generic) - -data SubConf = SubConf - { hello :: String } deriving (Eq, Show, Generic) - -instance FromProp m SubConf where - fromProp = SubConf <$> "hello" .?= "yyy" - -instance FromProp m Conf - -jsonProperty :: SpecWith () -jsonProperty = do - context "load json" $ do - it "salak.yml" $ do - loadAndRunSalak (loadYaml "test/salak.yml") $ do - SourcePack{..} <- ask - as <- trace (show source) $ require "array" - cf <- require "me.icymint.conf" - lift $ do - as `shouldBe` ["a","b","d","c" :: String] - name cf `shouldBe` "daniel" - age cf `shouldBe` 18 - male cf `shouldBe` True - det cf `shouldBe` SubConf "abc" - - - - - diff --git a/test/salak.yml b/test/salak.yml deleted file mode 100644 --- a/test/salak.yml +++ /dev/null @@ -1,20 +0,0 @@ -array: - - a - - b - - d - - c -hello: - world -a: - b: c - -me.icymint.conf: - name: daniel - age: 18 - male: yes - det: - hello: abc - -xyz: - - bcd: hello - - bcd: world