module Language.Haskell.HBB.Internal.TTreeJSON (
encodeTTreeToJSON,
decodeTTreeFromJSON) where
import Language.Haskell.HBB.Internal.SrcSpan
import Language.Haskell.HBB.Internal.TTree
import qualified Data.ByteString.Char8 as StrictByteString (ByteString)
import qualified Data.ByteString.Lazy as LazyByteString (ByteString)
import Data.HashMap.Strict (member)
import Data.Aeson.Types (Parser)
import Control.Monad
import FastString (mkFastString,unpackFS)
import Data.Aeson
import qualified Data.Text as Text
import SrcLoc
decodeTTreeFromJSON :: StrictByteString.ByteString -> Either String (RealSrcSpan,TTree LineBuf (RealSrcSpan,Int) BufSpan)
decodeTTreeFromJSON bs = case eitherDecodeStrict' bs of
Right (JSON_RootTTree tree) -> Right tree
Left msg -> Left msg
encodeTTreeToJSON :: (RealSrcSpan,TTree LineBuf (RealSrcSpan,Int) BufSpan) -> LazyByteString.ByteString
encodeTTreeToJSON tree = encode (JSON_RootTTree tree)
data JSON_RealSrcSpan = JSON_RealSrcSpan RealSrcSpan
data JSON_DisplaySpan = JSON_DisplaySpan (RealSrcSpan,Int)
data JSON_TTree = JSON_TTree (BufSpan ,TTree LineBuf (RealSrcSpan,Int) BufSpan)
data JSON_RootTTree = JSON_RootTTree (RealSrcSpan,TTree LineBuf (RealSrcSpan,Int) BufSpan)
data JSON_BufLoc = JSON_BufLoc BufLoc
data JSON_BufSpan = JSON_BufSpan BufSpan
splitAtChar :: Char -> String -> Parser (String,String)
splitAtChar char x = case break (== char) x of
(xs,(c:ys)) | c == char -> return (xs,ys)
_ -> mzero
instance FromJSON JSON_BufLoc where
parseJSON (String s) = do
(l,c) <- splitAtChar ':' (Text.unpack s)
return $ (JSON_BufLoc (BufLoc (read l) (read c)))
parseJSON _ = mzero
instance ToJSON JSON_BufLoc where
toJSON (JSON_BufLoc (BufLoc li co)) =
(String $ Text.pack $ (show li) ++ [':'] ++ (show co))
instance FromJSON JSON_BufSpan where
parseJSON (String s) = do
(l1,l2) <- splitAtChar '-' (Text.unpack s)
loc1 <- parseJSON (String $ Text.pack l1)
loc2 <- parseJSON (String $ Text.pack l2)
let (JSON_BufLoc location1) = loc1
(JSON_BufLoc location2) = loc2
return $ (JSON_BufSpan (BufSpan location1 location2))
parseJSON _ = mzero
instance ToJSON JSON_BufSpan where
toJSON (JSON_BufSpan (BufSpan l1 l2)) =
let (String t1) = toJSON (JSON_BufLoc l1)
(String t2) = toJSON (JSON_BufLoc l2)
in String $ Text.append (Text.snoc t1 '-') t2
instance FromJSON JSON_DisplaySpan where
parseJSON (String s) = do
(revHint,revRealSrcSpan) <- splitAtChar ',' (reverse $ Text.unpack s)
rSrcSpan <- parseJSON $ String $ Text.pack $ reverse revRealSrcSpan
let hint = read (reverse revHint) :: Int
(JSON_RealSrcSpan rspn) = rSrcSpan
return $ JSON_DisplaySpan (rspn,hint)
parseJSON _ = mzero
instance ToJSON JSON_DisplaySpan where
toJSON (JSON_DisplaySpan (spn,hint)) =
let (String txt) = toJSON (JSON_RealSrcSpan spn)
in String $ Text.append (Text.snoc txt ',') (Text.pack (show hint))
instance FromJSON JSON_RealSrcSpan where
parseJSON (String s) = do
(revSpan,revName) <- splitAtChar ',' (reverse $ Text.unpack s)
span <- parseJSON $ String $ Text.pack (reverse revSpan)
let (JSON_BufSpan (BufSpan (BufLoc l1 c1) (BufLoc l2 c2))) = span
return $ JSON_RealSrcSpan (mkRealSrcSpan
(mkRealSrcLoc (mkFastString (reverse revName)) l1 c1)
(mkRealSrcLoc (mkFastString (reverse revName)) l2 c2))
parseJSON _ = mzero
instance ToJSON JSON_RealSrcSpan where
toJSON (JSON_RealSrcSpan spn) =
let fromLoc = realSrcSpanStart spn
toLoc = realSrcSpanEnd spn
fn = Text.pack $ unpackFS $ srcLocFile fromLoc
(l1,c1) = (srcLocLine fromLoc,srcLocCol fromLoc)
(l2,c2) = (srcLocLine toLoc,srcLocCol toLoc)
(String spanStr) = toJSON (JSON_BufSpan $ BufSpan (BufLoc l1 c1) (BufLoc l2 c2))
in (String (Text.append fn (Text.cons ',' spanStr)))
parseJSONTTreeGeneric constr locExtract (Object o) | member "addition-text" o = do
addition' <- parseJSON =<< (o .: "addition-text")
coverrange' <- parseJSON =<< (o .: "cover-range")
children' <- parseJSON =<< (o .: "children")
let cr = locExtract coverrange'
cldrn = [ tree | (JSON_TTree tree) <- children' ]
return $ constr (cr,(TTree (Addition addition') cldrn))
parseJSONTTreeGeneric constr locExtract (Object o) | member "source-range" o = do
sourcedisplay' <- parseJSON =<< (o .: "source-range")
coverrange' <- parseJSON =<< (o .: "cover-range")
children' <- parseJSON =<< (o .: "children")
let (JSON_DisplaySpan ds) = sourcedisplay'
cr = locExtract coverrange'
cldrn = [ tree | (JSON_TTree tree) <- children' ]
return $ constr (cr,(TTree (Display ds) cldrn))
parseJSONTTreeGeneric _ _ _ = mzero
instance FromJSON JSON_TTree where
parseJSON = parseJSONTTreeGeneric JSON_TTree (\(JSON_BufSpan x) -> x)
instance FromJSON JSON_RootTTree where
parseJSON = parseJSONTTreeGeneric JSON_RootTTree (\(JSON_RealSrcSpan x) -> x)
toJSONTTreeGeneric extractor wrapLoc wrappedTree =
case extractor wrappedTree of
(bs,(TTree (Addition add) childs)) ->
object [ "addition-text" .= add
, "cover-range" .= (wrapLoc bs)
, "children" .= [ JSON_TTree c | c <- childs] ]
(bs,(TTree (Display display) childs)) ->
object [ "source-range" .= (JSON_DisplaySpan display)
, "cover-range" .= (wrapLoc bs)
, "children" .= [ JSON_TTree c | c <- childs] ]
instance ToJSON JSON_TTree where
toJSON = toJSONTTreeGeneric (\(JSON_TTree x) -> x) JSON_BufSpan
instance ToJSON JSON_RootTTree where
toJSON = toJSONTTreeGeneric (\(JSON_RootTTree x) -> x) JSON_RealSrcSpan