[#8] Create EDSL for tomland

CHANGELOG.md

@@ -4,6 +4,12 @@ Change log
 tomland uses [PVP Versioning][1].
 The change log is available [on GitHub][2].
 
+0.2.2
+=====
+
+* [#8](https://github.com/kowainik/tomland/issues/8):
+  Create EDSL for easier TOML data type writing.
+
 0.2.1
 =====
 * Make `table` parser work with `maybeP`.

examples/Playground.hs

@@ -4,12 +4,11 @@ import Data.Text (Text)
 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
 
@@ -58,35 +57,17 @@ main = do
         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/Bi/Combinators.hs

@@ -46,8 +46,9 @@ import Toml.Bi.Code (BiToml, DecodeException (..), Env, St)
 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.Type (AnyValue (..), TOML (..), Value (..), ValueType (..), emptyToml, insertKeyVal,
+                  insertTable, matchArray, matchBool, matchDouble, matchInteger, matchText,
+                  valueType)
 
 import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Text as Text
@@ -78,9 +79,7 @@ bijectionMaker fromVal toVal key = Bijection input output
                 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)
@@ -231,9 +230,9 @@ table bi key = Bijection input output
     output :: a -> St a
     output a = do
         mTable <- gets $ Prefix.lookup key . tomlTables
-        let toml = fromMaybe (TOML mempty mempty) mTable
+        let toml = fromMaybe emptyToml 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

@@ -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, emptyToml, insertKeyVal, insertTable)
+
+
+type TDSL = State TOML ()
+
+-- | Creates 'TOML' from the 'TDSL'.
+mkToml :: TDSL -> TOML
+mkToml env = execState env emptyToml
+
+-- | 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 env = modify $ insertTable k (mkToml env)

src/Toml/Type.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds                 #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances         #-}
 {-# LANGUAGE GADTs                     #-}
 {-# LANGUAGE KindSignatures            #-}
 {-# LANGUAGE Rank2Types                #-}
@@ -11,6 +12,9 @@
 module Toml.Type
        ( -- * Main type
          TOML (..)
+       , emptyToml
+       , insertKeyVal
+       , insertTable
 
          -- * Values
        , ValueType (..)
@@ -32,12 +36,16 @@ module Toml.Type
        ) where
 
 import Data.HashMap.Strict (HashMap)
+import Data.String (IsString (..))
 import Data.Text (Text)
 import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime, zonedTimeToUTC)
 import Data.Type.Equality ((:~:) (..))
 
 import Toml.PrefixTree (Key (..), PrefixMap)
 
+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
@@ -46,6 +54,19 @@ data TOML = TOML
     -- tomlTableArrays :: HashMap Key (NonEmpty TOML)
     } deriving (Show, Eq)
 
+emptyToml :: TOML
+emptyToml = 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)
+    }
+
 -- | Needed for GADT parameterization
 data ValueType = TBool | TInt | TFloat | TString | TDate | TArray
     deriving (Eq, Show)
@@ -121,6 +142,18 @@ arr6 = [ 1, 2.0 ] # INVALID
     Array  :: [Value t] -> Value 'TArray
 
 deriving instance Show (Value t)
+
+instance (t ~ 'TInt) => Num (Value t) where
+    (Int a) + (Int b) = Int $ a + b
+    (Int a) * (Int b) = Int $ a * b
+    abs (Int a) = Int (abs a)
+    signum (Int a) = Int (signum a)
+    fromInteger = Int
+    negate (Int a) = Int (negate a)
+
+instance (t ~ 'TString) => IsString (Value t) where
+    fromString = String . fromString @Text
+
 instance Eq (Value t) where
     (Bool b1)   == (Bool b2)   = b1 == b2
     (Int i1)    == (Int i2)    = i1 == i2

tomland.cabal

@@ -1,5 +1,5 @@
 name:                tomland
-version:             0.2.1
+version:             0.2.2
 synopsis:            TOML parser
 description:         See README.md for details.
 homepage:            https://github.com/kowainik/tomland
@@ -25,6 +25,7 @@ library
                            Toml.Bi.Code
                            Toml.Bi.Combinators
                            Toml.Bi.Monad
+                         Toml.Edsl
                          Toml.Parser
                          Toml.PrefixTree
                          Toml.Printer