diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -1,1 +1,2 @@ +.stack-work dist diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -1,34 +1,22 @@ -# from https://github.com/hvr/multi-ghc-travis +sudo: false -env: - - GHCVER=7.6.3 - - GHCVER=7.8.4 # see note about Alex/Happy - - GHCVER=7.10.3 # see note about Alex/Happy +addons: + apt: + packages: + - libgsl0-dev + - liblapack-dev before_install: - - travis_retry sudo add-apt-repository -y ppa:hvr/ghc - - travis_retry sudo apt-get update - - travis_retry sudo apt-get install cabal-install-1.24 ghc-$GHCVER libgsl0-dev liblapack-dev - - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.24/bin:$PATH + # Download and unpack the stack executable + - mkdir -p ~/.local/bin + - export PATH=$HOME/.local/bin:$PATH + - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' + - chmod a+x ~/.local/bin/stack install: - - cabal update - - cabal install --only-dependencies --enable-tests --enable-benchmarks + - stack setup --no-terminal + - stack build --no-terminal --only-snapshot -# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail. script: - - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging - - cabal build # this builds all libraries and executables (including tests/benchmarks) - - cabal test --show-details=always -# - cabal check - - cabal sdist # tests that a source-distribution can be generated - -# The following scriptlet checks that the resulting source distribution can be built & installed - - export SRC_TGZ=$(cabal-1.24 info . | awk '{print $2 ".tar.gz";exit}') ; - cd dist/; - if [ -f "$SRC_TGZ" ]; then - cabal install "$SRC_TGZ"; - else - echo "expected '$SRC_TGZ' not found"; - exit 1; - fi + - stack build --no-terminal --test + - stack sdist diff --git a/generic-accessors.cabal b/generic-accessors.cabal --- a/generic-accessors.cabal +++ b/generic-accessors.cabal @@ -1,5 +1,5 @@ name: generic-accessors -version: 0.6.0.1 +version: 0.6.1.0 synopsis: stringly-named getters for generic data license: BSD3 license-file: LICENSE diff --git a/src/Accessors/Dynamic.hs b/src/Accessors/Dynamic.hs --- a/src/Accessors/Dynamic.hs +++ b/src/Accessors/Dynamic.hs @@ -6,6 +6,7 @@ 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 @@ -15,6 +16,7 @@ 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 @@ -120,7 +122,7 @@ 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 @@ -182,7 +184,7 @@ "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)] @@ -219,3 +221,81 @@ fieldMismatch f d = "accessor GAField " ++ describeGAField f ++ " got incompatible dynamic DField " ++ describeDField d + + +diffDTrees :: DTree -> DTree -> [String] +diffDTrees = diffDTrees' [] + +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"] + _ -> [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 [] = []