{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}

module Accessors.Dynamic
       ( DTree, DData(..), DConstructor(..), DSimpleEnum(..), DField(..)
       , toDData, updateLookupable, describeDField, sameDFieldType
       , diffDTrees
         -- * some utility functions for working with DSimpleEnums
       , denumToString, denumToStringOrMsg, denumSetString, denumSetIndex
       ) where

import GHC.Generics

import Data.Binary ( Binary )
import Data.Serialize ( Serialize )
import Data.Data ( Data )
import Data.Either ( partitionEithers )
import Data.List ( intercalate )
import Data.Typeable ( Typeable )
import Control.Lens
import Text.Printf ( printf )

import Accessors

type DTree = Either DField DData

data DData = DData String DConstructor
           deriving (Generic, Show, Eq, Ord, Data, Typeable)
instance Serialize DData
instance Binary DData

data DConstructor =
  DConstructor String [(Maybe String, DTree)]
  | DSum DSimpleEnum
  deriving (Generic, Show, Eq, Ord, Data, Typeable)
instance Serialize DConstructor
instance Binary DConstructor

data DSimpleEnum = DSimpleEnum [String] Int
                 deriving (Generic, Show, Eq, Ord, Data, Typeable)
instance Serialize DSimpleEnum
instance Binary DSimpleEnum

-- | a dynamic field
data DField =
  DDouble Double
  | DFloat Float
  | DInt Int
  | DString String
  | DSorry
  deriving (Generic, Show, Eq, Ord, Data, Typeable)
instance Serialize DField
instance Binary DField

-- | Get the constructor string or an error message.
denumToString :: DSimpleEnum -> Either String String
denumToString (DSimpleEnum _ k)
  | k < 0 = Left $ printf "denumToString: index %d is negative" k
denumToString (DSimpleEnum constructors k) = safeIndex constructors k
  where
    safeIndex (x:_) 0 = Right x
    safeIndex (_:xs) j = safeIndex xs (j-1)
    safeIndex [] _ =
      Left $
      printf "denumToString: index %d is too large (%d constructors)" k (length constructors)

-- | Get the constructor string or an error message without telling which is which.
denumToStringOrMsg :: DSimpleEnum -> String
denumToStringOrMsg d = case denumToString d of
  Left msg -> msg
  Right r -> r

-- | Try to update an enum with its constructor. Fail if not a valid constructor.
denumSetString :: DSimpleEnum -> String -> Either String DSimpleEnum
denumSetString (DSimpleEnum options _) txt = safeLookup options 0
  where
    safeLookup (opt:opts) k
      | opt == txt = Right (DSimpleEnum options k)
      | otherwise = safeLookup opts (k + 1)
    safeLookup [] _ = Left $ printf "denumSetString: %s is not a valid constructor" txt

-- | Try to update an enum with its index. Fail if out of bounds.
denumSetIndex :: DSimpleEnum -> Int -> Either String DSimpleEnum
denumSetIndex (DSimpleEnum constructors _) k
  | k < 0 = Left $ printf "denumSetIndex: index %d is negative" k
  | k >= length constructors =
      Left $
      printf "denumSetIndex: index %d is too large (%d constructors)" k (length constructors)
  | otherwise = Right $ DSimpleEnum constructors k

-- | Returns True if the __type__ of fields is the same.
sameDFieldType :: DField -> DField -> Bool
sameDFieldType (DDouble _) (DDouble _) = True
sameDFieldType (DFloat _) (DFloat _) = True
sameDFieldType (DInt _) (DInt _) = True
sameDFieldType (DString _) (DString _) = True
sameDFieldType DSorry DSorry = True
sameDFieldType (DDouble _) _ = False
sameDFieldType (DFloat _) _ = False
sameDFieldType (DInt _) _ = False
sameDFieldType (DString _) _ = False
sameDFieldType DSorry _ = False

describeDField :: DField -> String
describeDField (DInt _) = "Int"
describeDField (DDouble _) = "Double"
describeDField (DFloat _) = "Float"
describeDField (DString _) = "String"
describeDField DSorry = "Sorry"

