-- | Derives @Show@.  This is as defined by the Haskell report, except
-- there is no support for infix constructors.  If you attempt to
-- derive @Show@ for a data type with infix constructors, the
-- constructors are handled as if they were prefix constructors, using
-- the @(@/consym/@)@ syntax.
module Data.Derive.Show(makeShow) where

{-
import Prelude

example :: Custom
instance Show a => Show (Sample a) where
    showsPrec p (First) = $(show 0)
    showsPrec p (Second x1 x2) = $(show 1)
    showsPrec p (Third x1) = $(show 2)


test :: Sample
instance Show a => Show (Sample a) where
    showsPrec _ First = showString "First"
    showsPrec p (Second x1 x2) = showParen (p > 10) $ showString "Second " . showsPrec 11 x1 . showChar ' ' . showsPrec 11 x2
    showsPrec p (Third x1) = showParen (p > 10) $ showString "Third " . showsPrec 11 x1

test :: Computer
instance Show Computer where
    showsPrec _ (Laptop x1 x2) =
        showString "Laptop {weight = " . showsPrec 0 x1 . showString ", speed = " . showsPrec 0 x2 . showChar '}'
    showsPrec _ (Desktop x1) =
        showString "Desktop {speed = " . showsPrec 0 x1 . showChar '}'

test :: (:*:)
instance (Show a, Show b) => Show ((:*:) a b) where
    showsPrec p ((:*:) x1 x2) = showParen (p > 10) $ showString "(:*:) " . showsPrec 11 x1 . showChar ' ' . showsPrec 11 x2
-}

import Data.List
import Data.Derive.DSL.HSE
import qualified Language.Haskell as H

-- GENERATED START

import Data.Derive.DSL.DSL
import Data.Derive.Internal.Derivation

makeShow :: Derivation
makeShow = derivationCustomDSL "Show" custom $
    List [Instance ["Show"] "Show" (List [App "InsDecl" (List [App
    "FunBind" (List [MapCtor (App "Match" (List [App "Ident" (List [
    String "showsPrec"]),List [App "PVar" (List [App "Ident" (List [
    String "p"])]),App "PParen" (List [App "PApp" (List [App "UnQual"
    (List [App "Ident" (List [CtorName])]),MapField (App "PVar" (List
    [App "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])]
    )]))])])],App "Nothing" (List []),App "UnGuardedRhs" (List [App
    "SpliceExp" (List [App "ParenSplice" (List [App "App" (List [App
    "Var" (List [App "UnQual" (List [App "Ident" (List [String "show"]
    )])]),App "Lit" (List [App "Int" (List [CtorIndex])])])])])]),App
    "BDecls" (List [List []])]))])])])]
-- GENERATED STOP

-- Left is a literal string, Right is a variable

custom = customSplice splice

splice :: FullDataDecl -> Exp -> Exp
splice d (H.App x (H.Lit (H.Int y))) | x ~= "show" = combine $ compress $
        if fields then customFields c else customPlain c
    where
        fields = any (not . null . fst) (ctorDeclFields c)
        c = dataDeclCtors (snd d) !! fromInteger y

        out (Left [x]) = H.App (var "showChar") (H.Lit $ H.Char x)
        out (Left xs ) = H.App (var "showString") (H.Lit $ H.String xs)
        out (Right x) = apps (var "showsPrec") [H.Lit $ H.Int (fields ? 0 $ 11), var $ 'x' : show x]

        compress (Left x:Left y:z) = compress $ Left (x++y) : z
        compress (x:y) = x : compress y
        compress [] = []

        paren = InfixApp (H.App (var "showParen") (Paren $ InfixApp (var "p") (qvop ">") (H.Lit $ H.Int 10))) (qvop "$")
        combine xs = (fields || or [' ' `notElem` x | Left x <- xs] ? id $ paren) $
                     foldr1 (\x y -> InfixApp x (qvop ".") y) $ map out xs


customPlain :: CtorDecl -> [Either String Int]
customPlain c = intersperse (Left " ") $ Left (ctorDeclName c) : map Right [1..length (ctorDeclFields c)]

customFields :: CtorDecl -> [Either String Int]
customFields c = Left (ctorDeclName c ++ " {") : concat (intersperse [Left ", "] xs) ++ [Left "}"]
    where xs = [[Left (n ++ " = "), Right i] | (i,(n,t)) <- zip [1..] $ ctorDeclFields c]