Move sources under haddock-api/src

1 files changed, 403 insertions, 0 deletions

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
new file mode 100644
index 00000000..73ff3f1a
--- /dev/null
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -0,0 +1,403 @@
+{-# 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