{-# LANGUAGE OverloadedStrings #-}
module Language.Haskell.HBB.Internal.TTreeJSON (
    encodeTTreeToJSON,
    decodeTTreeFromJSON) where

-- This module allows the (de-)serialization of TTree to JSON.
-- The following example shows a serialized TTree which one child element:
-- {
--     "addition-text": "()",
--     "children": [
--         {
--             "addition-text": "\x -> \"hello \" ++ x",
--             "children": [],
--             "cover-range": "1:2-1:2"
--         }
--     ],
--     "cover-range": "examples/PlayHelloPattern.hs,17:16-17:21"
-- }

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
-- SrcLoc is a module from GHC which can be used to describe locations and
-- spans of the source code. It is used at this point to avoid the introduction
-- of (some) user-defined types to describe the transformation tree.

-- | This is the function that allows the deserialization of the
-- Transformation-Tree from JSON.
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

-- | This function converts the tranformation-tree to JSON.
--
-- This is an example of a tree containing two addition which has been
-- converted to JSON (the JSON-code has been layouted to make it more
-- readable):
--
-- 
-- > {
-- >     "addition-text": "()",
-- >     "children": [
-- >         {
-- >             "addition-text": "\x -> \"hello \" ++ x",
-- >             "children": [],
-- >             "cover-range": "1:2-1:2"
-- >         }
-- >     ],
-- >     "cover-range": "examples/PlayHelloPattern.hs,17:16-17:21"
-- > }
encodeTTreeToJSON :: (RealSrcSpan,TTree LineBuf (RealSrcSpan,Int) BufSpan) -> LazyByteString.ByteString
encodeTTreeToJSON tree = encode (JSON_RootTTree tree)

-- Wrapped data types
-- ==================
--
-- The JSON library aeson is based on the type classes FromJSON and ToJSON.
-- Types that are instances of these classes can be converted from and to JSON.
-- We want the type TTree to be encoded to and decoded from JSON. The first
-- solution would be to make it (and RealSrcSpan as it occurres within the
-- tree) an instance of these to type classes. This solution works but the
-- problem is that the compiler will issue "Orphaned Instance" errors as the
-- type class instances aren't defined in the module where the type is defined.
-- Especially for RealSrcSpan (which is defined in the module SrcLoc from GHC)
-- we can never reach this. To circumvent this issue this module defines its
-- own wrappers around these types prefixing them with "JSON_". For these (new)
-- types instances of FromJSON and ToJSON are defined.
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

-- For the data type (JOSN_)RealSrcSpan (originally a GHC type) we use a more
-- narrow representation: '<filename>-<line>:<column>-<line>:<column>'. This
-- should make the JSON strings more compact and readable.

-- Splits a string at the first occurrence of the passed character
-- and returns the two substrings (without the character itself).
splitAtChar :: Char -> String -> Parser (String,String)
splitAtChar char x = case break (== char) x of 
        (xs,(c:ys)) | c == char -> return (xs,ys)
        _                       -> mzero

-- BufLoc in JSON must have the form '<line>:<column>'
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))

-- A BufSpan must have the form '<line>:<column>-<line>:<column>'
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

-- BufSpan will have the form '<line>:<column>-<line>:<column>'
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))

-- This instance parses RealSrcSpans from JSON strings.
-- The format is: '<filename>,<line>:<column>-<line>:<column>'
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

-- This instance serializes a RealSrcSpan to a JSON string.
-- The format is: '<filename>,<line>:<column>-<line>:<column>'
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)))

-- This function parses a TTree from JSON. It is generic in a way that allows
-- its usage for the deserialization of either JSON_TTree or JSON_RootTTree.
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)

-- This function makes JSON from a TTree. It is generic in a way that allows
-- its usage for the serialization of either JSON_TTree or JSON_RootTTree.
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