TH.hs

{-# LANGUAGE
    TemplateHaskell
  , ViewPatterns
  , FlexibleInstances #-}

-- | Generate instances for converting lists of strings to records.

module Text.RowRecord.TH
  ( rowRecords
  ) where

import Text.RowRecord

import Control.Applicative

import Language.Haskell.TH
import Language.Haskell.TH.Syntax

-- Turn a record label name into a column name.
-- Drop everything through the first '_'.
getColumn :: Name -> Column
getColumn = f . nameBase where
  f (break (=='_') -> (_, ('_':xs))) = xs
  f n = error ("RowRecord: bad label: " ++ n)

-- | Generate a @'ParseRow'@ instance for each of the named types.
--
-- Each type must have exactly one constructor, in record style.
--
-- Column names are derived from the record field names by dropping the first
-- @'_'@-separated component.  This allows for a prefix to disambiguate record
-- labels between types.
--
-- For example, with
--
-- > data Foo = Foo
-- >   { f_bar :: String
-- >   , f_baz :: Int }
-- > $(rowRecords [''Foo])
--
-- we can parse files of the form
-- 
-- > bar,baz
-- > abc,3
-- > def,5
--
-- assuming an appropriate CSV parser.

rowRecords :: [Name] -> Q [Dec]
rowRecords ns = concat <$> mapM rowRecord ns

rowRecord :: Name -> Q [Dec]
rowRecord n = do
  i <- reify n
  case i of
    TyConI (DataD    _ _ _ [c] _) -> fromCon n c
    TyConI (NewtypeD _ _ _ c   _) -> fromCon n c
    _ -> error ("RowRecord: not a data type: " ++ show n)

fromCon :: Name -> Con -> Q [Dec]
fromCon ty (RecC ctor fields) =
  let gets m = [ [| getField $(lift $ getColumn n) $(varE m) |]
               | (n,_,_) <- fields ]
      splat a b = [| $a <*> $b |]
      bdy = [| \m -> $(foldl1 splat ([| pure $(conE ctor) |] : gets 'm)) |]
  in  [d| instance ParseRow $(conT ty) where { parseRow = $bdy } |]

fromCon _ c = error ("RowRecord: not a record: " ++ show c)