Collect.hs

{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE TypeSynonymInstances   #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE OverlappingInstances   #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE PolyKinds              #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  HarmTrace.Models.Collect
-- Copyright   :  (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford
-- License     :  GPL3
--
-- Maintainer  :  bash@cs.uu.nl, jpm@cs.ox.ac.uk
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Summary: Generic collect
--------------------------------------------------------------------------------

module HarmTrace.Models.Collect ( CollectG (..), collectGdefault ) where

-- Generics stuff
import Generics.Instant.Base as G


--------------------------------------------------------------------------------
-- The generic part of the parser
--------------------------------------------------------------------------------

class Collect' a b where
   collect' :: a -> [b]

instance Collect' U b where
  collect' _ = []

instance (CollectG a b) => Collect' (Rec a) b where
  collect' (Rec x) = collectG x

-- Not really necessary because TH is not generating any Var, but anyway
instance (CollectG a b) => Collect' (Var a) b where
  collect' (Var x) = collectG x

instance (Collect' a b) => Collect' (G.CEq c p q a) b where 
  collect' (G.C x) = collect' x

instance (Collect' a c, Collect' b c) => Collect' (a :+: b) c where
  collect' (L x) = collect' x
  collect' (R x) = collect' x

instance (Collect' a c, Collect' b c) => Collect' (a :*: b) c where
  collect' (a :*: b) = collect' a ++ collect' b


class CollectG a b where
  collectG :: a -> [b]

instance (CollectG a b) => CollectG [a] b where
  collectG = concatMap collectG

-- | default generic parser
collectGdefault :: (Representable a, Collect' (Rep a) b) => a -> [b]
collectGdefault = collect' . from