github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-30 14:47:30 +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 Prologue
import Data.Language
import Data.Reprinting.Token import Data.Machine
import Data.Reprinting.Splice import Data.Reprinting.Splice
import Reprinting.Translate import Data.Reprinting.Token
import Data.Sequence hiding (fromFunction) import Data.Sequence
import Data.Machine
import Control.Monad.Effect (Eff)
data JSONBeautyOpts = JSONBeautyOpts { jsonPrettyPrint :: Bool } data JSONBeautyOpts = JSONBeautyOpts { jsonPrettyPrint :: Bool }
deriving (Eq, Show) deriving (Eq, Show)
@ -15,48 +18,39 @@ data JSONBeautyOpts = JSONBeautyOpts { jsonPrettyPrint :: Bool }
defaultBeautyOpts :: JSONBeautyOpts defaultBeautyOpts :: JSONBeautyOpts
defaultBeautyOpts = JSONBeautyOpts True defaultBeautyOpts = JSONBeautyOpts True
defaultJSONPipeline :: Monad m => ProcessT m Splice Splice
defaultJSONPipeline :: ProcessT (Eff effs) Splice Splice
defaultJSONPipeline defaultJSONPipeline
= translatingJSON = translatingJSON
~> beautifyingJSON defaultBeautyOpts ~> beautifyingJSON defaultBeautyOpts
translatingJSON :: Monad m => ProcessT m Splice Splice
translatingJSON :: ProcessT (Eff effs) Splice Splice
translatingJSON = flattened <~ auto step where translatingJSON = flattened <~ auto step where
step :: Splice -> Seq Splice 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 step x = pure x
beautifyingJSON :: JSONBeautyOpts -> ProcessT (Eff effs) Splice Splice beautifyingJSON :: Monad m => JSONBeautyOpts -> ProcessT m Splice Splice
beautifyingJSON _ = flattened <~ auto step where beautifyingJSON _ = flattened <~ auto step where
step :: Splice -> Seq Splice step :: Splice -> Seq Splice
step s@(Insert Open (Just Associative) _) = s <| directive (HardWrap 2 Space) step s@(Insert Open (Associative:_) _) = s <| directive (HardWrap 2 Space)
step s@(Insert Close (Just Associative) _) = directive (HardWrap 0 Space) |> s step s@(Insert Close (Associative:_) _) = directive (HardWrap 0 Space) |> s
step x = pure x step x = pure x
-- TODO: Could implement other steps like minimizing or uglifing.
-- minimizingJSON :: Rule eff Token (Seq Splice) -- minimizingJSON :: Rule eff Token (Seq Splice)
-- minimizingJSON = undefined -- 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"