Lists.hs

-----------------------------------------------------------------------------
--
-- Module      :  Data.Relational.Lists
-- Copyright   :  (c) 2015-16 Brian W Bush
-- License     :  MIT
--
-- Maintainer  :  Brian W Bush <consult@brianwbush.info>
-- Stability   :  Experimental
-- Portability :  Portable
--
-- | Tuples and relations as lists.
--
-----------------------------------------------------------------------------


{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE RecordWildCards           #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE UndecidableInstances      #-}

{-# OPTIONS_GHC -fno-warn-deprecations #-}


module Data.Relational.Lists {-# DEPRECATED "This module will be replaced in a future release." #-} (
-- * Types
  Tabulation
, Record(..)
, Table(..)
-- * Input/Output
, 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(..))


-- | A tabulation.
type Tabulation a = Table (Record a)


-- | A record.
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


-- | A table.
data Table r =
  Table
  {
    header  :: [String] -- ^ The header.
  , records :: [r]      -- ^ The records.
  }

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


-- | Read a table.
readTable :: (Stringy (Attribute r), Tuple r)
          => FilePath                         -- ^ The file path.
          -> IO (Table r)                     -- ^ Action to read the table.
readTable = readTabbedListsWithHeader


-- | Write a table.
writeTable :: (Stringy (Attribute r), Tuple r)
           => FilePath                         -- ^ The file path.
           -> Table r                          -- ^ The table.
           -> IO ()                            -- ^ Action to write the table.
writeTable = writeTabbedListsWithHeader


-- | Make a table.
makeTable :: forall r . (Default (Table r), Tuple r)
          => [r]                                     -- ^ The records.
          -> Table r                                 -- ^ The table.
makeTable = makeRelation (header (def :: Table r))