Move sources under haddock-api/src

1 files changed, 0 insertions, 403 deletions

diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
deleted file mode 100644
index 73ff3f1a..00000000
--- a/src/Haddock/Convert.hs
+++ /dev/null
@@ -1,403 +0,0 @@
-{-# LANGUAGE CPP, PatternGuards #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Haddock.Convert
--- Copyright   :  (c) Isaac Dupree 2009,
--- License     :  BSD-like
---
--- Maintainer  :  haddock@projects.haskell.org
--- Stability   :  experimental
--- Portability :  portable
---
--- Conversion between TyThing and HsDecl. This functionality may be moved into
--- GHC at some point.
------------------------------------------------------------------------------
-module Haddock.Convert where
--- Some other functions turned out to be useful for converting
--- instance heads, which aren't TyThings, so just export everything.
-
-
-import HsSyn
-import TcType ( tcSplitSigmaTy )
-import TypeRep
-import Type(isStrLitTy)
-import Kind ( splitKindFunTys, synTyConResKind, isKind )
-import Name
-import Var
-import Class
-import TyCon
-import CoAxiom
-import ConLike
-import DataCon
-import PatSyn
-import FamInstEnv
-import BasicTypes ( TupleSort(..) )
-import TysPrim ( alphaTyVars )
-import TysWiredIn ( listTyConName, eqTyCon )
-import PrelNames (ipClassName)
-import Bag ( emptyBag )
-import Unique ( getUnique )
-import SrcLoc ( Located, noLoc, unLoc )
-import Data.List( partition )
-import Haddock.Types
-
-
--- the main function here! yay!
-tyThingToLHsDecl :: TyThing -> LHsDecl Name
-tyThingToLHsDecl t = noLoc $ case t of
-  -- ids (functions and zero-argument a.k.a. CAFs) get a type signature.
-  -- Including built-in functions like seq.
-  -- foreign-imported functions could be represented with ForD
-  -- instead of SigD if we wanted...
-  --
-  -- in a future code version we could turn idVarDetails = foreign-call
-  -- into a ForD instead of a SigD if we wanted.  Haddock doesn't
-  -- need to care.
-  AnId i -> SigD (synifyIdSig ImplicitizeForAll i)
-
-  -- type-constructors (e.g. Maybe) are complicated, put the definition
-  -- later in the file (also it's used for class associated-types too.)
-  ATyCon tc
-    | Just cl <- tyConClass_maybe tc -- classes are just a little tedious
-    -> let extractFamilyDecl :: TyClDecl a -> LFamilyDecl a
-           extractFamilyDecl (FamDecl d) = noLoc d
-           extractFamilyDecl _           =
-             error "tyThingToLHsDecl: impossible associated tycon"
-
-           atTyClDecls = [synifyTyCon Nothing at_tc | (at_tc, _) <- classATItems cl]
-           atFamDecls  = map extractFamilyDecl atTyClDecls in
-       TyClD $ ClassDecl
-         { tcdCtxt = synifyCtx (classSCTheta cl)
-         , tcdLName = synifyName cl
-         , tcdTyVars = synifyTyVars (classTyVars cl)
-         , tcdFDs = map (\ (l,r) -> noLoc
-                        (map getName l, map getName r) ) $
-                         snd $ classTvsFds cl
-         , tcdSigs = noLoc (MinimalSig . fmap noLoc $ classMinimalDef cl) :
-                      map (noLoc . synifyIdSig DeleteTopLevelQuantification)
-                        (classMethods cl)
-         , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature
-         -- class associated-types are a subset of TyCon:
-         , tcdATs = atFamDecls
-         , tcdATDefs = [] --ignore associated type defaults
-         , tcdDocs = [] --we don't have any docs at this point
-         , tcdFVs = placeHolderNames }
-    | otherwise
-    -> TyClD (synifyTyCon Nothing tc)
-
-  -- type-constructors (e.g. Maybe) are complicated, put the definition
-  -- later in the file (also it's used for class associated-types too.)
-  ACoAxiom ax -> synifyAxiom ax
-
-  -- a data-constructor alone just gets rendered as a function:
-  AConLike (RealDataCon dc) -> SigD (TypeSig [synifyName dc]
-    (synifyType ImplicitizeForAll (dataConUserType dc)))
-
-  AConLike (PatSynCon ps) ->
-#if MIN_VERSION_ghc(7,8,3)
-      let (_, _, req_theta, prov_theta, _, res_ty) = patSynSig ps
-#else
-      let (_, _, (req_theta, prov_theta)) = patSynSig ps
-#endif
-      in SigD $ PatSynSig (synifyName ps)
-#if MIN_VERSION_ghc(7,8,3)
-                          (fmap (synifyType WithinType) (patSynTyDetails ps))
-                          (synifyType WithinType res_ty)
-#else
-                          (fmap (synifyType WithinType) (patSynTyDetails ps))
-                          (synifyType WithinType (patSynType ps))
-#endif
-                          (synifyCtx req_theta)
-                          (synifyCtx prov_theta)
-
-synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name
-synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
-  = let name       = synifyName tc
-        typats     = map (synifyType WithinType) args
-        hs_rhs     = synifyType WithinType rhs
-        (kvs, tvs) = partition isKindVar tkvs
-    in TyFamInstEqn { tfie_tycon = name
-                    , tfie_pats  = HsWB { hswb_cts = typats
-                                        , hswb_kvs = map tyVarName kvs
-                                        , hswb_tvs = map tyVarName tvs }
-                    , tfie_rhs   = hs_rhs }
-
-synifyAxiom :: CoAxiom br -> HsDecl Name
-synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
-  | isOpenSynFamilyTyCon tc
-  , Just branch <- coAxiomSingleBranch_maybe ax
-  = InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch
-                                     , tfid_fvs = placeHolderNames }))
-
-  | Just ax' <- isClosedSynFamilyTyCon_maybe tc
-  , getUnique ax' == getUnique ax   -- without the getUniques, type error
-  = TyClD (synifyTyCon (Just ax) tc)
-
-  | otherwise
-  = error "synifyAxiom: closed/open family confusion"
-
-synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> TyClDecl Name
-synifyTyCon coax tc
-  | isFunTyCon tc || isPrimTyCon tc 
-  = DataDecl { tcdLName = synifyName tc
-             , tcdTyVars =       -- tyConTyVars doesn't work on fun/prim, but we can make them up:
-                         let mk_hs_tv realKind fakeTyVar 
-                                = noLoc $ KindedTyVar (getName fakeTyVar) 
-                                                      (synifyKindSig realKind)
-                         in HsQTvs { hsq_kvs = []   -- No kind polymorphism
-                                   , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc)))
-                                                                alphaTyVars --a, b, c... which are unfortunately all kind *
-                                   }
-                            
-           , tcdDataDefn = HsDataDefn { dd_ND = DataType  -- arbitrary lie, they are neither 
-                                                    -- algebraic data nor newtype:
-                                      , dd_ctxt = noLoc []
-                                      , dd_cType = Nothing
-                                      , dd_kindSig = Just (synifyKindSig (tyConKind tc))
-                                               -- we have their kind accurately:
-                                      , dd_cons = []  -- No constructors
-                                      , dd_derivs = Nothing }
-           , tcdFVs = placeHolderNames }
-
-  | isSynFamilyTyCon tc 
-  = case synTyConRhs_maybe tc of
-      Just rhs ->
-        let info = case rhs of
-                     OpenSynFamilyTyCon -> OpenTypeFamily
-                     ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) ->
-                       ClosedTypeFamily (brListMap (noLoc . synifyAxBranch tc) branches)
-                     _ -> error "synifyTyCon: type/data family confusion"
-        in FamDecl (FamilyDecl { fdInfo = info
-                               , fdLName = synifyName tc
-                               , fdTyVars = synifyTyVars (tyConTyVars tc)
-                               , fdKindSig = Just (synifyKindSig (synTyConResKind tc)) })
-      Nothing -> error "synifyTyCon: impossible open type synonym?"
-
-  | isDataFamilyTyCon tc 
-  = --(why no "isOpenAlgTyCon"?)
-    case algTyConRhs tc of
-        DataFamilyTyCon ->
-          FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
-                              Nothing) --always kind '*'
-        _ -> error "synifyTyCon: impossible open data type?"
-  | isSynTyCon tc
-  = case synTyConRhs_maybe tc of
-        Just (SynonymTyCon ty) ->
-          SynDecl { tcdLName = synifyName tc
-                  , tcdTyVars = synifyTyVars (tyConTyVars tc)
-                  , tcdRhs = synifyType WithinType ty
-                  , tcdFVs = placeHolderNames }
-        _ -> error "synifyTyCon: impossible synTyCon"
-  | otherwise =
-  -- (closed) newtype and data
-  let
-  alg_nd = if isNewTyCon tc then NewType else DataType
-  alg_ctx = synifyCtx (tyConStupidTheta tc)
-  name = case coax of
-    Just a -> synifyName a -- Data families are named according to their
-                           -- CoAxioms, not their TyCons
-    _ -> synifyName tc
-  tyvars = synifyTyVars (tyConTyVars tc)
-  kindSig = Just (tyConKind tc)
-  -- The data constructors.
-  --
-  -- Any data-constructors not exported from the module that *defines* the
-  -- type will not (cannot) be included.
-  --
-  -- Very simple constructors, Haskell98 with no existentials or anything,
-  -- probably look nicer in non-GADT syntax.  In source code, all constructors
-  -- must be declared with the same (GADT vs. not) syntax, and it probably
-  -- is less confusing to follow that principle for the documentation as well.
-  --
-  -- There is no sensible infix-representation for GADT-syntax constructor
-  -- declarations.  They cannot be made in source code, but we could end up
-  -- with some here in the case where some constructors use existentials.
-  -- That seems like an acceptable compromise (they'll just be documented
-  -- in prefix position), since, otherwise, the logic (at best) gets much more
-  -- complicated. (would use dataConIsInfix.)
-  use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc)
-  cons = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc)
-  -- "deriving" doesn't affect the signature, no need to specify any.
-  alg_deriv = Nothing
-  defn = HsDataDefn { dd_ND      = alg_nd
-                    , dd_ctxt    = alg_ctx
-                    , dd_cType   = Nothing
-                    , dd_kindSig = fmap synifyKindSig kindSig
-                    , dd_cons    = cons 
-                    , dd_derivs  = alg_deriv }
- in DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn
-             , tcdFVs = placeHolderNames }
-
--- User beware: it is your responsibility to pass True (use_gadt_syntax)
--- for any constructor that would be misrepresented by omitting its
--- result-type.
--- But you might want pass False in simple enough cases,
--- if you think it looks better.
-synifyDataCon :: Bool -> DataCon -> LConDecl Name
-synifyDataCon use_gadt_syntax dc = noLoc $
- let
-  -- dataConIsInfix allegedly tells us whether it was declared with
-  -- infix *syntax*.
-  use_infix_syntax = dataConIsInfix dc
-  use_named_field_syntax = not (null field_tys)
-  name = synifyName dc
-  -- con_qvars means a different thing depending on gadt-syntax
-  (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc
-
-  qvars = if use_gadt_syntax
-          then synifyTyVars (univ_tvs ++ ex_tvs)
-          else synifyTyVars ex_tvs
-
-  -- skip any EqTheta, use 'orig'inal syntax
-  ctx = synifyCtx theta
-
-  linear_tys = zipWith (\ty bang ->
-            let tySyn = synifyType WithinType ty
-                src_bang = case bang of
-                             HsUnpack {} -> HsUserBang (Just True) True
-                             HsStrict    -> HsUserBang (Just False) True
-                             _           -> bang
-            in case src_bang of
-                 HsNoBang -> tySyn
-                 _        -> noLoc $ HsBangTy bang tySyn
-            -- HsNoBang never appears, it's implied instead.
-          )
-          arg_tys (dataConStrictMarks dc)
-  field_tys = zipWith (\field synTy -> ConDeclField
-                                           (synifyName field) synTy Nothing)
-                (dataConFieldLabels dc) linear_tys
-  hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
-          (True,True) -> error "synifyDataCon: contradiction!"
-          (True,False) -> RecCon field_tys
-          (False,False) -> PrefixCon linear_tys
-          (False,True) -> case linear_tys of
-                           [a,b] -> InfixCon a b
-                           _ -> error "synifyDataCon: infix with non-2 args?"
-  hs_res_ty = if use_gadt_syntax
-              then ResTyGADT (synifyType WithinType res_ty)
-              else ResTyH98
- -- finally we get synifyDataCon's result!
- in ConDecl name Implicit{-we don't know nor care-}
-      qvars ctx hs_arg_tys hs_res_ty Nothing
-      False --we don't want any "deprecated GADT syntax" warnings!
-
-
-synifyName :: NamedThing n => n -> Located Name
-synifyName = noLoc . getName
-
-
-synifyIdSig :: SynifyTypeState -> Id -> Sig Name
-synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i))
-
-
-synifyCtx :: [PredType] -> LHsContext Name
-synifyCtx = noLoc . map (synifyType WithinType)
-
-
-synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name
-synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs
-                           , hsq_tvs = map synifyTyVar tvs }
-  where
-    (kvs, tvs) = partition isKindVar ktvs
-    synifyTyVar tv 
-      | isLiftedTypeKind kind = noLoc (UserTyVar name)
-      | otherwise             = noLoc (KindedTyVar name (synifyKindSig kind))
-      where
-        kind = tyVarKind tv
-        name = getName tv
-
---states of what to do with foralls:
-data SynifyTypeState
-  = WithinType
-  -- ^ normal situation.  This is the safe one to use if you don't
-  -- quite understand what's going on.
-  | ImplicitizeForAll
-  -- ^ beginning of a function definition, in which, to make it look
-  --   less ugly, those rank-1 foralls are made implicit.
-  | DeleteTopLevelQuantification
-  -- ^ because in class methods the context is added to the type
-  --   (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@)
-  --   which is rather sensible,
-  --   but we want to restore things to the source-syntax situation where
-  --   the defining class gets to quantify all its functions for free!
-
-
-synifyType :: SynifyTypeState -> Type -> LHsType Name
-synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv)
-synifyType _ (TyConApp tc tys)
-  -- Use non-prefix tuple syntax where possible, because it looks nicer.
-  | isTupleTyCon tc, tyConArity tc == length tys =
-     noLoc $ HsTupleTy (case tupleTyConSort tc of
-                          BoxedTuple      -> HsBoxedTuple
-                          ConstraintTuple -> HsConstraintTuple
-                          UnboxedTuple    -> HsUnboxedTuple)
-                       (map (synifyType WithinType) tys)
-  -- ditto for lists
-  | getName tc == listTyConName, [ty] <- tys =
-     noLoc $ HsListTy (synifyType WithinType ty)
-  -- ditto for implicit parameter tycons
-  | tyConName tc == ipClassName
-  , [name, ty] <- tys
-  , Just x <- isStrLitTy name
-  = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty)
-  -- and equalities
-  | tc == eqTyCon
-  , [ty1, ty2] <- tys
-  = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2)
-  -- Most TyCons:
-  | otherwise =
-    foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))
-      (noLoc $ HsTyVar (getName tc))
-      (map (synifyType WithinType) tys)
-synifyType _ (AppTy t1 t2) = let
-  s1 = synifyType WithinType t1
-  s2 = synifyType WithinType t2
-  in noLoc $ HsAppTy s1 s2
-synifyType _ (FunTy t1 t2) = let
-  s1 = synifyType WithinType t1
-  s2 = synifyType WithinType t2
-  in noLoc $ HsFunTy s1 s2
-synifyType s forallty@(ForAllTy _tv _ty) =
-  let (tvs, ctx, tau) = tcSplitSigmaTy forallty
-  in case s of
-    DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau
-    _ -> let
-      forallPlicitness = case s of
-              WithinType -> Explicit
-              ImplicitizeForAll -> Implicit
-              _ -> error "synifyType: impossible case!!!"
-      sTvs = synifyTyVars tvs
-      sCtx = synifyCtx ctx
-      sTau = synifyType WithinType tau
-     in noLoc $
-           HsForAllTy forallPlicitness sTvs sCtx sTau
-synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
-
-synifyTyLit :: TyLit -> HsTyLit
-synifyTyLit (NumTyLit n) = HsNumTy n
-synifyTyLit (StrTyLit s) = HsStrTy s
-
-synifyKindSig :: Kind -> LHsKind Name
-synifyKindSig k = synifyType WithinType k
-
-synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
-synifyInstHead (_, preds, cls, types) =
-  ( getName cls
-  , map (unLoc . synifyType WithinType) ks
-  , map (unLoc . synifyType WithinType) ts
-  , ClassInst $ map (unLoc . synifyType WithinType) preds
-  )
-  where (ks,ts) = break (not . isKind) types
-
--- Convert a family instance, this could be a type family or data family
-synifyFamInst :: FamInst -> Bool -> InstHead Name
-synifyFamInst fi opaque =
-  ( fi_fam fi
-  , map (unLoc . synifyType WithinType) ks
-  , map (unLoc . synifyType WithinType) ts
-  , case fi_flavor fi of
-      SynFamilyInst | opaque -> TypeInst Nothing
-      SynFamilyInst -> TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi
-      DataFamilyInst c -> DataInst $ synifyTyCon (Just $ famInstAxiom fi) c
-  )
-  where (ks,ts) = break (not . isKind) $ fi_tys fi