------------------------------------------------------------------
-- Code generators -----------------------------------------------
------------------------------------------------------------------

gen_hs_source :: Info -> String
gen_hs_source (Info defaults entries) =
       "{-\n"
    ++ "This is a generated file (generated by genprimopcode).\n"
    ++ "It is not code to actually be used. Its only purpose is to be\n"
    ++ "consumed by haddock.\n"
    ++ "-}\n"
    ++ "\n"
        ++ (replicate 77 '-' ++ "\n") -- For 80-col cleanliness
        ++ "-- |\n"
        ++ "-- Module      :  GHC.Prim\n"
        ++ "-- \n"
        ++ "-- Maintainer  :  ghc-devs@haskell.org\n"
        ++ "-- Stability   :  internal\n"
        ++ "-- Portability :  non-portable (GHC extensions)\n"
        ++ "--\n"
        ++ "-- GHC\'s primitive types and operations.\n"
        ++ "-- Use GHC.Exts from the base package instead of importing this\n"
        ++ "-- module directly.\n"
        ++ "--\n"
        ++ (replicate 77 '-' ++ "\n") -- For 80-col cleanliness
        ++ "{-# LANGUAGE Unsafe #-}\n"
        ++ "{-# LANGUAGE MagicHash #-}\n"
        ++ "{-# LANGUAGE MultiParamTypeClasses #-}\n"
        ++ "{-# LANGUAGE NoImplicitPrelude #-}\n"
        ++ "{-# LANGUAGE UnboxedTuples #-}\n"

        ++ "{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}\n"
                -- We generate a binding for coerce, like
                --   coerce :: Coercible a b => a -> b
                --   coerce = let x = x in x
                -- and we don't want a complaint that the constraint is redundant
                -- Remember, this silly file is only for Haddock's consumption

        ++ "module GHC.Prim (\n"
        ++ unlines (map (("        " ++) . hdr) entries')
        ++ ") where\n"
    ++ "\n"
    ++ "{-\n"
        ++ unlines (map opt defaults)
    ++ "-}\n"
    ++ "import GHC.Types (Coercible)\n"

    ++ "default ()"  -- If we don't say this then the default type include Integer
                     -- so that runs off and loads modules that are not part of
                     -- pacakge ghc-prim at all.  And that in turn somehow ends up
                     -- with Declaration for $fEqMaybe:
                     --       attempting to use module ‘GHC.Classes’
                     --       (libraries/ghc-prim/./GHC/Classes.hs) which is not loaded
                     -- coming from LoadIface.homeModError
                     -- I'm not sure precisely why; but I *am* sure that we don't need
                     -- any type-class defaulting; and it's clearly wrong to need
                     -- the base package when haddocking ghc-prim

       -- Now the main payload
    ++ unlines (concatMap ent entries') ++ "\n\n\n"

     where entries' = concatMap desugarVectorSpec entries

           opt (OptionFalse n)    = n ++ " = False"
           opt (OptionTrue n)     = n ++ " = True"
           opt (OptionString n v) = n ++ " = { " ++ v ++ "}"
           opt (OptionInteger n v) = n ++ " = " ++ show v
           opt (OptionVector _)    = ""
           opt (OptionFixity mf) = "fixity" ++ " = " ++ show mf

           hdr s@(Section {})                                    = sec s
           hdr (PrimOpSpec { name = n })                         = wrapOp n ++ ","
           hdr (PrimVecOpSpec { name = n })                      = wrapOp n ++ ","
           hdr (PseudoOpSpec { name = n })                       = wrapOp n ++ ","
           hdr (PrimTypeSpec { ty = TyApp (TyCon n) _ })         = wrapTy n ++ ","
           hdr (PrimTypeSpec {})                                 = error $ "Illegal type spec"
           hdr (PrimVecTypeSpec { ty = TyApp (VecTyCon n _) _ }) = wrapTy n ++ ","
           hdr (PrimVecTypeSpec {})                              = error $ "Illegal type spec"

           ent   (Section {})         = []
           ent o@(PrimOpSpec {})      = spec o
           ent o@(PrimVecOpSpec {})   = spec o
           ent o@(PrimTypeSpec {})    = spec o
           ent o@(PrimVecTypeSpec {}) = spec o
           ent o@(PseudoOpSpec {})    = spec o

           sec s = "\n-- * " ++ escape (title s) ++ "\n"
                        ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s) ++ "\n"

           spec o = comm : decls
             where decls = case o of  -- See Note [Placeholder declarations]
                        PrimOpSpec { name = n, ty = t, opts = options } ->
                            prim_fixity n options ++ prim_decl n t
                        PrimVecOpSpec { name = n, ty = t, opts = options } ->
                            prim_fixity n options ++ prim_decl n t
                        PseudoOpSpec { name = n, ty = t } ->
                            prim_decl n t
                        PrimTypeSpec { ty = t }   ->
                            [ "data " ++ pprTy t ]
                        PrimVecTypeSpec { ty = t }   ->
                            [ "data " ++ pprTy t ]
                        Section { } -> []

                   comm = case (desc o) of
                        [] -> ""
                        d -> "\n" ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ d)

           prim_fixity n options = [ pprFixity fixity n | OptionFixity (Just fixity) <- options ]

           prim_decl n t = [ wrapOp n ++ " :: " ++ pprTy t,
                             wrapOp n ++ " = " ++ wrapOpRhs n ]

           wrapOp nm | isAlpha (head nm) = nm
                     | otherwise         = "(" ++ nm ++ ")"

           wrapTy nm | isAlpha (head nm) = nm
                     | otherwise         = "(" ++ nm ++ ")"

           wrapOpRhs "tagToEnum#" = "let x = x in x"
           wrapOpRhs nm           = wrapOp nm
              -- Special case for tagToEnum#: see Note [Placeholder declarations]

           unlatex s = case s of
                '\\':'t':'e':'x':'t':'t':'t':'{':cs -> markup "@" "@" cs
                '{':'\\':'t':'t':cs -> markup "@" "@" cs
                '{':'\\':'i':'t':cs -> markup "/" "/" cs
                c : cs -> c : unlatex cs
                [] -> []
           markup s t xs = s ++ mk (dropWhile isSpace xs)
                where mk ""        = t
                      mk ('\n':cs) = ' ' : mk cs
                      mk ('}':cs)  = t ++ unlatex cs
                      mk (c:cs)    = c : mk cs
           escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[])
                where special = "/'`\"@<"

           pprFixity (Fixity i d) n = pprFixityDir d ++ " " ++ show i ++ " " ++ n

