github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-28 01:47:01 +03:00
Code Issues Projects Releases Wiki Activity

Fully flesh out JSON specific translation step

Browse Source
This commit is contained in:
Timothy Clem 2018-08-20 09:04:08 -07:00
parent 193e17b277
commit 7d185d3001
1 changed files with 33 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
src/Language/JSON/Translate.hs
View File

@ -1,13 +1,16 @@
module Language.JSON.Translate where
module Language.JSON.Translate
( defaultBeautyOpts
, defaultJSONPipeline
, translatingJSON
, beautifyingJSON
) where
import Control.Rule
import Data.Language
import Data.Reprinting.Token
import Prologue
import Data.Machine
import Data.Reprinting.Splice
import Reprinting.Translate
import Data.Sequence hiding (fromFunction)
import Data.Machine
import Control.Monad.Effect (Eff)
import Data.Reprinting.Token
import Data.Sequence
data JSONBeautyOpts = JSONBeautyOpts { jsonPrettyPrint :: Bool }
deriving (Eq, Show)
@ -15,48 +18,39 @@ data JSONBeautyOpts = JSONBeautyOpts { jsonPrettyPrint :: Bool }
defaultBeautyOpts :: JSONBeautyOpts
defaultBeautyOpts = JSONBeautyOpts True
defaultJSONPipeline :: ProcessT (Eff effs) Splice Splice
defaultJSONPipeline :: Monad m => ProcessT m Splice Splice
defaultJSONPipeline
= translatingJSON
~> beautifyingJSON defaultBeautyOpts
translatingJSON :: ProcessT (Eff effs) Splice Splice
translatingJSON :: Monad m => ProcessT m Splice Splice
translatingJSON = flattened <~ auto step where
step :: Splice -> Seq Splice
step (Insert el@(Truth True) c _) = splice el c "true"
step (Insert el cs txt) = splice el cs $ case (el, listToMaybe cs) of
(Truth True, _) -> "true"
(Truth False, _) -> "false"
(Nullity, _) -> "null"
(Open, Just List) -> "["
(Close, Just List) -> "]"
(Open, Just Associative) -> "{"
(Close, Just Associative) -> "}"
(Separator, Just List) -> ","
(Separator, Just Pair) -> ":"
(Separator, Just Associative) -> ","
_ -> txt
step x = pure x
beautifyingJSON :: JSONBeautyOpts -> ProcessT (Eff effs) Splice Splice
beautifyingJSON :: Monad m => JSONBeautyOpts -> ProcessT m Splice Splice
beautifyingJSON _ = flattened <~ auto step where
step :: Splice -> Seq Splice
step s@(Insert Open (Just Associative) _) = s <| directive (HardWrap 2 Space)
step s@(Insert Close (Just Associative) _) = directive (HardWrap 0 Space) |> s
step s@(Insert Open (Associative:_) _) = s <| directive (HardWrap 2 Space)
step s@(Insert Close (Associative:_) _) = directive (HardWrap 0 Space) |> s
step x = pure x
-- TODO: Could implement other steps like minimizing or uglifing.
-- minimizingJSON :: Rule eff Token (Seq Splice)
-- minimizingJSON = undefined
-- instance Translation 'JSON JSONTypeSetting where
-- translation _ JSONTypeSetting{..} content context = undefined -- case (content, context) of
-- (Fragment f, _) -> Right $ splice f
--
-- (Truth True, _) -> Right $ splice "true"
-- (Truth False, _) -> Right $ splice "false"
-- (Nullity, _) -> Right $ splice "null"
--
-- (Open, List:_) -> Right $ splice "["
-- (Open, Associative:_) -> Right $ splice "{" <>
-- if jsonPrettyPrint then directive (HardWrap 2 Space) else mempty
--
-- (Close, List:_) -> Right $ splice "]"
-- (Close, Associative:_) ->
-- let prefix = if jsonPrettyPrint then directive (HardWrap 0 Space) else mempty
-- in Right $ prefix <> splice "}"
--
-- (Separator, List:_) -> Right $ splice ","
-- (Separator, Associative:_) -> Right $ splice ","
-- (Separator, Pair:_) -> Right $ splice ":"
--
-- _ -> Left "JSON translate failed, unknown context"