diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2020 paroxayte + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/pprecord.cabal b/pprecord.cabal new file mode 100644 --- /dev/null +++ b/pprecord.cabal @@ -0,0 +1,33 @@ +cabal-version: >= 1.10 +-- Initial package description 'pprecord.cabal' generated by 'cabal init'. +-- For further documentation, see http://haskell.org/cabal/users-guide/ + +name: pprecord +version: 0.1.0.0 +synopsis: A library for pretty printing Records +description: A pretty-printing library which is accumulates record + accessors as Strings, and fields as Strings or formatted + boxes. Functions are included to output lists of records as + a table, or apply a format to individual records. +homepage: https://github.com/paroxayte/pprecord +author: paroxayte +maintainer: 36929366+paroxayte@users.noreply.github.com +category: Text +license: MIT +license-file: LICENSE +build-type: Simple +tested-with: GHC==8.8.2 + GHC==8.6.5 + GHC==8.4.4 + +library + build-depends: base >= 4.11.1 && < 4.14, + boxes >= 0.1.5 && < 0.2 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + exposed-modules: Text.PrettyPrint.Records + +source-repository head + type: git + location: https://github.com/pprecord diff --git a/src/Text/PrettyPrint/Records.hs b/src/Text/PrettyPrint/Records.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/Records.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +module Text.PrettyPrint.Records (FQuery, VQuery, RFmt, format, formatUntil, fields, values, + dfltFmt, simpleFmt, tableFmt, Format(..), TableFmt(..), formatTable) where + +import GHC.Generics +import Data.Typeable (cast, Typeable) +import Text.PrettyPrint.Boxes ((<+>), vcat, text, Box(), left, hsep, top) +import Data.List (transpose) + +--- FQuery ------------------------------------------------------------------- + +class FQuery' f where + fields' :: f p -> [String] + +instance FQuery' V1 where + fields' _ = [] + +instance FQuery' U1 where + fields' _ = [] + +instance FQuery c => FQuery' (Rec0 c) where + fields' _ = [] + +instance (FQuery' f, FQuery' g) => FQuery' (f :*: g) where + fields' (x :*: y) = fields' x <> fields' y + +instance FQuery' f => FQuery' (D1 c f) where + fields' (M1 x) = fields' x + +instance FQuery' f => FQuery' (C1 c f) where + fields' (M1 x) = fields' x + +instance Selector s => FQuery' (S1 s f) where + fields' x = [selName x] + +-- | Accumulate Record accessors as [String] (in order of definition). +class FQuery a where + fields :: a -> [String] + default fields :: (Generic a, FQuery' (Rep a)) => a -> [String] + fields = fields' . from + +-- VQuery ---------------------------------------------------------------------- + +class VQuery' f where + values' :: f p -> [String] + +instance VQuery' f => VQuery' (M1 t c f) where + values' (M1 x) = values' x + +instance (VQuery' f, VQuery' g) => VQuery' (f :*: g) where + values' (x :*: y) = values' x <> values' y + +instance (Show c) => VQuery' (Rec0 c) where + values' K1{unK1=v} = [show v] + +instance VQuery' U1 where + values' _ = [] + +instance VQuery' V1 where + values' _ = [] + +-- | Accumulate Record values as [String] (in order of definition). +class VQuery a where + values :: a -> [String] + default values :: (Generic a, VQuery' (Rep a)) => a -> [String] + values = values' . from + +-- RFmt ------------------------------------------------------------------------ + +-- |A Format is responsible for converting a Record into a formatted Box. +-- +-- @ +-- __Example:__ +-- dfltFmt :: Format a +-- dfltFmt = Format +-- { arg = text +-- , label = \\a b -> text (a <> ":") <+> b +-- , finally = vcat left } +-- @ +-- +data Format a = Format + { -- | Converts Record fields to Boxes + arg :: String -> Box, + -- | Merge accessor with field + label :: String -> Box -> Box, + -- | Finally reduce list of boxes + finally :: [Box] -> Box + } + +class RFmt' f where + fvalues' :: (Typeable a, RFmt a) => Int -> f p -> Format a -> [Box] + +-- |Reduce Record to Box given a Format +-- +-- @ +-- +-- __Example:__ +-- data List a = List { label :: String, val :: a, tail :: List a } +-- | Nil deriving (Generic, Show) +-- instance FQuery (List a) +-- instance (Show a, Typeable a) => RFmt (List a) +-- test = List "head" 3 $ List "mid" 4 $ List "tail" 5 $ Nil +-- +-- ghci> printBox $ format test dfltFmt +-- label: "head" +-- val: 3 +-- tail: label: "mid" +-- val: 4 +-- tail: label: "tail" +-- val: 5 +-- tail: Nil +-- @ +-- +class (Typeable a, FQuery a, Show a) => RFmt a where + fvalues :: Int -> a -> Format a -> [Box] + default fvalues :: (Generic a, RFmt' (Rep a)) => Int -> a -> Format a -> [Box] + fvalues 0 _ _ = [text "....."] + fvalues n a f = fvalues' n (from a) f + +instance RFmt' f => RFmt' (M1 t c f) where + fvalues' n (M1 x) = fvalues' n x + +instance (RFmt' f, RFmt' g) => RFmt' (f :*: g) where + fvalues' n (x :*: y) f = let + l = fvalues' n x f + r = fvalues' n y f + in l <> r + +instance (Typeable c, Show c) => RFmt' (Rec0 c) where + fvalues' n K1{unK1=v} f = let + g :: Typeable k => Format k -> Maybe k + g _ = cast v + in case g f of + Nothing -> [arg f . show $ v] + Just x -> [formatUntil (n - 1) x f] + +instance RFmt' U1 where + fvalues' _ _ _ = [] + +instance RFmt' V1 where + fvalues' _ _ _ = [] + +-- Helpers --------------------------------------------------------------------- + +data TableFmt = TableFmt + { -- | Converts Record fields to Boxes + argT :: String -> Box, + -- | Merge accessor with field + labelT :: String -> [Box] -> Box, + -- | Finally reduce list of boxes + finallyT :: [Box] -> Box + } + +dfltFmt :: Format a +dfltFmt = Format + { arg = text + , label = \a b -> text (a <> ":") <+> b + , finally = vcat left } + +-- | A table formatter which produces a top-down table +tableFmt :: TableFmt +tableFmt = TableFmt + { argT = text + , labelT = \a bs -> vcat left $ text a : bs + , finallyT = hsep 1 top } + +-- | Given String representation of accessor and value return b +simpleFmt :: (VQuery a, FQuery a) => (String -> String -> b) -> a -> [b] +simpleFmt f x = zipWith f (fields x) (values x) + +-- | Format Record a with up to n levels of recursivity +formatUntil :: RFmt a => Int -> a -> Format a -> Box +formatUntil n a f = let + lhs = fields a + rhs = fvalues n a f + in if null rhs + then arg f . show $ a + else finally f $ zipWith (label f) lhs rhs + +-- | Format Record a record fully expanding the data structure if it is +-- recursive +format :: RFmt a => a -> Format a -> Box +format = formatUntil (-1) + +-- | Format a list of RFmt instances as a table (no recursive expansion). +-- +-- @ +-- __Example:__ +-- data Employee = E +-- { eId :: Int +-- , name :: String +-- , email :: String } deriving (Generic, Show) +-- instance FQuery Employee +-- instance RFmt Employee +-- e1 = E 3 \"John\" "johnbelcher@foobar.xyz" +-- e1 = E 3 \"John\" "johnbelcher@foobar.xyz" +-- e2 = E 17 \"Maria\" "Mariafoobar@net.net" +-- e3 = E 1 \"Stanley\" "stanleytheceo@foobar.org" +-- e4 = E 2 \"Kayla\" "klabar@foo.com" +-- e5 = E 4 \"Sammy\" "sammersfoobar@foo.bar" +-- +-- ghci> printBox $ formatTable [e1, e2, e3, e4, e5] tableFmt +-- eId name email +-- 3 \"John\" "johnbelcher@foobar.xyz" +-- 17 \"Maria\" "Mariafoobar@net.net" +-- 1 \"Stanley\" "stanleytheceo@foobar.org" +-- 2 \"Kayla\" "klabar@foo.com" +-- 4 \"Sammy\" "sammersfoobar@foo.bar" +-- @ +-- +formatTable :: RFmt a => [a] -> TableFmt -> Box +formatTable as t = let + minFmt = Format (argT t) undefined (finallyT t) + header = fields (head as) + fvals = transpose $ flip (fvalues 1) minFmt <$> as + in finallyT t $ zipWith (labelT t) header fvals