{-# OPTIONS_GHC -fglasgow-exts #-}

-- Regular library with functional dependencies

module Regular where

data K a r       = K { unK :: a }
data I r         = I { unI :: r }
data U r         = U
data (f :+: g) r = L (f r) | R (g r)
data (f :*: g) r = f r :*: g r
data C c f r =  C { unC :: f r }

infixr 6 :+:
infixr 7 :*:

class Constructor c where
  conName   :: t c (f :: * -> *) r -> String
  conFixity :: t c (f :: * -> *) r -> Fixity
  conFixity = const Prefix

data Fixity = Prefix | Infix Associativity Int
  deriving (Eq, Show, Ord, Read)

data Associativity = LeftAssociative | RightAssociative | NotAssociative
  deriving (Eq, Show, Ord, Read)

class Regular a where
  type PF a :: * -> *
  from      :: a -> PF a a
  to        :: PF a a -> a

class GShow f where
  gshowfS :: (a -> ShowS) -> f a -> ShowS
  gshowf :: (a -> String) -> f a -> String
instance GShow I where
  gshowfS f (I r) = f r
  gshowf f (I r) = f r
instance Show a => GShow (K a) where
  gshowfS _ (K x) = shows x
  gshowf _ (K x) = show x
instance GShow U where
  gshowfS _ U = id
  gshowf _ U = ""
instance (GShow f, GShow g) => GShow (f :+: g) where
  gshowfS f (L x) = gshowfS f x
  gshowfS f (R x) = gshowfS f x
  gshowf f (L x) = gshowf f x
  gshowf f (R x) = gshowf f x
instance (GShow f, GShow g) => GShow (f :*: g) where
  gshowfS f (x :*: y) = gshowfS f x . showChar ' ' . gshowfS f y
  gshowf f (x :*: y) = gshowf f x ++ " " ++ gshowf f y
instance (Constructor c, GShow f) => GShow (C c f) where
  gshowfS f cx@(C x) = 
    showParen True (showString (conName cx) . showChar ' ' . gshowfS f x)
  gshowf f cx@(C x) = "(" ++ conName cx ++ " " ++ gshowf f x ++ ")"

gshowS :: (Regular a, GShow (PF a)) => a -> ShowS
{- SPECIALIZE gshowS :: Logic -> ShowS #-}
gshowS x = gshowfS gshowS (from x)

gshow :: (Regular a, GShow (PF a)) => a -> String
-- This pragma works
{- SPECIALIZE gshow :: Logic -> String #-}
-- but adding
{- INLINE gshow #-}
-- doesn't help inlining the specialized gshow, and
{- SPECIALIZE INLINE gshow :: Logic -> String #-}
-- does something strange
gshow x = gshowf gshow (from x)