-- | convert to a dynamic value
toDData :: forall a . Lookup a => a -> DTree
toDData x = toDData' accessors
  where
    toDData' :: Either (GAField a) (GAData a) -> DTree
    toDData' (Right (GAData dname constructor)) =
      Right $ DData dname (toDConstructor constructor)
    toDData' (Left field) = Left (toDField field)

    toDConstructor :: GAConstructor a -> DConstructor
    toDConstructor (GASum e) =
      DSum (DSimpleEnum (eConstructors e) (eToIndex e x))

    toDConstructor (GAConstructor cname fields) =
      DConstructor cname $ map (\(n, f) -> (n, toDData' f)) fields

    toDField :: GAField a -> DField
    toDField (FieldInt f) = DInt (x ^. f)
    toDField (FieldDouble f) = DDouble (x ^. f)
    toDField (FieldFloat f) = DFloat (x ^. f)
    toDField (FieldString f) = DString (x ^. f)
    toDField FieldSorry = DSorry


-- | Update something using a dynamic representation
updateLookupable :: Lookup a => a -> DTree -> Either String a
updateLookupable x0 dtree = updateData x0 accessors dtree

updateData :: forall a
                     . a
                     -> Either (GAField a) (GAData a)
                     -> DTree
                     -> Either String a
updateData x0 (Left afield) (Left dfield) = updateField x0 afield dfield
updateData x0 (Right (GAData adataName acon)) (Right (DData ddataName dcon))
  | adataName /= ddataName =
      Left $
      "dynamic datatype name " ++ show ddataName ++
      " don't match accessor datatype names " ++ show adataName
  | otherwise = updateConstructor x0 acon dcon
updateData _ (Left field) (Right (DData n _)) =
  Left $ "got GAField (" ++ describeGAField field ++ ") for accessor tree but DData (" ++ show n ++ ") for dynamic tree"
updateData _ (Right (GAData n _)) (Left field) =
  Left $ "got GAData for accessor tree (" ++ show n ++ ") but DField (" ++ describeDField field++ ") for dynamic tree"

showList' :: [String] -> String
showList' xs = "[" ++ intercalate ", " xs ++ "]"

updateConstructor :: forall a
                     . a
                     -> GAConstructor a
                     -> DConstructor
                     -> Either String a
updateConstructor x (GASum aenum) (DSum (DSimpleEnum dnames k))
  | anames /= dnames =
      Left $
      "accessor sum options " ++ showList' anames ++
      " doesn't match dynamic sum options " ++ showList' dnames
  | otherwise = eFromIndex aenum x k
  where
    anames = eConstructors aenum
updateConstructor x0 (GAConstructor aconName afields) (DConstructor dconName dfields)
  | aconName /= dconName =
      Left $
      "dynamic constructor name " ++ show dconName ++
      " don't match accessor constructor names " ++ show aconName
  | length afields /= length dfields = lengthMismatch
  | otherwise = f x0 afields dfields
    where
      lengthMismatch =
        Left $
        "dynamic fields have different length than accessor fields\n" ++
        "dynamic fields: " ++ show (map fst dfields) ++ "\n" ++
        "accessor fields: " ++ show (map fst afields)

      f :: a
           -> [(Maybe String, Either (GAField a) (GAData a))]
           -> [(Maybe String, DTree)]
           -> Either String a
      f x ((aname, afield):as) ((dname, dfield):ds)
        | aname /= dname =
            Left $
            "accessor selector name " ++ show aname ++
            " doesn't match dynamic selector name " ++ show dname
        | otherwise = case updateData x afield dfield of
            Left msg -> Left $ "error updating selector " ++ show aname ++ ": " ++ msg
            Right r -> f r as ds
      f x [] [] = Right x
      -- this should never happen:
      f _ _ _ = lengthMismatch
updateConstructor _ (GAConstructor aconName _) (DSum (DSimpleEnum dnames _)) =
  Left $ "got GAConstructor (" ++ aconName ++ ") but DSum ([" ++ showList' dnames ++ "])"
updateConstructor _ (GASum aenum) (DConstructor dconName _) =
  Left $ "got GASum ([" ++ showList' (eConstructors aenum) ++ "]) but DConstructor (" ++ dconName ++ ")"


updateField :: a -> GAField a -> DField -> Either String a
updateField x0 (FieldDouble f) (DDouble x) = Right $ (f .~ x) x0
updateField x0 (FieldFloat f) (DFloat x) = Right $ (f .~ x) x0
updateField x0 (FieldInt f) (DInt x) = Right $ (f .~ x) x0
updateField x0 (FieldString f) (DString x) = Right $ (f .~ x) x0
updateField x0 FieldSorry _ = Right x0
updateField _ f@(FieldDouble _) d = Left (fieldMismatch f d)
updateField _ f@(FieldFloat _) d = Left (fieldMismatch f d)
updateField _ f@(FieldInt _) d = Left (fieldMismatch f d)
updateField _ f@(FieldString _) d = Left (fieldMismatch f d)

fieldMismatch :: GAField a -> DField -> String
fieldMismatch f d =
  "accessor GAField " ++ describeGAField f ++
  " got incompatible dynamic DField " ++ describeDField d


diffDTrees :: String -> DTree -> DTree -> [String]
diffDTrees rootName = diffDTrees' [rootName]

showName :: [String] -> String
showName = intercalate "." . reverse

diffDTrees' :: [String] -> DTree -> DTree -> [String]
diffDTrees' name (Left x) (Left y) = case diffDFields name x y of
  Nothing -> []
  Just r -> [r]
diffDTrees' name (Right x) (Right y) = diffDData name x y
diffDTrees' name _ _ = [showName name ++ " have different types"]

diffDFields :: [String] -> DField -> DField -> Maybe String
diffDFields name (DDouble x) (DDouble y) = diffEq name x y
diffDFields name (DFloat  x) (DFloat  y) = diffEq name x y
diffDFields name (DInt    x) (DInt    y) = diffEq name x y
diffDFields name (DString x) (DString y) = diffEq name x y
diffDFields name DSorry DSorry = Just (showName name ++ ": can't diff this type")
diffDFields name x y
  | sameDFieldType x y = Just $ showName name ++ ": ERROR! unhandled type " ++ show (x, y)
  | otherwise = Just $ showName name ++ ": has different types"

diffEq :: (Eq a, Show a) => [String] -> a -> a -> Maybe String
diffEq name x y
  | x == y = Nothing
  | otherwise = Just (showName name ++ ": " ++ show x ++ " /= " ++ show y)


data MaybeRecords
  = Record [(String, DTree)]
  | NoRecord [DTree]
  | Mixed
  | EmptyCon

toMaybeRecords :: [(Maybe String, DTree)] -> MaybeRecords
toMaybeRecords xs = case partitionEithers (map f xs) of
  ([], []) -> EmptyCon
  ([], r) -> Record r
  (r, []) -> NoRecord r
  _ -> Mixed
  where
    f (Just x, t) = Right (x, t)
    f (Nothing, t) = Left t

diffDData :: [String] -> DData -> DData -> [String]
diffDData name (DData dx (DSum sx@(DSimpleEnum csx kx))) (DData dy (DSum sy@(DSimpleEnum csy ky)))
  | (dx /= dy) || (csx /= csy) = [showName name ++ " have different types"]
  | kx /= ky = case (denumToString sx, denumToString sy) of
      (Right nx, Right ny) -> [showName name ++ ": " ++ nx ++ " /= " ++ ny]
      (nx, ny) -> [showName name ++ ": ERROR converting to enum! " ++ intercalate ", " (lefts [nx, ny])]
  | otherwise = []
diffDData name (DData dx (DConstructor cx xs)) (DData dy (DConstructor cy ys))
  | (dx, cx) /= (dy, cy) = [showName name ++ " has different types " ++ show ((dx, cx), (dy, cy))]
  | otherwise = case (toMaybeRecords xs, toMaybeRecords ys) of
      (Mixed, Mixed) -> [showName name ++ " has mixed types WTF"]
      (EmptyCon, EmptyCon) -> []
      (NoRecord x, NoRecord y)
        | length x == length y ->
            let diffChild k = diffDTrees' (arrayName k:name)
            in concat $ zipWith3 diffChild [0..] x y
        | otherwise -> [showName name ++ " has different types"]
      (Record x, Record y)
        | map fst x /= map fst y -> [showName name ++ " has different types"]
        | otherwise ->
            let diffChild (nx, x') (ny, y')
                  | nx == ny = diffDTrees' (nx:name) x' y'
                  | otherwise = error $ "internal error: record names don't match " ++ show (nx, ny)
            in concat $ zipWith diffChild x y
      _ -> [showName name ++ " has different types"]
diffDData name _ _ = [showName name ++ " has different types"]

--  | otherwise = zipWith diffDData
arrayName :: Int -> String
arrayName k = '[':(show k ++ "]")


lefts :: [Either a b] -> [a]
lefts ((Left x):xs) = x:lefts xs
lefts ((Right _):xs) = lefts xs
lefts [] = []