{-# LANGUAGE OverloadedStrings   #-}

module Replica.VDOM.Diff where

import           Data.Aeson                 ((.=))
import qualified Data.Aeson                 as A
import qualified Data.Text                  as T
import qualified Data.Map                   as M
import qualified Data.Algorithm.Diff        as D
import           Replica.VDOM.Types         (HTML, VDOM(VNode,VLeaf,VText,VRawText), Attrs, Attr(AText,ABool,AEvent,AMap))

t :: T.Text -> T.Text
t = id

data Diff
  = Delete !Int
  | Insert !Int !VDOM
  | Diff !Int ![AttrDiff] ![Diff]
  | ReplaceText !Int !T.Text

instance A.ToJSON Diff where
  toJSON (Delete i) = A.object
    [ "type"  .= t "delete"
    , "index" .= i
    ]
  toJSON (Insert i v) = A.object
    [ "type"  .= t "insert"
    , "dom"   .= v
    , "index" .= i
    ]
  toJSON (Diff i ads ds) = A.object
    [ "type"  .= t "diff"
    , "diff"  .= ds
    , "adiff" .= ads
    , "index" .= i
    ]
  toJSON (ReplaceText i text) = A.object
    [ "type"  .= t "replace_text"
    , "index" .= i
    , "text"  .= text
    ]

data AttrDiff
  = DeleteKey !T.Text
  | InsertKey !T.Text !Attr
  | DiffKey   !T.Text ![KeyDiff]

instance A.ToJSON AttrDiff where
  toJSON (DeleteKey k) = A.object
    [ "type" .= t "delete"
    , "key" .= k
    ]
  toJSON (InsertKey k v) = A.object
    [ "type" .= t "insert"
    , "key" .= k
    , "value" .= v
    ]
  toJSON (DiffKey k ds) = A.object
    [ "type" .= t "diff"
    , "key" .= k
    , "diff" .= ds
    ]

data KeyDiff
  = Replace !Attr
  | DiffMap ![AttrDiff]

instance A.ToJSON KeyDiff where
  toJSON (Replace v) = A.object
    [ "type" .= t "replace"
    , "value" .= v
    ]
  toJSON (DiffMap ds) = A.object
    [ "type" .= t "diff"
    , "diff" .= ds
    ]

diff :: HTML -> HTML -> [Diff]
diff a b = concatMap (uncurry toDiff) (zip vdiffs is)
  where
    go :: Int -> [D.Diff a] -> [Int]
    go i (D.First _:ds) = i:go i ds
    go i (_:ds) = i:go (i + 1) ds
    go _ [] = []

    vdiffs = D.getDiffBy eqNode a b
    is     = go 0 vdiffs

    toDiff :: D.Diff VDOM -> Int -> [Diff]
    toDiff (D.First _) i  = [Delete i]
    toDiff (D.Second v) i = [Insert i v]
    toDiff (D.Both (VNode _ ca cNs c) v@(VNode _ da dNs d)) i
      | cNs /= dNs          = [Delete i, Insert i v]
      | null das && null ds = []
      | otherwise           = [Diff i (diffAttrs ca da) (diff c d)]
      where
        das = diffAttrs ca da
        ds  = diff c d
    toDiff (D.Both (VLeaf _ ca cNs) v@(VLeaf _ da dNs)) i
      | cNs /= dNs = [Delete i, Insert i v]
      | null das   = []
      | otherwise  = [Diff i (diffAttrs ca da) []]
      where
        das = diffAttrs ca da
    toDiff (D.Both (VText m) (VText n)) i
      | m == n    = []
      | otherwise = [ReplaceText i n]
    toDiff (D.Both (VRawText m) (VRawText n)) i
      | m == n    = []
      | otherwise = [ReplaceText i n]
    toDiff _ _ = []

    key attrs = M.lookup "key" attrs

    eqType (Just (AText m)) (Just (AText n))
      | m == n    = True
      | otherwise = False
    eqType Nothing Nothing = True
    eqType _ _ = False

    eqNode (VNode n na nNs _) (VNode m ma mNs _)
      | Just (AText k1) <- key na
      , Just (AText k2) <- key ma = k1 == k2
      | otherwise = n == m && nNs == mNs && M.lookup "type" na `eqType` M.lookup "type" ma
    eqNode (VLeaf n na nNs) (VLeaf m ma mNs)
      | Just (AText k1) <- key na
      , Just (AText k2) <- key ma = k1 == k2
      | otherwise = n == m && nNs == mNs && M.lookup "type" na `eqType` M.lookup "type" ma
    eqNode (VText _) (VText _) = True
    eqNode (VRawText _) (VRawText _) = True
    eqNode _ _ = False

diffAttrs :: Attrs -> Attrs -> [AttrDiff]
diffAttrs a b
  =  fmap DeleteKey (M.keys deleted)
  <> fmap (uncurry InsertKey) (M.assocs inserted)
  <> concatMap diffKey (M.assocs same)
  where
    deleted  = a `M.difference` b
    inserted = b `M.difference` a
    same     = M.intersectionWith (,) a b

    diffKey :: (T.Text, (Attr, Attr)) -> [AttrDiff]
    diffKey (k, (m, n))
      | null ds   = []
      | otherwise = [DiffKey k ds]
      where
        ds = diffVValue m n

    diffVValue :: Attr -> Attr -> [KeyDiff]
    diffVValue (AText m) vn@(AText n)
      | m == n = []
      | otherwise = [Replace vn]
    diffVValue (ABool m) vn@(ABool n)
      | m == n = []
      | otherwise = [Replace vn]
    diffVValue (AEvent m _) vn@(AEvent n _)
       | m == n = []
       | otherwise = [Replace vn]
    diffVValue (AMap m) (AMap n)
      | null das  = []
      | otherwise = [DiffMap $ diffAttrs m n]
      where
        das = diffAttrs m n
    diffVValue _ n                   = [Replace n]

patch :: [Diff] -> HTML -> HTML
patch [] a                  = a
patch (Delete i:rds) a      = patch rds $ take i a <> drop (i + 1) a
patch (Insert i v:rds) a    = patch rds $ take i a <> [v] <> drop i a
patch (Diff i ads ds:rds) a = patch rds $ take i a <> [v] <> drop (i + 1) a
  where
    v = case a !! i of
      VNode e as ns cs -> VNode e (patchAttrs ads as) ns (patch ds cs)
      VLeaf e as ns    -> VLeaf e (patchAttrs ads as) ns
      VText _          -> error "Can't node patch text"
      VRawText _       -> error "Can't node patch text"
patch (ReplaceText i n:rds) a = patch rds $ take i a <> [v] <> drop (i + 1) a
  where
    v = case a !! i of
      VText _     -> VText n
      VRawText _  -> VRawText n
      _           -> error "Can't text patch node"

patchAttrs :: [AttrDiff] -> Attrs -> Attrs
patchAttrs [] a                 = a
patchAttrs (DeleteKey k:ds) a   = patchAttrs ds $ M.delete k a
patchAttrs (InsertKey k v:ds) a = patchAttrs ds $ M.insert k v a
patchAttrs (DiffKey k vds:ds) a = patchAttrs ds $ M.adjust (patchVValue vds) k a
  where
    patchVValue [] v                      = v
    patchVValue (Replace m:vs) _          = patchVValue vs m
    patchVValue (DiffMap ads:vs) (AMap m) = patchVValue vs $ AMap (patchAttrs ads m)
    patchVValue (DiffMap _:_) _           = error "Can't patch map non-maps"

# LANGUAGE OverloadedStrings   #

module Replica.VDOM.Diff where

import           Data.Aeson                 ((.=))
import qualified Data.Aeson                 as A
import qualified Data.Text                  as T
import qualified Data.Map                   as M
import qualified Data.Algorithm.Diff        as D
import           Replica.VDOM.Types         (HTML, VDOM(VNode,VLeaf,VText,VRawText), Attrs, Attr(AText,ABool,AEvent,AMap))

t :: T.Text -> T.Text
t = id

data Diff
  = Delete !Int
  | Insert !Int !VDOM
  | Diff !Int ![AttrDiff] ![Diff]
  | ReplaceText !Int !T.Text

instance A.ToJSON Diff where
  toJSON (Delete i) = A.object
    [ "type"  .= t "delete"
    , "index" .= i
    ]
  toJSON (Insert i v) = A.object
    [ "type"  .= t "insert"
    , "dom"   .= v
    , "index" .= i
    ]
  toJSON (Diff i ads ds) = A.object
    [ "type"  .= t "diff"
    , "diff"  .= ds
    , "adiff" .= ads
    , "index" .= i
    ]
  toJSON (ReplaceText i text) = A.object
    [ "type"  .= t "replace_text"
    , "index" .= i
    , "text"  .= text
    ]

data AttrDiff
  = DeleteKey !T.Text
  | InsertKey !T.Text !Attr
  | DiffKey   !T.Text ![KeyDiff]

instance A.ToJSON AttrDiff where
  toJSON (DeleteKey k) = A.object
    [ "type" .= t "delete"
    , "key" .= k
    ]
  toJSON (InsertKey k v) = A.object
    [ "type" .= t "insert"
    , "key" .= k
    , "value" .= v
    ]
  toJSON (DiffKey k ds) = A.object
    [ "type" .= t "diff"
    , "key" .= k
    , "diff" .= ds
    ]

data KeyDiff
  = Replace !Attr
  | DiffMap ![AttrDiff]

instance A.ToJSON KeyDiff where
  toJSON (Replace v) = A.object
    [ "type" .= t "replace"
    , "value" .= v
    ]
  toJSON (DiffMap ds) = A.object
    [ "type" .= t "diff"
    , "diff" .= ds
    ]

diff :: HTML -> HTML -> [Diff]
diff a b = concatMap (uncurry toDiff) (zip vdiffs is)
  where
    go :: Int -> [D.Diff a] -> [Int]
    go i (D.First _:ds) = i:go i ds
    go i (_:ds) = i:go (i + 1) ds
    go _ [] = []

    vdiffs = D.getDiffBy eqNode a b
    is     = go 0 vdiffs

    toDiff :: D.Diff VDOM -> Int -> [Diff]
    toDiff (D.First _) i  = [Delete i]
    toDiff (D.Second v) i = [Insert i v]
    toDiff (D.Both (VNode _ ca cNs c) v@(VNode _ da dNs d)) i
      | cNs /= dNs          = [Delete i, Insert i v]
      | null das && null ds = []
      | otherwise           = [Diff i (diffAttrs ca da) (diff c d)]
      where
        das = diffAttrs ca da
        ds  = diff c d
    toDiff (D.Both (VLeaf _ ca cNs) v@(VLeaf _ da dNs)) i
      | cNs /= dNs = [Delete i, Insert i v]
      | null das   = []
      | otherwise  = [Diff i (diffAttrs ca da) []]
      where
        das = diffAttrs ca da
    toDiff (D.Both (VText m) (VText n)) i
      | m == n    = []
      | otherwise = [ReplaceText i n]
    toDiff (D.Both (VRawText m) (VRawText n)) i
      | m == n    = []
      | otherwise = [ReplaceText i n]
    toDiff _ _ = []

    key attrs = M.lookup "key" attrs

    eqType (Just (AText m)) (Just (AText n))
      | m == n    = True
      | otherwise = False
    eqType Nothing Nothing = True
    eqType _ _ = False

    eqNode (VNode n na nNs _) (VNode m ma mNs _)
      | Just (AText k1) <- key na
      , Just (AText k2) <- key ma = k1 == k2
      | otherwise = n == m && nNs == mNs && M.lookup "type" na `eqType` M.lookup "type" ma
    eqNode (VLeaf n na nNs) (VLeaf m ma mNs)
      | Just (AText k1) <- key na
      , Just (AText k2) <- key ma = k1 == k2
      | otherwise = n == m && nNs == mNs && M.lookup "type" na `eqType` M.lookup "type" ma
    eqNode (VText _) (VText _) = True
    eqNode (VRawText _) (VRawText _) = True
    eqNode _ _ = False

diffAttrs :: Attrs -> Attrs -> [AttrDiff]
diffAttrs a b
  =  fmap DeleteKey (M.keys deleted)
  <> fmap (uncurry InsertKey) (M.assocs inserted)
  <> concatMap diffKey (M.assocs same)
  where
    deleted  = a `M.difference` b
    inserted = b `M.difference` a
    same     = M.intersectionWith (,) a b

    diffKey :: (T.Text, (Attr, Attr)) -> [AttrDiff]
    diffKey (k, (m, n))
      | null ds   = []
      | otherwise = [DiffKey k ds]
      where
        ds = diffVValue m n

    diffVValue :: Attr -> Attr -> [KeyDiff]
    diffVValue (AText m) vn@(AText n)
      | m == n = []
      | otherwise = [Replace vn]
    diffVValue (ABool m) vn@(ABool n)
      | m == n = []
      | otherwise = [Replace vn]
    diffVValue (AEvent m _) vn@(AEvent n _)
       | m == n = []
       | otherwise = [Replace vn]
    diffVValue (AMap m) (AMap n)
      | null das  = []
      | otherwise = [DiffMap $ diffAttrs m n]
      where
        das = diffAttrs m n
    diffVValue _ n                   = [Replace n]

patch :: [Diff] -> HTML -> HTML
patch [] a                  = a
patch (Delete i:rds) a      = patch rds $ take i a <> drop (i + 1) a
patch (Insert i v:rds) a    = patch rds $ take i a <> [v] <> drop i a
patch (Diff i ads ds:rds) a = patch rds $ take i a <> [v] <> drop (i + 1) a
  where
    v = case a !! i of
      VNode e as ns cs -> VNode e (patchAttrs ads as) ns (patch ds cs)
      VLeaf e as ns    -> VLeaf e (patchAttrs ads as) ns
      VText _          -> error "Can't node patch text"
      VRawText _       -> error "Can't node patch text"
patch (ReplaceText i n:rds) a = patch rds $ take i a <> [v] <> drop (i + 1) a
  where
    v = case a !! i of
      VText _     -> VText n
      VRawText _  -> VRawText n
      _           -> error "Can't text patch node"

patchAttrs :: [AttrDiff] -> Attrs -> Attrs
patchAttrs [] a                 = a
patchAttrs (DeleteKey k:ds) a   = patchAttrs ds $ M.delete k a
patchAttrs (InsertKey k v:ds) a = patchAttrs ds $ M.insert k v a
patchAttrs (DiffKey k vds:ds) a = patchAttrs ds $ M.adjust (patchVValue vds) k a
  where
    patchVValue [] v                      = v
    patchVValue (Replace m:vs) _          = patchVValue vs m
    patchVValue (DiffMap ads:vs) (AMap m) = patchVValue vs $ AMap (patchAttrs ads m)
    patchVValue (DiffMap _:_) _           = error "Can't patch map non-maps"
