module Data.Relational.Lists (
Tabulation
, Record(..)
, Table(..)
, readTable
, writeTable
, makeTable
) where
import Control.Monad (guard, msum)
import Data.Binary (Binary(..))
import Data.Default (Default(..))
import Data.List (union)
import Data.List.Util.Listable (readTabbedListsWithHeader, writeTabbedListsWithHeader)
import Data.String.Util (Stringy)
import Data.Relational (Relation(..), Tuple(..))
type Tabulation a = Table (Record a)
newtype Record a = Record {unRecord :: [a]}
deriving (Eq, Read, Show)
instance Tuple (Record a) where
type Attribute (Record a) = a
makeTuple = Record
attributes = unRecord
instance Functor Record where
fmap f = Record . fmap f . unRecord
instance Foldable Record where
foldMap f = foldMap f . unRecord
instance Binary a => Binary (Record a) where
put = put . unRecord
get = Record <$> get
data Table r =
Table
{
header :: [String]
, records :: [r]
}
instance Tuple r => Relation String r (Table r) where
names = header
empty = flip Table []
makeRelation = Table
tuples = records
attributeMaybe Table{..} name =
msum
. zipWith (\n a -> guard (n == name) >> return a) header
. attributes
instance Functor Table where
fmap f Table{..} =
Table header $ fmap f records
instance Foldable Table where
foldMap f Table{..} =
foldMap f records
instance (Monoid (Attribute r), Tuple r) => Monoid (Table r) where
mempty = Table [] []
mappend x y =
let
header' = header x `union` header y
makePadder ns =
let
pattern = map (`elem` ns) header'
pad (False : us) vs = mempty : pad us vs
pad (True : us) (v : vs) = v : pad us vs
pad [] _ = []
pad _ [] = []
in
makeTuple . pad pattern . attributes
in
Table header' $ map (makePadder $ header x) (records x) ++ map (makePadder $ header y) (records y)
instance (Read (Attribute r), Tuple r) => Read (Table r) where
readsPrec p =
readParen (p > 10)
$ \ r -> do
("fromLists", s) <- lex r
(ns, t) <- reads s
(rs, u) <- reads t
return (Table ns $ map makeTuple rs, u)
instance (Show (Attribute r), Tuple r) => Show (Table r) where
show Table{..} = "fromLists " ++ show header ++ " " ++ show (map attributes records)
instance Binary r => Binary (Table r) where
put Table{..} = put (header, records)
get = uncurry Table <$> get
readTable :: (Stringy (Attribute r), Tuple r)
=> FilePath
-> IO (Table r)
readTable = readTabbedListsWithHeader
writeTable :: (Stringy (Attribute r), Tuple r)
=> FilePath
-> Table r
-> IO ()
writeTable = writeTabbedListsWithHeader
makeTable :: forall r . (Default (Table r), Tuple r)
=> [r]
-> Table r
makeTable = makeRelation (header (def :: Table r))