-- Code from Section 12.2

module Generic where
import PhantomTypes
import Char
import PrettierPrinter

data Type t =              RInt  (Int   :=: t)
            |              RChar (Char  :=: t)
            | forall a   . RList ([a]   :=: t) (Type a)
            | forall a b . RPair ((a,b) :=: t) (Type a) (Type b)

rInt :: Type Int
rInt = RInt refl

rChar :: Type Char
rChar = RChar refl

rList :: forall a . Type a -> Type [a]
rList t = RList refl t

rPair :: forall a b . Type a -> Type b -> Type (a,b)
rPair t1 t2 = RPair refl t1 t2

rString :: Type String
rString = rList rChar

data Bit = Zero | One

instance Show Bit where
   showsPrec _ Zero s = '0':s
   showsPrec _ One s = '1':s
   showList bits s = '<':showBits bits ('>':s)

showBits [] = id
showBits (b:bs) = showsPrec 0 b . showBits bs

compress :: forall t . Type t -> t -> [Bit]
compress (RInt p) i = compressInt (to p i)
compress (RChar p) c = compressChar (to p c)
compress (RList p ra) as 
  = case to p as of
      [] -> Zero:[]
      (a:as) -> One:compress ra a ++ compress (RList p ra) (from p as)
compress (RPair p ra rb) pair 
 = let (a,b) = to p pair in compress ra a ++ compress rb b

digit 0 = Zero
digit 1 = One

compressInt :: Int -> [Bit]
compressInt n = take 32 $ compressInt' n

compressChar :: Char -> [Bit]
compressChar c = take 7 $ compressInt' (ord c)

compressInt' 0 = repeat Zero
compressInt' n = digit (n `mod` 2):compressInt' (n `div` 2)

-- pretty renamed to makeDoc to avoid clash with pretty from PrettierPrinter
-- module; Doc type in chapter 12 actually needs to be DOC for consistency 
-- with the final code from chapter 11

makeDoc :: forall t . Type t -> t -> DOC
makeDoc (RInt p) i = makeDocInt (to p i)
makeDoc (RChar p) c = makeDocChar (to p c)
makeDoc (RList p (RChar p')) s = makeDocString (map (to p') (to p s))
makeDoc (RList p ra) as 
 = case to p as of
     [] -> text "[]"
     (a:as) -> block 1 (text "[" <> makeDoc ra a <> makeDocL as)
       where makeDocL [] = text "]"
             makeDocL (a:as) = text "," <> line <> makeDoc ra a <> makeDocL as
makeDoc (RPair p ra rb) pair = let (a,b) = to p pair
                              in block 1 (text "(" <> makeDoc ra a <> text ","
                                          <> line <> makeDoc rb b <> text ")")

block :: Int -> DOC -> DOC
block i d = group (nest i d)

makeDocInt :: Int -> DOC
makeDocInt i = text $ show i

makeDocChar :: Char -> DOC
makeDocChar c = text $ show c

makeDocString :: String -> DOC
makeDocString s = text $ show s