Add TOML import

package.yaml

@@ -52,6 +52,7 @@ library:
     - split
     - strict
     - text
+    - tomland
     - transformers
     - unix
     - unordered-containers
@@ -100,6 +101,7 @@ tests:
       - pretty
       - scientific
       - text
+      - tomland
       - unordered-containers
       - vector
       - yaml

src/Eucalypt/Driver/Evaluator.hs

@@ -48,6 +48,7 @@ import qualified Eucalypt.Driver.Stg as STG
 import Eucalypt.Reporting.Error (EucalyptError(..))
 import Eucalypt.Reporting.Report (reportErrors)
 import Eucalypt.Source.Error (DataParseException(..))
+import Eucalypt.Source.TomlSource
 import Eucalypt.Source.YamlSource
 import Eucalypt.Syntax.Ast (Unit, Expression)
 import Eucalypt.Syntax.Error (SyntaxError(..))
@@ -112,8 +113,9 @@ parseInputToCore :: Input -> IO (Either EucalyptError TranslationUnit)
 parseInputToCore i@(Input locator name format) = do
   source <- readInput locator
   case format of
+    "toml" -> tomlDataToCore source
     "yaml" -> activeYamlToCore source
-    "json" -> dataToCore source
+    "json" -> yamlDataToCore source
     "eu" -> eucalyptToCore source
     _ -> (return . Left . Command . InvalidInput) i
   where
@@ -122,11 +124,12 @@ parseInputToCore i@(Input locator name format) = do
       case parseEucalypt text (show locator) of
         Left e -> (return . Left . Syntax) e
         Right expr -> (return . Right . maybeApplyName . translateToCore) expr
-    dataToCore text = do
+    yamlDataToCore text = do
       r <- try (parseYamlData text) :: IO (Either DataParseException CoreExpr)
       case r of
         Left e -> (return . Left . Source) e
         Right core -> (return . Right . maybeApplyName . dataUnit) core
+    tomlDataToCore text = parseTomlData text >>= (return . Right <$> dataUnit)
     activeYamlToCore text = do
       r <- try (parseYamlExpr text) :: IO (Either DataParseException CoreExpr)
       case r of

src/Eucalypt/Source/Error.hs

@@ -10,6 +10,7 @@ data DataParseException
   = UnexpectedEndOfEvents
   | UnexpectedEvent Event
   | FromYamlException Text
+  | FromTomlException Text
   deriving (Show, Typeable)
 
 instance Exception DataParseException

src/Eucalypt/Source/TomlSource.hs

