diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +dist/ +dist-newstyle/ +shell.nix +cabal.project.local diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,92 @@ +# This Travis job script has been generated by a script via +# +# make_travis_yml_2.hs 'lens-toml-parser.cabal' +# +# For more information, see https://github.com/hvr/multi-ghc-travis +# +language: c +sudo: false + +git: + submodules: false # whether to recursively clone submodules + +cache: + directories: + - $HOME/.cabal/packages + - $HOME/.cabal/store + +before_cache: + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log + # remove files that are regenerated by 'cabal update' + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx + +matrix: + include: + - compiler: "ghc-8.0.2" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}} + - compiler: "ghc-8.2.1" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}} + +before_install: + - HC=${CC} + - HCPKG=${HC/ghc/ghc-pkg} + - unset CC + - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH + - PKGNAME='lens-toml-parser' + +install: + - cabal --version + - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" + - BENCH=${BENCH---enable-benchmarks} + - TEST=${TEST---enable-tests} + - HADDOCK=${HADDOCK-true} + - INSTALLED=${INSTALLED-true} + - travis_retry cabal update -v + - sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config + - rm -fv cabal.project.local + - "echo 'packages: .' > cabal.project" + - rm -f cabal.project.freeze + - cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all + - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 all + +# Here starts the actual work to be performed for the package under test; +# any command which exits with a non-zero exit code causes the build to fail. +script: + - if [ -f configure.ac ]; then autoreconf -i; fi + - rm -rf .ghc.environment.* dist/ + - cabal sdist # test that a source-distribution can be generated + - cd dist/ + - SRCTAR=(${PKGNAME}-*.tar.gz) + - SRC_BASENAME="${SRCTAR/%.tar.gz}" + - tar -xvf "./$SRC_BASENAME.tar.gz" + - cd "$SRC_BASENAME/" +## from here on, CWD is inside the extracted source-tarball + - rm -fv cabal.project.local + - "echo 'packages: .' > cabal.project" + # this builds all libraries and executables (without tests/benchmarks) + - rm -f cabal.project.freeze + - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all + # this builds all libraries and executables (including tests/benchmarks) + # - rm -rf ./dist-newstyle + + # Build with installed constraints for packages in global-db + - if $INSTALLED; then + echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks $(${HCPKG} list --global --simple-output --names-only | sed 's/\([a-zA-Z0-9-]\{1,\}\) */--constraint="\1 installed" /g') all | sh; + else echo "Not building with installed constraints"; fi + + # build & run tests, build benchmarks + - cabal new-build -w ${HC} ${TEST} ${BENCH} all + - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} all; fi + + # haddock + - rm -rf ./dist-newstyle + - if $HADDOCK; then cabal new-haddock -w ${HC} --disable-tests --disable-benchmarks all; else echo "Skipping haddock generation";fi + +# REGENDATA ["lens-toml-parser.cabal"] +# EOF diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for lens-toml-parser + +## 0.1.0.0 -- 2017-08-14 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +Copyright (c) 2017 Henry Till + +Permission to use, copy, modify, and/or distribute this software for any purpose +with or without fee is hereby granted, provided that the above copyright notice +and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH +REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, +INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS +OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF +THIS SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/example-v0.4.0.toml b/example/example-v0.4.0.toml new file mode 100644 --- /dev/null +++ b/example/example-v0.4.0.toml @@ -0,0 +1,246 @@ +################################################################################ +## Comment + +# Speak your mind with the hash symbol. They go from the symbol to the end of +# the line. + + +################################################################################ +## Table + +# Tables (also known as hash tables or dictionaries) are collections of +# key/value pairs. They appear in square brackets on a line by themselves. + +[table] + +key = "value" # Yeah, you can do this. + +# Nested tables are denoted by table names with dots in them. Name your tables +# whatever crap you please, just don't use #, ., [ or ]. + +[table.subtable] + +key = "another value" + +# You don't need to specify all the super-tables if you don't want to. TOML +# knows how to do it for you. + +# [x] you +# [x.y] don't +# [x.y.z] need these +[x.y.z.w] # for this to work + + +################################################################################ +## Inline Table + +# Inline tables provide a more compact syntax for expressing tables. They are +# especially useful for grouped data that can otherwise quickly become verbose. +# Inline tables are enclosed in curly braces `{` and `}`. No newlines are +# allowed between the curly braces unless they are valid within a value. + +[table.inline] + +name = { first = "Tom", last = "Preston-Werner" } +point = { x = 1, y = 2 } + + +################################################################################ +## String + +# There are four ways to express strings: basic, multi-line basic, literal, and +# multi-line literal. All strings must contain only valid UTF-8 characters. + +[string.basic] + +basic = "I'm a string. \"You can quote me\". Name\tJos\u00E9\nLocation\tSF." + +[string.multiline] + +# The following strings are byte-for-byte equivalent: +key1 = "One\nTwo" +key2 = """One\nTwo""" +key3 = """ +One +Two""" + +[string.multiline.continued] + +# The following strings are byte-for-byte equivalent: +key1 = "The quick brown fox jumps over the lazy dog." + +key2 = """ +The quick brown \ + + + fox jumps over \ + the lazy dog.""" + +key3 = """\ + The quick brown \ + fox jumps over \ + the lazy dog.\ + """ + +[string.literal] + +# What you see is what you get. +winpath = 'C:\Users\nodejs\templates' +winpath2 = '\\ServerX\admin$\system32\' +quoted = 'Tom "Dubs" Preston-Werner' +regex = '<\i\c*\s*>' + + +[string.literal.multiline] + +regex2 = '''I [dw]on't need \d{2} apples''' +lines = ''' +The first newline is +trimmed in raw strings. + All other whitespace + is preserved. +''' + + +################################################################################ +## Integer + +# Integers are whole numbers. Positive numbers may be prefixed with a plus sign. +# Negative numbers are prefixed with a minus sign. + +[integer] + +key1 = +99 +key2 = 42 +key3 = 0 +key4 = -17 + +[integer.underscores] + +# For large numbers, you may use underscores to enhance readability. Each +# underscore must be surrounded by at least one digit. +key1 = 1_000 +key2 = 5_349_221 +key3 = 1_2_3_4_5 # valid but inadvisable + + +################################################################################ +## Float + +# A float consists of an integer part (which may be prefixed with a plus or +# minus sign) followed by a fractional part and/or an exponent part. + +[float.fractional] + +key1 = +1.0 +key2 = 3.1415 +key3 = -0.01 + +[float.exponent] + +key1 = 5e+22 +key2 = 1e6 +key3 = -2E-2 + +[float.both] + +key = 6.626e-34 + +[float.underscores] + +key1 = 9_224_617.445_991_228_313 +key2 = 1e1_000 + + +################################################################################ +## Boolean + +# Booleans are just the tokens you're used to. Always lowercase. + +[boolean] + +True = true +False = false + + +################################################################################ +## Datetime + +# Datetimes are RFC 3339 dates. + +[datetime] + +key1 = 1979-05-27T07:32:00Z +key2 = 1979-05-27T00:32:00-07:00 +key3 = 1979-05-27T00:32:00.999999-07:00 + + +################################################################################ +## Array + +# Arrays are square brackets with other primitives inside. Whitespace is +# ignored. Elements are separated by commas. Data types may not be mixed. + +[array] + +key1 = [ 1, 2, 3 ] +key2 = [ "red", "yellow", "green" ] +key3 = [ [ 1, 2 ], [3, 4, 5] ] +key4 = [ [ 1, 2 ], ["a", "b", "c"] ] # this is ok + +# Arrays can also be multiline. So in addition to ignoring whitespace, arrays +# also ignore newlines between the brackets. Terminating commas are ok before +# the closing bracket. + +key5 = [ + 1, 2, 3 +] +key6 = [ + 1, + 2, # this is ok +] + + +################################################################################ +## Array of Tables + +# These can be expressed by using a table name in double brackets. Each table +# with the same double bracketed name will be an element in the array. The +# tables are inserted in the order encountered. + +[[products]] + +name = "Hammer" +sku = 738594937 + +[[products]] + +[[products]] + +name = "Nail" +sku = 284758393 +color = "gray" + + +# You can create nested arrays of tables as well. + +[[fruit]] + name = "apple" + +## toml-parser does handle the following: +# +# [fruit.physical] +# color = "red" +# shape = "round" +# +# [[fruit.variety]] +# name = "red delicious" +# +# [[fruit.variety]] +# name = "granny smith" +# +# [[fruit]] +# name = "banana" +# +# [[fruit.variety]] +# name = "plantain" diff --git a/lens-toml-parser.cabal b/lens-toml-parser.cabal new file mode 100644 --- /dev/null +++ b/lens-toml-parser.cabal @@ -0,0 +1,62 @@ +-- Initial lens-toml-parser.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: lens-toml-parser +version: 0.1.0.0 +synopsis: Lenses for toml-parser +description: Lenses for toml-parser +license: ISC +license-file: LICENSE +author: Henry Till +maintainer: henrytill@gmail.com +homepage: https://github.com/xngns/lens-toml-parser +copyright: Copyright (c) 2017, Henry Till +category: Language, Lenses +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC == 8.0.2, GHC == 8.2.1 + +extra-source-files: + .gitignore + .travis.yml + ChangeLog.md + example/example-v0.4.0.toml + +source-repository head + type: git + location: https://github.com/xngns/lens-toml-parser.git + +library + exposed-modules: TOML.Lens + -- other-modules: + -- other-extensions: + build-depends: base >=4.8 && <4.11 + , text >=1.2 && <1.3 + , time >=1.5 && <1.9 + , profunctors >=5.2 && <5.3 + , toml-parser >=0.1 && <0.2 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + build-depends: base >=4.8 && <4.11 + , containers >=0.5 && <0.6 + , text >=1.2 && <1.3 + , dwergaz >=0.2 && <0.3 + , toml-parser >=0.1 && <0.2 + , lens-simple >=0.1 && <0.2 + , lens-toml-parser + hs-source-dirs: tests + default-language: Haskell2010 + ghc-options: -Wall + +test-suite hlint + type: exitcode-stdio-1.0 + main-is: HLint.hs + build-depends: base + , hlint >= 1.9 + hs-source-dirs: tests + default-language: Haskell2010 diff --git a/src/TOML/Lens.hs b/src/TOML/Lens.hs new file mode 100644 --- /dev/null +++ b/src/TOML/Lens.hs @@ -0,0 +1,150 @@ +-- | +-- Module : TOML.Lens +-- Description : Lenses for toml-parser +-- Copyright : (c) 2017, Henry Till +-- License : ISC +-- Maintainer : henrytill@gmail.com +-- Stability : experimental +-- +-- Lenses for . +-- +module TOML.Lens + ( _Table + , _List + , _Double + , _Integer + , _String + , _Bool + , _ZonedTimeV + , _LocalTimeV + , _DayV + , _TimeOfDayV + ) where + +import Data.Profunctor +import qualified Data.Text as T +import Data.Time + +import TOML + +-- +-- With help from: +-- +-- +-- @ +-- type Prism s t a b = (Choice p, Applicative f) => p a (f b) -> p s (f t) +-- @ +-- +-- @ +-- type Prism' s a = Prism s s a a +-- @ +-- + +prism + :: (Choice p, Applicative f) + => (b -> t) + -> (s -> Either t a) + -> p a (f b) + -> p s (f t) +prism bt seta = dimap seta (either pure (fmap bt)) . right' +{-# INLINE prism #-} + +-- | @_Table :: Prism' Value [(Text, Value)]@ +_Table + :: (Choice p, Applicative f) + => p [(T.Text, Value)] (f [(T.Text, Value)]) + -> p Value (f Value) +_Table = + prism Table $ \ n -> case n of + Table v -> pure v + _ -> Left n + +-- | @_List :: Prism' Value [Value]@ +_List + :: (Choice p, Applicative f) + => p [Value] (f [Value]) + -> p Value (f Value) +_List = + prism List $ \ n -> case n of + List v -> pure v + _ -> Left n + +-- | @_Double :: Prism' Value Double@ +_Double + :: (Choice p, Applicative f) + => p Double (f Double) + -> p Value (f Value) +_Double = + prism Double $ \ n -> case n of + Double v -> pure v + _ -> Left n + +-- | @_Integer :: Prism' Value Integer@ +_Integer + :: (Choice p, Applicative f) + => p Integer (f Integer) + -> p Value (f Value) +_Integer = + prism Integer $ \ n -> case n of + Integer v -> pure v + _ -> Left n + +-- | @_String :: Prism' Value T.Text@ +_String + :: (Choice p, Applicative f) + => p T.Text (f T.Text) + -> p Value (f Value) +_String = + prism String $ \ n -> case n of + String v -> pure v + _ -> Left n + +-- | @_Bool :: Prism' Value Bool@ +_Bool + :: (Choice p, Applicative f) + => p Bool (f Bool) + -> p Value (f Value) +_Bool = + prism Bool $ \ n -> case n of + Bool v -> pure v + _ -> Left n + +-- | @_ZonedTimeV :: Prism' Value ZonedTime@ +_ZonedTimeV + :: (Choice p, Applicative f) + => p ZonedTime (f ZonedTime) + -> p Value (f Value) +_ZonedTimeV = + prism ZonedTimeV $ \ n -> case n of + ZonedTimeV v -> pure v + _ -> Left n + +-- | @_LocalTimeV :: Prism' Value LocalTime@ +_LocalTimeV + :: (Choice p, Applicative f) + => p LocalTime (f LocalTime) + -> p Value (f Value) +_LocalTimeV = + prism LocalTimeV $ \ n -> case n of + LocalTimeV v -> pure v + _ -> Left n + +-- | @_DayV :: Prism' Value Day@ +_DayV + :: (Choice p, Applicative f) + => p Day (f Day) + -> p Value (f Value) +_DayV = + prism DayV $ \ n -> case n of + DayV v -> pure v + _ -> Left n + +-- | @_TimeOfDayV :: Prism' Value TimeOfDay@ +_TimeOfDayV + :: (Choice p, Applicative f) + => p TimeOfDay (f TimeOfDay) + -> p Value (f Value) +_TimeOfDayV = + prism TimeOfDayV $ \ n -> case n of + TimeOfDayV v -> pure v + _ -> Left n diff --git a/tests/HLint.hs b/tests/HLint.hs new file mode 100644 --- /dev/null +++ b/tests/HLint.hs @@ -0,0 +1,12 @@ +module Main (main) where + +import Control.Monad +import Language.Haskell.HLint3 +import System.Environment +import System.Exit + +main :: IO () +main = do + args <- getArgs + hints <- hlint $ ["src", "tests"] ++ args + unless (null hints) exitFailure diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Control.Monad (unless) +import qualified Data.Map.Lazy as Map +import qualified Data.Text as T +import Data.Text.IO (readFile) +import Lens.Simple +import Prelude hiding (readFile) +import System.Exit (exitFailure) +import Test.Dwergaz +import qualified TOML +import TOML.Lens + + +alist :: Ord k => [(k, v)] -> Map.Map k v +alist = Map.fromList + +alistLens + :: (Ord k1, Ord k2, Functor f) + => LensLike f [(k1, v1)] [(k2, v2)] (Map.Map k1 v1) (Map.Map k2 v2) +alistLens = iso Map.fromList Map.toList + +mapAt + :: Applicative f + => T.Text + -> (Map.Map T.Text TOML.Value -> f (Map.Map T.Text TOML.Value)) + -> Map.Map T.Text TOML.Value + -> f (Map.Map T.Text TOML.Value) +mapAt k = at k . _Just . _Table . alistLens + +listAt + :: Applicative f + => T.Text + -> ([TOML.Value] -> f [TOML.Value]) + -> Map.Map T.Text TOML.Value + -> f (Map.Map T.Text TOML.Value) +listAt k = at k . _Just . _List + +testTableKey :: [(T.Text, TOML.Value)] -> Test +testTableKey kv + = Expect "'key' from 'table' == Just \"value\"" + (==) expected actual + where + expected = Just "value" + actual = alist kv ^? mapAt "table" . at "key" . _Just . _String + +testTableZoo :: [(T.Text, TOML.Value)] -> Test +testTableZoo kv + = Expect "'zoo' from 'table' == Nothing" + (==) expected actual + where + expected = Nothing + actual = alist kv ^? mapAt "table" . at "zoo" . _Just . _String + +testTableSubtableKey :: [(T.Text, TOML.Value)] -> Test +testTableSubtableKey kv + = Expect "'key' from 'subtable' from 'table' == Just \"another value\"" + (==) expected actual + where + expected = Just "another value" + actual = alist kv ^? mapAt "table" . mapAt "subtable" . at "key" . _Just . _String + +testTableInlineNameFirst :: [(T.Text, TOML.Value)] -> Test +testTableInlineNameFirst kv + = Expect "'first' from 'name' from 'inline' from 'table' == \"Tom\"" + (==) expected actual + where + expected = Just "Tom" + actual = alist kv ^? mapAt "table" . mapAt "inline" . mapAt "name" . at "first" . _Just . _String + +testTableInlinePointY :: [(T.Text, TOML.Value)] -> Test +testTableInlinePointY kv + = Expect "'y' from 'point' from 'inline' from 'table' == Just 2" + (==) expected actual + where + expected = Just 2 + actual = alist kv ^? mapAt "table" . mapAt "inline" . mapAt "point" . at "y" . _Just . _Integer + +testStringBasicBasic :: [(T.Text, TOML.Value)] -> Test +testStringBasicBasic kv + = Expect "'basic' from 'basic' from 'string' == " + (==) expected actual + where + expected = Just "I'm a string. \"You can quote me\". Name\tJos\233\nLocation\tSF." + actual = alist kv ^? mapAt "string" . mapAt "basic" . at "basic" . _Just . _String + +testStringMultiline :: [(T.Text, TOML.Value)] -> Test +testStringMultiline kv + = Predicate "'key1', 'key2', and 'key3' from 'multiline' from 'string' are all the same" + (\ xs -> all (== head xs) (tail xs)) + [actual1, actual2, actual3] + where + actual1 = alist kv ^? mapAt "string" . mapAt "multiline" . at "key1" . _Just . _String + actual2 = alist kv ^? mapAt "string" . mapAt "multiline" . at "key2" . _Just . _String + actual3 = alist kv ^? mapAt "string" . mapAt "multiline" . at "key3" . _Just . _String + +testStringMultilineContinued :: [(T.Text, TOML.Value)] -> Test +testStringMultilineContinued kv + = Predicate "'key1', 'key2', and 'key3' from 'continued' from 'multiline' from 'string' are all the same" + (\ xs -> all (== head xs) (tail xs)) + [actual1, actual2, actual3] + where + actual1 = alist kv ^? mapAt "string" . mapAt "multiline" . mapAt "continued" . at "key1" . _Just . _String + actual2 = alist kv ^? mapAt "string" . mapAt "multiline" . mapAt "continued" . at "key2" . _Just . _String + actual3 = alist kv ^? mapAt "string" . mapAt "multiline" . mapAt "continued" . at "key3" . _Just . _String + +testArrayKey1 :: [(T.Text, TOML.Value)] -> Test +testArrayKey1 kv + = Expect "'key1' from 'array' == [1, 2, 3]" + (==) expected actual + where + expected = [1, 2, 3] + actual = alist kv ^.. mapAt "array" . listAt "key1" . traverse . _Integer + +runTests :: [(T.Text, TOML.Value)] -> [Result] +runTests kv = runTest . ($ kv) <$> tests + where + tests = [ testTableKey + , testTableZoo + , testTableSubtableKey + , testTableInlineNameFirst + , testTableInlinePointY + , testStringBasicBasic + , testStringMultiline + , testStringMultilineContinued + , testArrayKey1 + ] + +readTOMLFile :: String -> IO [(T.Text, TOML.Value)] +readTOMLFile file = readFile file >>= parse >>= handleError + where + parse = pure . TOML.parseTOML + handleError = either (error . show) pure + +main :: IO () +main = do + ex <- readTOMLFile "./example/example-v0.4.0.toml" + rs <- pure (runTests ex) + _ <- mapM_ print rs + unless (all isPassed rs) exitFailure