{-# LANGUAGE NoMonoLocalBinds, NamedFieldPuns #-}
{-# OPTIONS_GHC -pgmF drift-ghc -F #-}
module FrontEnd.Class(
    printClassHierarchy,
    instanceToTopDecls,
    ClassHierarchy(),
    augmentClassHierarchy,
    chToClassHead,
    ClassRecord(..),
    ClassType(..),
    instanceName,
    defaultInstanceName,
    checkForDuplicateInstaces,
    printClassSummary,
    findClassInsts,
    findClassRecord,
    asksClassRecord,
    classRecords,
    addInstanceToHierarchy,
    makeClassHierarchy,
    scatterAliasInstances,
    derivableClasses,
    enumDerivableClasses,
    noNewtypeDerivable,
    makeInstanceEnv,
    emptyInstance,
    InstanceEnv(..),
    Inst(..)
    ) where

import Control.Monad.Identity
import Control.Monad.Writer(Monoid(..))
import Data.Generics(mkQ,something)
import Data.List(nub)
import Data.Maybe
import Debug.Trace
import Text.PrettyPrint.HughesPJ(render,Doc())
import Text.Printf
import qualified Data.List
import qualified Data.Map as Map
import qualified Text.PrettyPrint.HughesPJ as PPrint

import Data.Binary
import Doc.DocLike
import Doc.PPrint
import FrontEnd.HsSyn
import FrontEnd.KindInfer
import FrontEnd.SrcLoc
import FrontEnd.Tc.Kind
import FrontEnd.Tc.Type
import FrontEnd.Utils
import FrontEnd.Warning
import Name.Name
import Name.Names
import Options (verbose)
import Support.FreeVars
import Support.MapBinaryInstance
import Support.Tickle
import Util.Gen
import Util.Inst()

type Assump = (Name,Sigma)

data Inst = Inst {
    instSrcLoc  :: SrcLoc,
    instDerived :: !Bool,   -- ^ whether this instance was derived
    instHead    :: Qual Pred,
    instAssocs  :: [(Tycon,[Tyvar],[Tyvar],Sigma)]
    } deriving(Eq,Ord,Show)
    {-! derive: Binary !-}

instance PPrint a (Qual Pred) => PPrint a Inst where
    pprint Inst { instHead = h, instAssocs = [], instDerived = d } = (if d then text "*" else text " ") <> pprint h
    pprint Inst { instHead = h, instAssocs = as, instDerived = d } = (if d then text "*" else text " ") <> pprint h <+> text "where" <$> vcat [ text "    type" <+> pprint n <+> text "_" <+> hsep (map pprint ts) <+> text "=" <+> pprint sigma  | (n,_,ts,sigma) <- as]

emptyInstance = Inst { instDerived = False, instSrcLoc = bogusASrcLoc, instHead = error "emptyInstance", instAssocs = [] }

-- augment heirarchy with just instances with full class definitions
augmentClassHierarchy :: ClassHierarchy -> ClassHierarchy -> ClassHierarchy
augmentClassHierarchy (CH full _) (CH res is) = ans where
    ans = CH (Map.mapWithKey f is) is
    f cn _ = r where Just r = Map.lookup cn (Map.union res full)

data ClassType = ClassNormal | ClassTypeFamily | ClassDataFamily | ClassAlias
        deriving(Eq,Ord)

-- Bool is true if data declaration instead of type declaration
data AssociatedType = Assoc !Tycon !Bool [Tyvar] Kind
    deriving(Eq,Show)
    {-! derive: Binary !-}

data ClassRecord = ClassRecord {
    className    :: !Class, -- ^ can be a TypeConstructor if we are a type or data family
    classSrcLoc  :: !SrcLoc,
    classArgs    :: [Tyvar],
    classSupers  :: [Class], -- TODO: should be Pred
    classAlias   :: Maybe (Qual [Pred]),
    classAssumps :: [(Name,Sigma)], -- ^ method signatures
    classAssocs  :: [AssociatedType]
    } deriving (Show,Eq)
    {-! derive: Binary !-}

newtype InstanceEnv = InstanceEnv {
    instanceEnv :: Map.Map (Name,Name) ([Tyvar],[Tyvar],Type) }

makeInstanceEnv :: ClassHierarchy -> InstanceEnv
makeInstanceEnv (CH _ is) = InstanceEnv $ Map.fromList (concatMap f (Map.toList is)) where
    f (cr,is) = concatMap (g cr) is
    g cr Inst { instHead = _ :=> IsIn _cname tt, instAssocs = as } | _cname == cr = ans where
        ans = [ ((tyconName tc,getTypeHead tt),(is,rs,e)) | (tc,is,rs,e) <- as]
    g cr x = error $  "makeInstanceEnv: " ++ show (cr,x)

getTypeHead th = case fromTAp th of
    (TArrow {},_) -> tc_Arrow
    (TCon c,_) -> tyconName c
    _ -> error $ "getTypeHead: " ++ show th

data ClassHierarchy = CH (Map.Map Class ClassRecord) (Map.Map Class [Inst])

instance Binary ClassHierarchy where
    get = do
        m1 <- getMap
        m2 <- getMap
        return (CH m1 m2)
    put (CH m1 m2) = do
        putMap m1
        putMap m2

instance Monoid ClassHierarchy where
    mempty = CH mempty mempty
    mappend (CH a b) (CH c d) =
        CH (Map.union a c) (Map.unionWith Data.List.union b d)

classRecords :: ClassHierarchy -> [ClassRecord]
classRecords (CH ch _) = Map.elems ch

findClassRecord (CH ch _) cn = case Map.lookup cn ch of
    Nothing -> error $ "findClassRecord: " ++ show cn
    Just n -> n

asksClassRecord (CH ch _) cn f = case Map.lookup cn ch of
    Nothing -> error $ "asksClassRecord: " ++ show cn
    Just n -> f n
findClassInsts (CH _ is) cn = fromMaybe [] (Map.lookup cn is)

showInst :: Inst -> String
showInst = PPrint.render . pprint

aHsTypeSigToAssumps :: KindEnv -> HsDecl -> [(Name,Type)]
aHsTypeSigToAssumps kt ~sig@(HsTypeSig _ names qualType) = [ (toName Val n,typ) | n <- names] where
    Identity typ = hsQualTypeToSigma kt qualType

qualifyMethod :: [HsAsst] -> HsDecl -> HsDecl
qualifyMethod ~[HsAsst c [n]] ~(HsTypeSig sloc names (HsQualType oc t))
    = HsTypeSig sloc names (HsQualType (HsAsst c [n']:oc) t) where
        Just n' = (something (mkQ mzero f)) t
        f (HsTyVar n') | hsNameToOrig n' == hsNameToOrig n = return n'
        f _ = mzero

printClassSummary :: ClassHierarchy -> IO ()
printClassSummary (CH h is) = mapM_ f (Map.toList h) where
    --h' = [ (n,fromJust $ Map.lookup n h) | n <- (map fst [ (cn, classSupers ss) | (cn,ss) <- Map.toList h]) ]
    f (cname, ClassRecord { .. }) = do
        putStrLn $ "-- class: " ++ show cname
        let insts = fromMaybe [] (Map.lookup cname is)
        unless (null classSupers) $ putStrLn $ "super classes:" ++ unwords (map show classSupers)
        unless (null insts) $ putStrLn $ "instances: " ++ (intercalate ", " (map showInst insts))
--        putStrLn ""
--    f (cname, (ClassAliasRecord { classSupers = supers, classInsts = insts, classClasses = classes })) = do
--        putStrLn $ "-- class: " ++ show cname
--        unless (null supers) $ putStrLn $ "super classes:" ++ unwords (map show supers)
--        unless (null insts) $ putStrLn $ "instances: " ++ (intercalate ", " (map showInst insts))
--        unless (null classes) $ putStrLn $ "alias for: " ++ unwords (map show classes)
--        putStrLn ""

printClassHierarchy :: ClassHierarchy -> IO ()
printClassHierarchy (CH h is) = mapM_ printClassDetails $  Map.toList h where
    printClassDetails :: (Name, ClassRecord) -> IO ()
    printClassDetails (cname, cr) = do
        let args = classArgs cr; supers = classSupers cr;
            methodAssumps = classAssumps cr
            assocs = classAssocs cr
        let insts = fromMaybe [] (Map.lookup cname is)
        putStrLn "..........."
        putStrLn $ "class: " ++ hsep (pprint cname:map pprintParen args)
        putStr $ "super classes:"
        pnone supers $ do putStrLn $ " " ++ (intercalate " " (map show supers))
        putStr $ "instances:"
        pnone insts $  putStr $ "\n" ++ (showListAndSepInWidth showInst 80 ", " insts)
        when True $ do
            putStr $ "method signatures:"
            pnone methodAssumps $ putStr $ "\n" ++ (unlines $ map pretty methodAssumps)
            putStr $ "associated types:"
            pnone assocs $  putStrLn $ "\n" ++ (unlines $ map (render . passoc) assocs)
        when (isJust (classAlias cr)) $ do
            let Just x = classAlias cr
            putStr $ "alias for:"
            putStrLn (pprint x)
            --Just $ --pnone classes $ do putStrLn $ " " ++ (intercalate " " (map show classes))
        putStr "\n"
    pnone [] f = putStrLn " none"
    pnone xs f = f
    passoc (Assoc nk isData as kt) = text (if isData then "data" else "type") <+>
        pprint nk <+> hsep (map pprint as) <+> text "::" <+> pprint kt

-- this does not check for duplicates, use checkForDuplicateInstaces after all
-- instances have been added to do so.
addInstanceToHierarchy :: Inst -> ClassHierarchy -> ClassHierarchy
addInstanceToHierarchy inst@Inst { instHead = cntxt :=> ~(IsIn className _) } (CH r i) =
    CH r (Map.insertWith Data.List.union className [inst] i)

-- Kind inference has already been done so we don't need to check for kind
-- errors here.
hsInstDeclToInst :: Monad m => KindEnv -> HsDecl -> m [Inst]
hsInstDeclToInst kt (HsInstDecl sloc qType decls)
    = return [emptyInstance { instSrcLoc = sloc, instDerived = False,
        instHead = cntxt :=> IsIn className convertedArgType, instAssocs = assocs }]
   where
   (cntxt, (className, [convertedArgType])) = chToClassHead kt qType
   assocs = [ (tc,as,bs,s) | (tc,as,bs,~(Just s)) <- createInstAssocs kt decls ]
hsInstDeclToInst kt (HsDeclDeriving sloc qType)
        = return [emptyInstance { instSrcLoc = sloc, instDerived = True,
        instHead = cntxt :=> IsIn className convertedArgType }]
   where (cntxt, (className, [convertedArgType])) = chToClassHead kt qType
hsInstDeclToInst _ _ = return []

vtrace s v | False && verbose = trace s v
vtrace s v | otherwise = v

chToClassHead :: KindEnv -> HsClassHead -> ([Pred],(Name,[Type]))
chToClassHead kt qt@HsClassHead { .. }  =
    vtrace ("chToClassHead" <+> show qt) $
    let res = (map (hsAsstToPred kt) hsClassHeadContext,(hsClassHead,
            map (runIdentity . hsTypeToType (kiHsQualType kt (HsQualType hsClassHeadContext (HsTyTuple [])))) hsClassHeadArgs))
    in vtrace ("=" <+> show res) res

createClassAssocs kt decls = [ Assoc (ctc n) False (map ct as) (ctype t) | HsTypeDecl { hsDeclName = n, hsDeclTArgs = as, hsDeclType = t } <- decls ] where
    ctc n = let nn = toName TypeConstructor n in Tycon nn (kindOf nn kt)
    ct (HsTyVar n) = let nn = toName TypeVal n in tyvar nn (kindOf nn kt)
    ct _ = error "Class.createClassAssocs: bad1."
    ctype HsTyAssoc = kindStar
    ctype _ = error "Class.createClassAssocs: bad2."
--    ctype t = Just $ runIdentity $ hsTypeToType kt t

createInstAssocs kt decls = [ (ctc n,map ct (czas ca),map ct as,ctype t) | HsTypeDecl { hsDeclName = n, hsDeclTArgs = (ca:as), hsDeclType = t } <- decls ] where
    ctc n = let nn = toName TypeConstructor n in Tycon nn (kindOf nn kt)
    ct (HsTyVar n) = let nn = toName TypeVal n in tyvar nn (kindOf nn kt)
    ct _ = error "Class.createInstAssocs: bad."
    czas ca = let (HsTyCon {},zas) = fromHsTypeApp ca in zas
    ctype HsTyAssoc = Nothing
    ctype t = Just $ runIdentity $ hsTypeToType kt t

fromHsTypeApp t = f t [] where
    f (HsTyApp a b) rs = f a (b:rs)
    f t rs = (t,rs)

instanceToTopDecls :: KindEnv -> ClassHierarchy -> HsDecl -> (([HsDecl],[Assump]))
instanceToTopDecls kt ch@(CH classHierarchy _) (HsInstDecl _ qualType methods)
    = unzip $ concatMap (methodToTopDecls kt [] crecord qualType) $ methodGroups where
    methodGroups = groupEquations (filter (not . isHsPragmaProps) methods)
    (_,(className,_)) = chToClassHead kt qualType
    crecord = case Map.lookup className classHierarchy  of
        Nothing -> error $ "instanceToTopDecls: could not find class " ++ show className ++ "in class hierarchy"
        Just crecord -> crecord
instanceToTopDecls kt ch@(CH classHierarchy _) (HsClassDecl _ chead methods)
   = unzip $ map (defaultMethodToTopDecls kt methodSigs chead) $ methodGroups where
   className = hsClassHead chead
   --HsQualType _ (HsTyApp (HsTyCon className) _) = qualType
   methodGroups = groupEquations (filter (\x -> isHsPatBind x || isHsFunBind x)  methods)
   methodSigs = case Map.lookup (toName ClassName className) classHierarchy  of
           Nothing -> error $ "defaultInstanceToTopDecls: could not find class " ++ show className ++ "in class hierarchy"
           Just sigs -> classAssumps sigs
instanceToTopDecls _ _ _ = mempty

instanceName n t = toName Val ("Instance@",'i':show n ++ "." ++ show t)
defaultInstanceName n = toName Val ("Instance@",'i':show n ++ ".default")
-- aliasDefaultInstanceName :: Name -> Class -> Name
-- aliasDefaultInstanceName n ca = toName Val ("Instance@",'i':show n ++ ".default."++show ca)

methodToTopDecls :: Monad m
    => KindEnv         -- ^ the kindenv
    -> [Pred]          -- ^ random extra predicates to add
    -> ClassRecord     -- ^ the class we are lifting methods from
    -> HsClassHead
    -> (Name, HsDecl)
    -> m (HsDecl,Assump)
methodToTopDecls kt preds crecord qt (methodName, methodDecls) = do
    let (cntxt,(className,[argType])) = chToClassHead kt qt
	newMethodName = instanceName methodName (getTypeHead argType)
    sigFromClass <- case [ s | (n, s) <- classAssumps crecord, n == methodName] of
	    [x] -> return x
	    _ -> fail $ "sigFromClass: " ++ (pprint className <+> pprint (classAssumps crecord))
					  ++ " " ++ show  methodName
    let instantiatedSig = newMethodSig' kt methodName (preds ++ cntxt) sigFromClass argType
	renamedMethodDecls = renameOneDecl newMethodName methodDecls
    return (renamedMethodDecls,(newMethodName, instantiatedSig))

defaultMethodToTopDecls :: KindEnv -> [Assump] -> HsClassHead -> (Name, HsDecl) -> (HsDecl,Assump)
defaultMethodToTopDecls kt methodSigs HsClassHead { .. } (methodName, methodDecls)
   = (renamedMethodDecls,(newMethodName,sigFromClass)) where
    newMethodName = defaultInstanceName methodName
    sigFromClass = case [ s | (n, s) <- methodSigs, n == methodName] of
        [x] -> x
        _ -> error $ "sigFromClass: " ++ show methodSigs ++ " " ++ show  methodName
     --  = newMethodSig cntxt newMethodName sigFromClass argType
    renamedMethodDecls = renameOneDecl newMethodName methodDecls

{-
aliasDefaultMethodToTopDecls :: KindEnv -> [Assump] -> Class -> (Name, HsDecl) -> (HsDecl,Assump)
aliasDefaultMethodToTopDecls kt methodSigs aliasName (methodName, methodDecls)
   = (renamedMethodDecls,(newMethodName,sigFromClass)) where
     newMethodName = aliasDefaultInstanceName methodName aliasName
     sigFromClass = case [ s | (n, s) <- methodSigs, n == methodName] of
         [x] -> x
         _ -> error $ "sigFromClass: " ++ show methodSigs ++ " " ++ show  methodName
      --  = newMethodSig cntxt newMethodName sigFromClass argType
     renamedMethodDecls = renameOneDecl newMethodName methodDecls
-}

renameOneDecl :: Name -> HsDecl -> HsDecl
renameOneDecl newName (HsFunBind matches)
   = HsFunBind  (map (renameOneMatch newName) matches)
-- all pattern bindings are simple by this stage
-- (ie no compound patterns)
renameOneDecl newName (HsPatBind sloc (HsPVar patName) rhs wheres)
   = HsPatBind sloc (HsPVar (nameName newName)) rhs wheres
renameOneDecl _ _ = error "Class.renameOneDecl"

renameOneMatch :: Name -> HsMatch -> HsMatch
renameOneMatch newName (HsMatch sloc oldName pats rhs wheres)
   = HsMatch sloc (nameName newName) pats rhs wheres

newMethodSig' :: KindEnv -> Name -> [Pred] -> Sigma -> Type -> Sigma
newMethodSig' kt methodName newCntxt qt' instanceType  = newQualType where
    TForAll _ ((IsIn _ classArg:restContext) :=> t) = qt'
    -- the assumption is that the context is non-empty and that
    -- the class and variable that we are interested in are at the
    -- front of the old context - the method of inserting instance types into
    -- the class hierarchy should ensure this
    --((className, classArg):restContxt) = cntxt
    foo = "_" ++ (show methodName ++ show (getTypeHead instanceType)) ++ "@@"
--    newQualType = everywhere (mkT at) $ tForAll (nub $ freeVars qt) qt

    newQualType = tForAll vs nqt where
        vs = nub $ freeVars nqt
        nqt = map (tickle f) (newCntxt ++ restContext) :=> f t
        f t | t == classArg = f instanceType
        f (TVar t) = TVar (at t)
        f (TForAll ta (ps :=> t)) = tickle f (TForAll (map at ta) (ps :=> t))
        f (TExists ta (ps :=> t)) = tickle f (TExists (map at ta) (ps :=> t))
        f t = tickle f t

    at (Tyvar n k) =  tyvar (updateName (++ foo) n) k
    updateName f n = toName nt (md,f nm) where
         (nt,(md::String,nm)) = fromName n
--    qt = (newCntxt ++ restContext) :=> t
    {-
    qt = (newCntxt ++ restContext) :=> (everywhere (mkT ct) t)
    ct n | n == classArg = instanceType
    ct n =  n
    -}

-- collect assumptions of all class methods

--classMethodAssumps :: ClassHierarchy -> [Assump]
--classMethodAssumps hierarchy = concatMap classAssumps $ classRecords hierarchy

--------------------------------------------------------------------------------

scatterAliasInstances :: ClassHierarchy -> ClassHierarchy
scatterAliasInstances = id
{-
scatterAliasInstances ch =
    let cas = [cr | cr@(ClassAliasRecord {}) <- classRecords ch]
    --ch `seq` liftIO $ putStrLn ("scatterAliasInstances: " ++ show cas)
        instances = concatMap scatterInstancesOf cas
        ret = foldr (modifyClassRecord $ \cr -> cr
                     { classInsts = [],
                       classMethodMap = Map.fromList [(meth, cls) | cls <- classClasses cr,
                                                                    (meth,_) <- classAssumps (findClassRecord ch cls)]
                     })
                    (ch `mappend` classHierarchyFromRecords instances)
                    (map className cas)
    -- liftIO $ mapM_ print (classRecords ret)
    in ret

scatterInstancesOf :: ClassRecord -> [ClassRecord]
scatterInstancesOf cr = map extract (classClasses cr)
    where
      extract c =
          (newClassRecord c) { classInsts =
                                   [Inst sl d ((cxt ++ [IsIn c2 xs | c2 <- classClasses cr, c2 /= c]) :=> IsIn c xs) []
                                        | Inst sl d (cxt :=> IsIn _ xs) [] <- classInsts cr] }

-}
--------------------------------------------------------------------------------

--failSl sl m = fail $ show sl ++ ": " ++ m

classHierarchyFromRecords rs =
    CH (Map.fromList [ (className x,x)| x <- rs ]) mempty

fromHsTyVar (HsTyVar v) = return v
fromHsTyVar (HsTyExpKind (Located _ t) _) = fromHsTyVar t
fromHsTyVar _ = fail "fromHsTyVar"

-- We give all instance declarations the benefit of the doubt here, assuming
-- they are correct. It is up to the typechecking pass to find any errors.
makeClassHierarchy :: MonadWarn m => ClassHierarchy -> KindEnv -> [HsDecl] -> m ClassHierarchy
makeClassHierarchy (CH ch _is) kt ds = mconcat `liftM` mapM f ds where
    f (HsClassDecl sl chead decls) = do
            let qualifiedMethodAssumps = concatMap (aHsTypeSigToAssumps kt . qualifyMethod newClassContext) (filter isHsTypeSig decls)
                newClassContext = [HsAsst className args]
                className = hsClassHead chead
                args = [ a | ~(Just a) <- map fromHsTyVar (hsClassHeadArgs chead) ]
            return $ classHierarchyFromRecords [ClassRecord {
                classArgs,
                classAssocs,
                classAlias = Nothing,
                className = toName ClassName className,
                classSrcLoc = sl,
                classSupers = [ toName ClassName x | ~(HsAsst x _) <- cntxt],
                classAssumps = qualifiedMethodAssumps }]
        where
        cntxt = hsClassHeadContext chead
        classAssocs = createClassAssocs kt decls
        (_,(_,classArgs')) = chToClassHead kt chead
        classArgs = [ v | ~(TVar v) <- classArgs' ]
--    f decl@(HsClassAliasDecl {}) = trace ("makeClassHierarchy: "++show decl) $ do
--        tell [ClassAliasRecord { className = toName ClassName (hsDeclName decl),
--                                 classArgs = [v | ~(TVar v) <- map (runIdentity . hsTypeToType kt) (hsDeclTypeArgs decl)],
--                                 classSrcLoc = hsDeclSrcLoc decl,
--                                 classSupers = [toName ClassName n | HsAsst n _ <- (hsDeclContext decl)],
--                                 classClasses = [toName ClassName n | HsAsst n _ <- (hsDeclClasses decl)],
--                                 classInsts = [],
--                                 classMethodMap = Map.empty
--                               }]

    f decl@(HsInstDecl {}) = hsInstDeclToInst kt decl >>= \insts -> do
        return $ foldl (flip addInstanceToHierarchy) mempty insts
    f decl@(HsDeclDeriving {}) = hsInstDeclToInst kt decl >>= \insts -> do
        return $ foldl (flip addInstanceToHierarchy) mempty insts
    f _ = return mempty

checkForDuplicateInstaces :: MonadWarn m
    => ClassHierarchy    -- ^ imported class hierarchy
    -> ClassHierarchy    -- ^ locally defined hierarchy
    -> m ClassHierarchy  -- ^ possibly simplified local hierarchy
checkForDuplicateInstaces iCh (CH ch is) = mapM_ f (Map.toList is) >> return (CH ch is) where
    f (className,is) = do
        let is' = findClassInsts iCh className ++ is
            sgu = sortGroupUnderFG fst snd [ ((cn,getTypeHead tt), i) |
                i@Inst { instSrcLoc = sl, instHead = _ :=> IsIn cn tt } <- is' ]
        mapM_ g sgu
    g (_,[_]) = return ()
    g (_,sls) | all instDerived sls = return ()
    g ((ch,th),sls) = warn (instSrcLoc $ head sls) DuplicateInstances $
        printf "instance (%s (%s ..)) defined multiple times: %s"
            (show ch) (show th) (show $ map instSrcLoc sls)

accLen :: Int -> [[a]] -> [(Int, [a])]
accLen width [] = []
accLen width (x:xs) = let newWidth = length x + width in (newWidth, x) : accLen newWidth xs

groupStringsToWidth :: Int -> [String] -> [String]
groupStringsToWidth width ss = groupStringsToWidth' width (accLen 0 ss) where
   groupStringsToWidth' :: Int -> [(Int,String)] -> [String]
   groupStringsToWidth' width [] = []
   groupStringsToWidth' width xs
      = headString : groupStringsToWidth' width (accLen 0 $ map snd rest)
      where
      (headSegments, rest)
         = case span ((<=width).fst) xs of
              ([], ss)     -> ([head ss], tail ss)
              anythingElse -> anythingElse
      headString = concatMap snd headSegments

showListAndSepInWidth :: (a -> String) -> Int -> String -> [a] -> String
showListAndSepInWidth _ _ _ [] = []
showListAndSepInWidth f width sep things = unlines $ groupStringsToWidth width newThings where
   newThings = (map ((\t -> t ++ sep).f) (init things)) ++ [f (last things)]

pretty  :: PPrint Doc a => a -> String
pretty   = render . pprint

{-
nameOfTyCon :: NameType -> HsType -> Name
nameOfTyCon t (HsTyCon n) = toName t n
nameOfTyCon t (HsTyTuple xs) = nameTuple t (length xs)
nameOfTyCon t (HsTyFun _ _) = tc_Arrow
nameOfTyCon _ t = error $ "nameOfTyCon: " ++ show t
-}

groupEquations :: [HsDecl] -> [(Name, HsDecl)]
groupEquations [] = []
groupEquations (HsTypeDecl {}:ds) = groupEquations ds
groupEquations (d:ds) = (getDeclName d, d) : groupEquations ds

derivableClasses ::  [Name]
derivableClasses = [
    class_Eq,
    class_Ord,
    class_Enum,
    class_Bounded,
    class_Show,
    class_Read,
    class_Ix
    ]

-- can be automatically derived when
-- the class is an enumeration
enumDerivableClasses ::  [Name]
enumDerivableClasses = [
    class_Eq,
    class_Ord,
    class_Enum,
    class_Ix
    ]

-- classes that cannot be derived by the generalized
-- newtype deriving mechanism.
noNewtypeDerivable :: [Name]
noNewtypeDerivable = [
    class_Show,
    class_Read
    ]

-- classes that behave identically to their component when they have a single
-- unary constructor but are not newtypes
{-
unaryPassDerivable :: [Name]
unaryPassDerivable = [
    class_Ix,
    class_Eq,
    class_Ord,
    class_Bounded
    ]
-}