diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,1 @@ +dist diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -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 diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +0.1 +--- +* Initial release (moved from Plot-ho-matic repo) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,8 @@ +generic-accessors +== + +[![Build Status](https://travis-ci.org/ghorn/generic-accessors.png?branch=master)](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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/generic-accessors.cabal b/generic-accessors.cabal new file mode 100644 --- /dev/null +++ b/generic-accessors.cabal @@ -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 diff --git a/src/Accessors.hs b/src/Accessors.hs new file mode 100644 --- /dev/null +++ b/src/Accessors.hs @@ -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 diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -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