module Accessors.Dynamic
( DTree, DData(..), DConstructor(..), DSimpleEnum(..), DField(..)
, toDData, updateLookupable, describeDField, sameDFieldType
, diffDTrees
, 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
data DField =
DDouble Double
| DFloat Float
| DInt Int
| DString String
| DSorry
deriving (Generic, Show, Eq, Ord, Data, Typeable)
instance Serialize DField
instance Binary DField
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 (j1)
safeIndex [] _ =
Left $
printf "denumToString: index %d is too large (%d constructors)" k (length constructors)
denumToStringOrMsg :: DSimpleEnum -> String
denumToStringOrMsg d = case denumToString d of
Left msg -> msg
Right r -> r
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
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
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"
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
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
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"]
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 [] = []