{- Note [Placeholder declarations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We are generating fake declarations for things in GHC.Prim, just to
keep GHC's renamer and typechecker happy enough for what Haddock
needs.  Our main plan is to say
        foo :: <type>
        foo = foo
We have to silence GHC's complaints about unboxed-top-level declarations
with an ad-hoc fix in TcBinds: see Note [Compiling GHC.Prim] in TcBinds.

That works for all the primitive functions except tagToEnum#.
If we generate the binding
        tagToEnum# = tagToEnum#
GHC will complain about "tagToEnum# must appear applied to one argument".
We could hack GHC to silence this complaint when compiling GHC.Prim,
but it seems easier to generate
        tagToEnum# = let x = x in x
We don't do this for *all* bindings because for ones with an unboxed
RHS we would get other complaints (e.g.can't unify "*" with "#").
-}

pp
gen_hs_source :: Info -> String
gen_hs_source (Info defaults entries) =
       "{-\n"
    ++ "This is a generated file (generated by genprimopcode).\n"
    ++ "It is not code to actually be used. Its only purpose is to be\n"
    ++ "consumed by haddock.\n"
    ++ "-}\n"
    ++ "\n"
        ++ (replicate 77 '-' ++ "\n") -- For 80-col cleanliness
        ++ "-- |\n"
        ++ "-- Module      :  GHC.Prim\n"
        ++ "-- \n"
        ++ "-- Maintainer  :  ghc-devs@haskell.org\n"
        ++ "-- Stability   :  internal\n"
        ++ "-- Portability :  non-portable (GHC extensions)\n"
        ++ "--\n"
        ++ "-- GHC\'s primitive types and operations.\n"
        ++ "-- Use GHC.Exts from the base package instead of importing this\n"
        ++ "-- module directly.\n"
        ++ "--\n"
        ++ (replicate 77 '-' ++ "\n") -- For 80-col cleanliness
        ++ "{-# LANGUAGE Unsafe #-}\n"
        ++ "{-# LANGUAGE MagicHash #-}\n"
        ++ "{-# LANGUAGE MultiParamTypeClasses #-}\n"
        ++ "{-# LANGUAGE NoImplicitPrelude #-}\n"
        ++ "{-# LANGUAGE UnboxedTuples #-}\n"

        ++ "{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}\n"
                -- We generate a binding for coerce, like
                --   coerce :: Coercible a b => a -> b
                --   coerce = let x = x in x
                -- and we don't want a complaint that the constraint is redundant
                -- Remember, this silly file is only for Haddock's consumption

        ++ "module GHC.Prim (\n"
        ++ unlines (map (("        " ++) . hdr) entries')
        ++ ") where\n"
    ++ "\n"
    ++ "{-\n"
        ++ unlines (map opt defaults)
    ++ "-}\n"
    ++ "import GHC.Types (Coercible)\n"

    ++ "default ()"  -- If we don't say this then the default type include Integer
                     -- so that runs off and loads modules that are not part of
                     -- pacakge ghc-prim at all.  And that in turn somehow ends up
                     -- with Declaration for $fEqMaybe:
                     --       attempting to use module ‘GHC.Classes’
                     --       (libraries/ghc-prim/./GHC/Classes.hs) which is not loaded
                     -- coming from LoadIface.homeModError
                     -- I'm not sure precisely why; but I *am* sure that we don't need
                     -- any type-class defaulting; and it's clearly wrong to need
                     -- the base package when haddocking ghc-prim

       -- Now the main payload
    ++ unlines (concatMap ent entries') ++ "\n\n\n"

     where entries' = concatMap desugarVectorSpec entries

           opt (OptionFalse n)    = n ++ " = False"
           opt (OptionTrue n)     = n ++ " = True"
           opt (OptionString n v) = n ++ " = { " ++ v ++ "}"
           opt (OptionInteger n v) = n ++ " = " ++ show v
           opt (OptionVector _)    = ""
           opt (OptionFixity mf) = "fixity" ++ " = " ++ show mf

           hdr s@(Section {})                                    = sec s
           hdr (PrimOpSpec { name = n })                         = wrapOp n ++ ","
           hdr (PrimVecOpSpec { name = n })                      = wrapOp n ++ ","
           hdr (PseudoOpSpec { name = n })                       = wrapOp n ++ ","
           hdr (PrimTypeSpec { ty = TyApp (TyCon n) _ })         = wrapTy n ++ ","
           hdr (PrimTypeSpec {})                                 = error $ "Illegal type spec"
           hdr (PrimVecTypeSpec { ty = TyApp (VecTyCon n _) _ }) = wrapTy n ++ ","
           hdr (PrimVecTypeSpec {})                              = error $ "Illegal type spec"

           ent   (Section {})         = []
           ent o@(PrimOpSpec {})      = spec o
           ent o@(PrimVecOpSpec {})   = spec o
           ent o@(PrimTypeSpec {})    = spec o
           ent o@(PrimVecTypeSpec {}) = spec o
           ent o@(PseudoOpSpec {})    = spec o

           sec s = "\n-- * " ++ escape (title s) ++ "\n"
                        ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s) ++ "\n"

           spec o = comm : decls
             where decls = case o of  -- See Note [Placeholder declarations]
                        PrimOpSpec { name = n, ty = t, opts = options } ->
                            prim_fixity n options ++ prim_decl n t
                        PrimVecOpSpec { name = n, ty = t, opts = options } ->
                            prim_fixity n options ++ prim_decl n t
                        PseudoOpSpec { name = n, ty = t } ->
                            prim_decl n t
                        PrimTypeSpec { ty = t }   ->
                            [ "data " ++ pprTy t ]
                        PrimVecTypeSpec { ty = t }   ->
                            [ "data " ++ pprTy t ]
                        Section { } -> []

                   comm = case (desc o) of
                        [] -> ""
                        d -> "\n" ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ d)

           prim_fixity n options = [ pprFixity fixity n | OptionFixity (Just fixity) <- options ]

           prim_decl n t = [ wrapOp n ++ " :: " ++ pprTy t,
                             wrapOp n ++ " = " ++ wrapOpRhs n ]

           wrapOp nm | isAlpha (head nm) = nm
                     | otherwise         = "(" ++ nm ++ ")"

           wrapTy nm | isAlpha (head nm) = nm
                     | otherwise         = "(" ++ nm ++ ")"

           wrapOpRhs "tagToEnum#" = "let x = x in x"
           wrapOpRhs nm           = wrapOp nm
              -- Special case for tagToEnum#: see Note [Placeholder declarations]

           unlatex s = case s of
                '\\':'t':'e':'x':'t':'t':'t':'{':cs -> markup "@" "@" cs
                '{':'\\':'t':'t':cs -> markup "@" "@" cs
                '{':'\\':'i':'t':cs -> markup "/" "/" cs
                c : cs -> c : unlatex cs
                [] -> []
           markup s t xs = s ++ mk (dropWhile isSpace xs)
                where mk ""        = t
                      mk ('\n':cs) = ' ' : mk cs
                      mk ('}':cs)  = t ++ unlatex cs
                      mk (c:cs)    = c : mk cs
           escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[])
                where special = "/'`\"@<"

           pprFixity (Fixity i d) n = pprFixityDir d ++ " " ++ show i ++ " " ++ n

{- Note [Placeholder declarations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We are generating fake declarations for things in GHC.Prim, just to
keep GHC's renamer and typechecker happy enough for what Haddock
needs.  Our main plan is to say
        foo :: <type>
        foo = foo
We have to silence GHC's complaints about unboxed-top-level declarations
with an ad-hoc fix in TcBinds: see Note [Compiling GHC.Prim] in TcBinds.

That works for all the primitive functions except tagToEnum#.
If we generate the binding
        tagToEnum# = tagToEnum#
GHC will complain about "tagToEnum# must appear applied to one argument".
We could hack GHC to silence this complaint when compiling GHC.Prim,
but it seems easier to generate
        tagToEnum# = let x = x in x
We don't do this for *all* bindings because for ones with an unboxed
RHS we would get other complaints (e.g.can't unify "*" with "#").
-}
gen_hs_source (Info defaults entries) =
       "{-\n"
    ++ "This is a generated file (generated by genprimopcode).\n"
    ++ "It is not code to actually be used. Its only purpose is to be\n"
    ++ "consumed by haddock.\n"
    ++ "-}\n"
    ++ "\n"
        ++ (replicate 77 '-' ++ "\n") -- For 80-col cleanliness
        ++ "-- |\n"
        ++ "-- Module      :  GHC.Prim\n"
        ++ "-- \n"
        ++ "-- Maintainer  :  ghc-devs@haskell.org\n"
        ++ "-- Stability   :  internal\n"
        ++ "-- Portability :  non-portable (GHC extensions)\n"
        ++ "--\n"
        ++ "-- GHC\'s primitive types and operations.\n"
        ++ "-- Use GHC.Exts from the base package instead of importing this\n"
        ++ "-- module directly.\n"
        ++ "--\n"
        ++ (replicate 77 '-' ++ "\n") -- For 80-col cleanliness
        ++ "{-# LANGUAGE Unsafe #-}\n"
        ++ "{-# LANGUAGE MagicHash #-}\n"
        ++ "{-# LANGUAGE MultiParamTypeClasses #-}\n"
        ++ "{-# LANGUAGE NoImplicitPrelude #-}\n"
        ++ "{-# LANGUAGE UnboxedTuples #-}\n"

        ++ "{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}\n"
                -- We generate a binding for coerce, like
                --   coerce :: Coercible a b => a -> b
                --   coerce = let x = x in x
                -- and we don't want a complaint that the constraint is redundant
                -- Remember, this silly file is only for Haddock's consumption

        ++ "module GHC.Prim (\n"
        ++ unlines (map (("        " ++) . hdr) entries')
        ++ ") where\n"
    ++ "\n"
    ++ "{-\n"
        ++ unlines (map opt defaults)
    ++ "-}\n"
    ++ "import GHC.Types (Coercible)\n"

    ++ "default ()"  -- If we don't say this then the default type include Integer
                     -- so that runs off and loads modules that are not part of
                     -- pacakge ghc-prim at all.  And that in turn somehow ends up
                     -- with Declaration for $fEqMaybe:
                     --       attempting to use module ‘GHC.Classes’
                     --       (libraries/ghc-prim/./GHC/Classes.hs) which is not loaded
                     -- coming from LoadIface.homeModError
                     -- I'm not sure precisely why; but I *am* sure that we don't need
                     -- any type-class defaulting; and it's clearly wrong to need
                     -- the base package when haddocking ghc-prim

       -- Now the main payload
    ++ unlines (concatMap ent entries') ++ "\n\n\n"

     where entries' = concatMap desugarVectorSpec entries

           opt (OptionFalse n)    = n ++ " = False"
           opt (OptionTrue n)     = n ++ " = True"
           opt (OptionString n v) = n ++ " = { " ++ v ++ "}"
           opt (OptionInteger n v) = n ++ " = " ++ show v
           opt (OptionVector _)    = ""
           opt (OptionFixity mf) = "fixity" ++ " = " ++ show mf

           hdr s@(Section {})                                    = sec s
           hdr (PrimOpSpec { name = n })                         = wrapOp n ++ ","
           hdr (PrimVecOpSpec { name = n })                      = wrapOp n ++ ","
           hdr (PseudoOpSpec { name = n })                       = wrapOp n ++ ","
           hdr (PrimTypeSpec { ty = TyApp (TyCon n) _ })         = wrapTy n ++ ","
           hdr (PrimTypeSpec {})                                 = error $ "Illegal type spec"
           hdr (PrimVecTypeSpec { ty = TyApp (VecTyCon n _) _ }) = wrapTy n ++ ","
           hdr (PrimVecTypeSpec {})                              = error $ "Illegal type spec"

           ent   (Section {})         = []
           ent o@(PrimOpSpec {})      = spec o
           ent o@(PrimVecOpSpec {})   = spec o
           ent o@(PrimTypeSpec {})    = spec o
           ent o@(PrimVecTypeSpec {}) = spec o
           ent o@(PseudoOpSpec {})    = spec o

           sec s = "\n-- * " ++ escape (title s) ++ "\n"
                        ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s) ++ "\n"

           spec o = comm : decls
             where decls = case o of  -- See Note [Placeholder declarations]
                        PrimOpSpec { name = n, ty = t, opts = options } ->
                            prim_fixity n options ++ prim_decl n t
                        PrimVecOpSpec { name = n, ty = t, opts = options } ->
                            prim_fixity n options ++ prim_decl n t
                        PseudoOpSpec { name = n, ty = t } ->
                            prim_decl n t
                        PrimTypeSpec { ty = t }   ->
                            [ "data " ++ pprTy t ]
                        PrimVecTypeSpec { ty = t }   ->
                            [ "data " ++ pprTy t ]
                        Section { } -> []

                   comm = case (desc o) of
                        [] -> ""
                        d -> "\n" ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ d)

           prim_fixity n options = [ pprFixity fixity n | OptionFixity (Just fixity) <- options ]

           prim_decl n t = [ wrapOp n ++ " :: " ++ pprTy t,
                             wrapOp n ++ " = " ++ wrapOpRhs n ]

           wrapOp nm | isAlpha (head nm) = nm
                     | otherwise         = "(" ++ nm ++ ")"

           wrapTy nm | isAlpha (head nm) = nm
                     | otherwise         = "(" ++ nm ++ ")"

           wrapOpRhs "tagToEnum#" = "let x = x in x"
           wrapOpRhs nm           = wrapOp nm
              -- Special case for tagToEnum#: see Note [Placeholder declarations]

           unlatex s = case s of
                '\\':'t':'e':'x':'t':'t':'t':'{':cs -> markup "@" "@" cs
                '{':'\\':'t':'t':cs -> markup "@" "@" cs
                '{':'\\':'i':'t':cs -> markup "/" "/" cs
                c : cs -> c : unlatex cs
                [] -> []
           markup s t xs = s ++ mk (dropWhile isSpace xs)
                where mk ""        = t
                      mk ('\n':cs) = ' ' : mk cs
                      mk ('}':cs)  = t ++ unlatex cs
                      mk (c:cs)    = c : mk cs
           escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[])
                where special = "/'`\"@<"

           pprFixity (Fixity i d) n = pprFixityDir d ++ " " ++ show i ++ " " ++ n

{- Note [Placeholder declarations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We are generating fake declarations for things in GHC.Prim, just to
keep GHC's renamer and typechecker happy enough for what Haddock
needs.  Our main plan is to say
        foo :: <type>
        foo = foo
We have to silence GHC's complaints about unboxed-top-level declarations
with an ad-hoc fix in TcBinds: see Note [Compiling GHC.Prim] in TcBinds.

That works for all the primitive functions except tagToEnum#.
If we generate the binding
        tagToEnum# = tagToEnum#
GHC will complain about "tagToEnum# must appear applied to one argument".
We could hack GHC to silence this complaint when compiling GHC.Prim,
but it seems easier to generate
        tagToEnum# = let x = x in x
We don't do this for *all* bindings because for ones with an unboxed
RHS we would get other complaints (e.g.can't unify "*" with "#").
-}