generic-accessors (empty) → 0.1.0.0
raw patch · 9 files changed
+547/−0 lines, 9 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, generic-accessors, linear, spatial-math, test-framework, test-framework-hunit
Files
- .gitignore +1/−0
- .travis.yml +33/−0
- CHANGELOG.md +3/−0
- LICENSE +30/−0
- README.md +8/−0
- Setup.hs +2/−0
- generic-accessors.cabal +45/−0
- src/Accessors.hs +281/−0
- tests/Tests.hs +144/−0
+ .gitignore view
@@ -0,0 +1,1 @@+dist
+ .travis.yml view
@@ -0,0 +1,33 @@+# from https://github.com/hvr/multi-ghc-travis++env:+ - GHCVER=7.6.3+ - GHCVER=7.8.3 # see note about Alex/Happy++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.18 ghc-$GHCVER libgsl0-dev liblapack-dev+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.18/bin:$PATH++install:+ - cabal update+ - cabal install --only-dependencies --enable-tests --enable-benchmarks++# 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.18 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
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+0.1+---+* Initial release (moved from Plot-ho-matic repo)
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013-2015, Greg Horn++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Greg Horn nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,8 @@+generic-accessors+==++[](https://travis-ci.org/ghorn/generic-accessors)++Get a Tree or list of (String, a -> Double) pairs for use in plotting++See the tests for usage.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ generic-accessors.cabal view
@@ -0,0 +1,45 @@+name: generic-accessors+version: 0.1.0.0+synopsis: stringly-named getters for generic data+license: BSD3+license-file: LICENSE+author: Greg Horn+maintainer: gregmainland@gmail.com+copyright: Copyright (c) 2013-2015, Greg Horn+category: Data+build-type: Simple+cabal-version: >=1.10+extra-source-files:+ .gitignore+ .travis.yml+ CHANGELOG.md+ README.md+description: {+Get a Tree or list of (String, a -> Double) pairs for use in plotting and data inspection+}++library+ hs-source-dirs: src+ default-language: Haskell2010+ exposed-modules: Accessors+ build-depends: base >= 4.6.0.0 && < 5+ , linear+ , spatial-math >= 0.2.0++ ghc-options: -O2 -Wall+ ghc-prof-options: -O2 -Wall -prof -fprof-auto -fprof-cafs -rtsopts+++test-suite unit-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Tests.hs+ default-language: Haskell2010+ build-depends: generic-accessors,+ QuickCheck >= 2,+ HUnit,+ test-framework,+ test-framework-hunit,+-- test-framework-quickcheck2,+ base >=4.6 && < 5+ ghc-options: -O2
+ src/Accessors.hs view
@@ -0,0 +1,281 @@+{-# OPTIONS_GHC -Wall #-}+--{-# OPTIONS_GHC -ddump-deriv #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}++module Accessors+ ( Lookup(..)+ , AccessorTree(..)+ , accessors+ , flatten+ , showTree+ , showFlat+ ) where++import GHC.Generics++import Data.List ( intercalate )+import qualified Linear+import GHC.Word+import Data.Int+import Foreign.C.Types++import SpatialMath ( Euler )+import SpatialMathT ( V3T, Rot )++showAccTree :: String -> AccessorTree a -> [String]+showAccTree spaces (ATGetter _) = [spaces ++ "ATGetter {}"]+showAccTree spaces (Data name trees) =+ (spaces ++ "Data " ++ show name) :+ concatMap (showChild (spaces ++ " ")) trees++showChild :: String -> (String, AccessorTree a) -> [String]+showChild spaces (name, tree) =+ (spaces ++ name) : showAccTree (spaces ++ " ") tree++instance Show (AccessorTree a) where+ show = unlines . showAccTree ""++data AccessorTree a = Data (String,String) [(String, AccessorTree a)]+ | ATGetter (a -> Double)++accessors :: Lookup a => a -> AccessorTree a+accessors = flip toAccessorTree id++showMsgs :: [String] -> String+showMsgs = intercalate "."++flatten :: AccessorTree a -> [(String, a -> Double)]+flatten = flatten' []++flatten' :: [String] -> AccessorTree a -> [(String, a -> Double)]+flatten' msgs (ATGetter f) = [(showMsgs (reverse msgs), f)]+flatten' msgs (Data (_,_) trees) = concatMap f trees+ where+ f (name,tree) = flatten' (name:msgs) tree++-- | Things which you can make a tree of labeled getters for.+-- You should derive this using GHC.Generics.+class Lookup a where+ toAccessorTree :: a -> (b -> a) -> AccessorTree b++ default toAccessorTree :: (Generic a, GLookup (Rep a)) => a -> (b -> a) -> AccessorTree b+ toAccessorTree x f = gtoAccessorTree (from x) (from . f)++class GLookup f where+ gtoAccessorTree :: f a -> (b -> f a) -> AccessorTree b++class GLookupS f where+ gtoAccessorTreeS :: f a -> (b -> f a) -> [(String, AccessorTree b)]++-- some instance from linear+instance Lookup a => Lookup (Linear.V0 a) where+ toAccessorTree _ _ =+ Data ("V0", "V0") []+instance Lookup a => Lookup (Linear.V1 a) where+ toAccessorTree xyz f =+ Data ("V1", "V1") [ ("x", toAccessorTree (getX xyz) (getX . f))+ ]+ where+ getX (Linear.V1 x) = x+instance Lookup a => Lookup (Linear.V2 a) where+ toAccessorTree xyz f =+ Data ("V2", "V2") [ ("x", toAccessorTree (getX xyz) (getX . f))+ , ("y", toAccessorTree (getY xyz) (getY . f))+ ]+ where+ getX (Linear.V2 x _) = x+ getY (Linear.V2 _ y) = y+instance Lookup a => Lookup (Linear.V3 a) where+ toAccessorTree xyz f =+ Data ("V3", "V3") [ ("x", toAccessorTree (getX xyz) (getX . f))+ , ("y", toAccessorTree (getY xyz) (getY . f))+ , ("z", toAccessorTree (getZ xyz) (getZ . f))+ ]+ where+ getX (Linear.V3 x _ _) = x+ getY (Linear.V3 _ y _) = y+ getZ (Linear.V3 _ _ z) = z+instance Lookup a => Lookup (Linear.V4 a) where+ toAccessorTree xyz f =+ Data ("V4", "V4") [ ("x", toAccessorTree (getX xyz) (getX . f))+ , ("y", toAccessorTree (getY xyz) (getY . f))+ , ("z", toAccessorTree (getZ xyz) (getZ . f))+ , ("w", toAccessorTree (getW xyz) (getW . f))+ ]+ where+ getX (Linear.V4 x _ _ _) = x+ getY (Linear.V4 _ y _ _) = y+ getZ (Linear.V4 _ _ z _) = z+ getW (Linear.V4 _ _ _ w) = w+instance Lookup a => Lookup (Linear.Quaternion a) where+ toAccessorTree xyz f =+ Data ("Quaternion", "Quaternion")+ [ ("q0", toAccessorTree (getQ0 xyz) (getQ0 . f))+ , ("q1", toAccessorTree (getQ1 xyz) (getQ1 . f))+ , ("q2", toAccessorTree (getQ2 xyz) (getQ2 . f))+ , ("q3", toAccessorTree (getQ3 xyz) (getQ3 . f))+ ]+ where+ getQ0 (Linear.Quaternion q0 _) = q0+ getQ1 (Linear.Quaternion _ (Linear.V3 x _ _)) = x+ getQ2 (Linear.Quaternion _ (Linear.V3 _ y _)) = y+ getQ3 (Linear.Quaternion _ (Linear.V3 _ _ z)) = z+++instance Lookup f => GLookup (Rec0 f) where+ gtoAccessorTree x f = toAccessorTree (unK1 x) (unK1 . f)++instance (Selector s, GLookup a) => GLookupS (S1 s a) where+ gtoAccessorTreeS x f = [(selname, gtoAccessorTree (unM1 x) (unM1 . f))]+ where+ selname = case selName x of+ [] -> "()"+ y -> y++instance GLookupS U1 where+ gtoAccessorTreeS _ _ = []++instance (GLookupS f, GLookupS g) => GLookupS (f :*: g) where+ gtoAccessorTreeS (x :*: y) f = tf ++ tg+ where+ tf = gtoAccessorTreeS x $ left . f+ tg = gtoAccessorTreeS y $ right . f++ left ( x' :*: _ ) = x'+ right ( _ :*: y' ) = y'++instance (Datatype d, Constructor c, GLookupS a) => GLookup (D1 d (C1 c a)) where+ gtoAccessorTree d@(M1 c) f = Data (datatypeName d, conName c) con+ where+ con = gtoAccessorTreeS (unM1 c) (unM1 . unM1 . f)++-- basic types+instance Lookup () where -- hack to get dummy tree+ toAccessorTree _ _ = ATGetter $ const 0+instance Lookup Int where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup Float where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup Double where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup Bool where+ toAccessorTree _ f = ATGetter $ realToFrac . fromEnum . f++-- Word types+instance Lookup Word where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup Word8 where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup Word16 where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup Word32 where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup Word64 where+ toAccessorTree _ f = ATGetter $ realToFrac . f++-- Int types+instance Lookup Int8 where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup Int16 where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup Int32 where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup Int64 where+ toAccessorTree _ f = ATGetter $ realToFrac . f++-- C types+instance Lookup CChar where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CSChar where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CUChar where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CShort where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CUShort where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CInt where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CUInt where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CLong where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CULong where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CPtrdiff where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CSize where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CWchar where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CSigAtomic where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CLLong where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CULLong where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CIntPtr where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CUIntPtr where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CIntMax where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CUIntMax where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CClock where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CTime where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CUSeconds where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CSUSeconds where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CFloat where+ toAccessorTree _ f = ATGetter $ realToFrac . f+instance Lookup CDouble where+ toAccessorTree _ f = ATGetter $ realToFrac . f++-- other types+instance Lookup a => Lookup (Rot f1 f2 a)+instance Lookup a => Lookup (V3T f a)+instance Lookup a => Lookup (Euler a)++showAccTrees :: (Double -> String) -> a -> [(String, AccessorTree a)] -> String -> [String]+showAccTrees show' x trees spaces = concat cs ++ [spaces ++ "}"]+ where+ cs = zipWith (showRecordField show' x spaces) trees ("{ " : repeat ", ")++showRecordField :: (Double -> String) -> a -> String -> (String, AccessorTree a) -> String -> [String]+showRecordField show' x spaces (getterName, ATGetter f) prefix =+ [spaces ++ prefix ++ getterName ++ " = " ++ show' (f x)]+showRecordField show' x spaces (getterName, Data (_,cons) trees) prefix =+ (spaces ++ prefixNameEq ++ cons) : showAccTrees show' x trees newSpaces+ where+ prefixNameEq = prefix ++ getterName ++ " = "+ newSpaces = spaces ++ (replicate (length prefixNameEq) ' ')++-- | Show a tree of values+showTree :: AccessorTree a -> (Double -> String) -> a -> String+showTree (Data (_,cons) trees) show' x = init $ unlines $ cons : showAccTrees show' x trees ""+showTree (ATGetter f) show' x = show' (f x)++-- | Show a list of values+-- .+-- True --> align the colums, False --> total mayhem+showFlat :: forall a . AccessorTree a -> Bool -> (Double -> String) -> a -> String+showFlat at align show' x = init $ unlines $ map f fl+ where+ n = maximum (map (length . fst) fl)++ f (name, get) = name ++ spaces ++ " = " ++ show' (get x)+ where+ spaces+ | align = replicate (n - length name) ' '+ | otherwise = ""++ fl :: [(String, a -> Double)]+ fl = flatten at
+ tests/Tests.hs view
@@ -0,0 +1,144 @@+{-# OPTIONS_GHC -Wall #-}+{-# Language DeriveGeneric #-}++module Main where++import GHC.Generics ( Generic )++import Data.Monoid ( mempty )+import Text.Printf ( printf )+import Test.Framework ( ColorMode(..), RunnerOptions'(..), TestOptions'(..), defaultMainWithOpts )+import qualified Test.HUnit.Base as HUnit+import Test.Framework ( Test, testGroup )+import Test.Framework.Providers.HUnit ( testCase )++import Accessors++main :: IO ()+main = do+ defaultMainWithOpts+ [ accessorTests+ ]+ opts++opts :: RunnerOptions' Maybe+opts = mempty { ropt_color_mode = Just ColorAlways+ , ropt_threads = Just 1+ , ropt_test_options = Just my_test_opts+ }++my_test_opts :: TestOptions' Maybe+my_test_opts = mempty { topt_timeout = Just (Just 2000000) }+++data Xyz a = Xyz { xx :: Int+ , yy :: Double+ , zz :: Float+ , ww :: a+ } deriving (Generic)+data One = MkOne { one :: Double } deriving (Generic)+data Foo = MkFoo { aaa :: Int+ , bbb :: Xyz Int+ , yoyo :: Xyz (Xyz Double)+ , ccc :: One+ } deriving (Generic)+instance Lookup One+instance Lookup a => Lookup (Xyz a)+instance Lookup Foo++yo :: Xyz (Xyz Double)+yo = Xyz 42 45 2000 (Xyz 2 3 4 5)++foo :: Foo+foo = MkFoo 2 (Xyz 6 7 8 9) yo (MkOne 17)++yup :: AccessorTree Foo+yup = accessors foo+++accessorTests :: Test+accessorTests =+ testGroup "accessors"+ [ testCase "showTree" treeTest+ , testCase "showFlat" flatTest+ , testCase "showFlat (aligned)" flatTestAligned+ ]++assertEqualString :: String -> String -> HUnit.Assertion+assertEqualString x y = HUnit.assertBool msg (x == y)+ where+ msg = "------------------ expected: ------------------\n" +++ x +++ "\n------------------ but got: -------------------\n" +++ y +++ "\n-----------------------------------------------"++treeTest :: HUnit.Assertion+treeTest = assertEqualString x y+ where+ x = init $ unlines+ [ "MkFoo"+ , "{ aaa = 2.00e0"+ , ", bbb = Xyz"+ , " { xx = 6.00e0"+ , " , yy = 7.00e0"+ , " , zz = 8.00e0"+ , " , ww = 9.00e0"+ , " }"+ , ", yoyo = Xyz"+ , " { xx = 4.20e1"+ , " , yy = 4.50e1"+ , " , zz = 2.00e3"+ , " , ww = Xyz"+ , " { xx = 2.00e0"+ , " , yy = 3.00e0"+ , " , zz = 4.00e0"+ , " , ww = 5.00e0"+ , " }"+ , " }"+ , ", ccc = MkOne"+ , " { one = 1.70e1"+ , " }"+ , "}"+ ]+ y = showTree yup (printf "%.2e") foo++flatTest :: HUnit.Assertion+flatTest = assertEqualString x y+ where+ x = init $ unlines+ [ "aaa = 2.00e0"+ , "bbb.xx = 6.00e0"+ , "bbb.yy = 7.00e0"+ , "bbb.zz = 8.00e0"+ , "bbb.ww = 9.00e0"+ , "yoyo.xx = 4.20e1"+ , "yoyo.yy = 4.50e1"+ , "yoyo.zz = 2.00e3"+ , "yoyo.ww.xx = 2.00e0"+ , "yoyo.ww.yy = 3.00e0"+ , "yoyo.ww.zz = 4.00e0"+ , "yoyo.ww.ww = 5.00e0"+ , "ccc.one = 1.70e1"+ ]+ y = showFlat yup False (printf "%.2e") foo++flatTestAligned :: HUnit.Assertion+flatTestAligned = assertEqualString x y+ where+ x = init $ unlines+ [ "aaa = 2.00e0"+ , "bbb.xx = 6.00e0"+ , "bbb.yy = 7.00e0"+ , "bbb.zz = 8.00e0"+ , "bbb.ww = 9.00e0"+ , "yoyo.xx = 4.20e1"+ , "yoyo.yy = 4.50e1"+ , "yoyo.zz = 2.00e3"+ , "yoyo.ww.xx = 2.00e0"+ , "yoyo.ww.yy = 3.00e0"+ , "yoyo.ww.zz = 4.00e0"+ , "yoyo.ww.ww = 5.00e0"+ , "ccc.one = 1.70e1"+ ]+ y = showFlat yup True (printf "%.2e") foo