|
| 1 | +{-# LANGUAGE GADTs #-} |
| 2 | +{-# LANGUAGE TypeFamilies #-} |
| 3 | +{-# LANGUAGE RecordWildCards #-} |
| 4 | +{-| |
| 5 | +Module : Eucalypt.Source.TomlSource |
| 6 | +Description : Ingest TOML into core syntax |
| 7 | +Copyright : (c) Greg Hawkins, 2018 |
| 8 | +License : |
| 9 | + |
| 10 | +Stability : experimental |
| 11 | +-} |
| 12 | +module Eucalypt.Source.TomlSource where |
| 13 | + |
| 14 | +import Control.Exception.Safe |
| 15 | +import qualified Data.ByteString as BS |
| 16 | +import qualified Data.HashMap.Strict as HM |
| 17 | +import Data.List (intercalate) |
| 18 | +import qualified Data.List.NonEmpty as NonEmpty |
| 19 | +import Data.Text (unpack) |
| 20 | +import Data.Text.Encoding (decodeUtf8) |
| 21 | +import Eucalypt.Core.Syn |
| 22 | +import Eucalypt.Source.Error |
| 23 | +import qualified Toml |
| 24 | + |
| 25 | +-- | Convert a TOML primitive to a core expression |
| 26 | +-- |
| 27 | +tomlValue :: Toml.Value t -> CoreExpr |
| 28 | +tomlValue (Toml.Bool b) = corebool b |
| 29 | +tomlValue (Toml.Integer n) = int n |
| 30 | +tomlValue (Toml.Double d) = float d |
| 31 | +tomlValue (Toml.Text s) = (str . unpack) s |
| 32 | +tomlValue (Toml.Date d) = |
| 33 | + withMeta |
| 34 | + (block [element "toml" $ block [element "type" $ sym "date"]]) |
| 35 | + (str $ show d) |
| 36 | +tomlValue (Toml.Array a) = CoreList $ map tomlValue a |
| 37 | + |
| 38 | +pieceToBindingName :: Toml.Piece -> CoreBindingName |
| 39 | +pieceToBindingName = unpack . Toml.unPiece |
| 40 | + |
| 41 | +keyToBindingName :: Toml.Key -> CoreBindingName |
| 42 | +keyToBindingName (Toml.Key k) = |
| 43 | + intercalate "." $ map pieceToBindingName (NonEmpty.toList k) |
| 44 | + |
| 45 | +-- | Translate a prefix tree into a list of blocks that can be |
| 46 | +-- concatenated |
| 47 | +translatePrefixTree :: Toml.PrefixTree Toml.TOML -> CoreExpr |
| 48 | +translatePrefixTree (Toml.Leaf k a) = |
| 49 | + inPrefixBlocks k $ translateToml a |
| 50 | +translatePrefixTree Toml.Branch {..} = |
| 51 | + inPrefixBlocks bCommonPref $ translatePrefixMap bPrefixMap |
| 52 | + |
| 53 | +-- | Translate a prefix map |
| 54 | +translatePrefixMap :: Toml.PrefixMap Toml.TOML -> CoreExpr |
| 55 | +translatePrefixMap m = |
| 56 | + block |
| 57 | + [ element (pieceToBindingName k) $ translatePrefixTree v |
| 58 | + | (k, v) <- HM.toList m |
| 59 | + ] |
| 60 | + |
| 61 | +-- | Return expression wrapped in enough blocks to represent the |
| 62 | +-- prefix |
| 63 | +inPrefixBlocks :: Toml.Prefix -> CoreExpr -> CoreExpr |
| 64 | +inPrefixBlocks k ex = foldr wrap ex names |
| 65 | + where |
| 66 | + wrap l r = block [element l r] |
| 67 | + names = map pieceToBindingName (NonEmpty.toList . Toml.unKey $ k) |
| 68 | + |
| 69 | +-- | Translate a TOML file into a 'CoreExpr' |
| 70 | +-- |
| 71 | +translateToml :: Toml.TOML -> CoreExpr |
| 72 | +translateToml Toml.TOML {..} = foldl1 collapse (pairBlocks ++ tables) |
| 73 | + where |
| 74 | + pairBlocks = map kvBlock $ HM.toList tomlPairs |
| 75 | + tables = map translatePrefixTree $ HM.elems tomlTables |
| 76 | + kvBlock (k, Toml.AnyValue val) = inPrefixBlocks k $ tomlValue val |
| 77 | + collapse (CoreBlock (CoreList l)) (CoreBlock (CoreList r)) = |
| 78 | + CoreBlock . CoreList $ l ++ r |
| 79 | + collapse _ _ = error "Collapsing non-block expressions" |
| 80 | + |
| 81 | +-- | Parse inert TOML data into a CoreExpr |
| 82 | +parseTomlData :: BS.ByteString -> IO CoreExpr |
| 83 | +parseTomlData src = |
| 84 | + case Toml.parse . decodeUtf8 $ src of |
| 85 | + Left (Toml.ParseException t) -> throwM $ FromTomlException t |
| 86 | + Right val -> return . translateToml $ val |
0 commit comments