@@ -0,0 +1,86 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RecordWildCards #-}
+{-|
+Module      : Eucalypt.Source.TomlSource
+Description : Ingest TOML into core syntax
+Copyright   : (c) Greg Hawkins, 2018
+License     :
+Maintainer  : greg@curvelogic.co.uk
+Stability   : experimental
+-}
+module Eucalypt.Source.TomlSource where
+
+import Control.Exception.Safe
+import qualified Data.ByteString as BS
+import qualified Data.HashMap.Strict as HM
+import Data.List (intercalate)
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Text (unpack)
+import Data.Text.Encoding (decodeUtf8)
+import Eucalypt.Core.Syn
+import Eucalypt.Source.Error
+import qualified Toml
+
+-- | Convert a TOML primitive to a core expression
+--
+tomlValue :: Toml.Value t -> CoreExpr
+tomlValue (Toml.Bool b) = corebool b
+tomlValue (Toml.Integer n) = int n
+tomlValue (Toml.Double d) = float d
+tomlValue (Toml.Text s) = (str . unpack) s
+tomlValue (Toml.Date d) =
+  withMeta
+    (block [element "toml" $ block [element "type" $ sym "date"]])
+    (str $ show d)
+tomlValue (Toml.Array a) = CoreList $ map tomlValue a
+
+pieceToBindingName :: Toml.Piece -> CoreBindingName
+pieceToBindingName = unpack . Toml.unPiece
+
+keyToBindingName :: Toml.Key -> CoreBindingName
+keyToBindingName (Toml.Key k) =
+  intercalate "." $ map pieceToBindingName (NonEmpty.toList k)
+
+-- | Translate a prefix tree into a list of blocks that can be
+-- concatenated
+translatePrefixTree :: Toml.PrefixTree Toml.TOML -> CoreExpr
+translatePrefixTree (Toml.Leaf k a) =
+  inPrefixBlocks k $ translateToml a
+translatePrefixTree Toml.Branch {..} =
+  inPrefixBlocks bCommonPref $ translatePrefixMap bPrefixMap
+
+-- | Translate a prefix map
+translatePrefixMap :: Toml.PrefixMap Toml.TOML -> CoreExpr
+translatePrefixMap m =
+  block
+    [ element (pieceToBindingName k) $ translatePrefixTree v
+    | (k, v) <- HM.toList m
+    ]
+
+-- | Return expression wrapped in enough blocks to represent the
+-- prefix
+inPrefixBlocks :: Toml.Prefix -> CoreExpr -> CoreExpr
+inPrefixBlocks k ex = foldr wrap ex names
+  where
+    wrap l r = block [element l r]
+    names = map pieceToBindingName (NonEmpty.toList . Toml.unKey $ k)
+
+-- | Translate a TOML file into a 'CoreExpr'
+--
+translateToml :: Toml.TOML -> CoreExpr
+translateToml Toml.TOML {..} = foldl1 collapse (pairBlocks ++ tables)
+  where
+    pairBlocks = map kvBlock $ HM.toList tomlPairs
+    tables = map translatePrefixTree $ HM.elems tomlTables
+    kvBlock (k, Toml.AnyValue val) = inPrefixBlocks k $ tomlValue val
+    collapse (CoreBlock (CoreList l)) (CoreBlock (CoreList r)) =
+      CoreBlock . CoreList $ l ++ r
+    collapse _ _ = error "Collapsing non-block expressions"
+
+-- | Parse inert TOML data into a CoreExpr
+parseTomlData :: BS.ByteString -> IO CoreExpr
+parseTomlData src =
+  case Toml.parse . decodeUtf8 $ src of
+    Left (Toml.ParseException t) -> throwM $ FromTomlException t
+    Right val -> return . translateToml $ val

src/Eucalypt/Syntax/Input.hs

@@ -72,6 +72,7 @@ inferFormat loc =
     extToFormat ext =
       case ext of
         ".json" -> Just "json"
+        ".toml" -> Just "toml"
         ".yaml" -> Just "yaml"
         ".yml" -> Just "yaml"
         ".eu" -> Just "eu"

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-12.9
+resolver: lts-12.10
 packages:
 - '.'
 ghc-options:

test/Eucalypt/Source/TomlSourceSpec.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Eucalypt.Source.TomlSourceSpec
+  ( main
+  , spec
+  ) where
+
+import Eucalypt.Core.Syn
+import Eucalypt.Source.TomlSource
+import Test.Hspec
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec =
+  describe "Toml parser" $
+  it "parses basic toml snippet" $
+  parseTomlData "foo = \"bar\"\n\n[a]\nx=3\ny = 4\nz.p = 12\n[r.s.t]\nf.f=8\n" `shouldReturn`
+  block
+    [ element "foo" $ str "bar"
+    , element "a" $
+      block
+        [ element "x" $ int 3
+        , element "z" $ block [element "p" $ int 12]
+        , element "y" $ int 4
+        ]
+    , element "r" $
+      block
+        [ element "s" $
+          block
+            [element "t" $ block [element "f" $ block [element "f" $ int 8]]]
+        ]
+    ]

test/Eucalypt/Syntax/InputSpec.hs

@@ -8,10 +8,13 @@ import Eucalypt.Syntax.Input
 
 spec :: Spec
 spec = do
-  describe "inferFormat" $
-    it "respects extension" $
-    (inferFormat . URLInput . fromJust . parseRelativeReference) "data.json" `shouldBe`
-    Just "json"
+  describe "infer format" $ do
+    it "recognises json" $
+      (inferFormat . URLInput . fromJust . parseRelativeReference) "data.json" `shouldBe`
+      Just "json"
+    it "recognises toml" $
+      (inferFormat . URLInput . fromJust . parseRelativeReference) "data.toml" `shouldBe`
+      Just "toml"
   describe "parseInput" $ do
     it "parses simple.eu" $
       parseInputFromString "simple.eu" `shouldBe`