CfgPP.hs

module UHC.Light.Compiler.Base.CfgPP
( CfgPP (..)
, CfgPP_Plain (..), CfgPP_Core (..), CfgPP_Grin (..), CfgPP_TyCore (..)
, ppCTag', ppCTagExtensive'
, ppCTagsMp )
where
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Base.HsName
import UHC.Light.Compiler.Opts.Base
import UHC.Light.Compiler.Base.HsName.Builtin
import UHC.Light.Compiler.Scanner.Common
import Data.Char
import qualified Data.Set as Set
import UHC.Util.Pretty

{-# LINE 37 "src/ehc/Base/CfgPP.chs" #-}
class CfgPP x where
  cfgppHsName 		:: x -> HsName -> PP_Doc
  cfgppConHsName 	:: x -> HsName -> PP_Doc
  cfgppUID    		:: x -> UID    -> PP_Doc
  cfgppVarHsName 	:: x -> Maybe HsName -> Maybe UID -> Maybe Int -> Maybe PP_Doc -> PP_Doc
  cfgppVarHsNameFallback
  					:: x -> Maybe HsName -> Maybe UID -> Maybe Int -> Maybe PP_Doc -> PP_Doc
  cfgppFollowAST    :: x -> Bool
  cfgppTyPPVarDflt 	:: x -> String -> UID -> Maybe PP_Doc -> PP_Doc

  cfgppHsName    _              			= pp
  cfgppConHsName _              			= ppCon
  cfgppUID       _              			= pp
  cfgppVarHsName x mn mu mi mp				= cfgppVarHsNameFallback x mn mu mi mp
  cfgppVarHsNameFallback x _ _ _ (Just p)  	= p
  cfgppVarHsNameFallback x _ _ (Just i) _ 	= cfgppHsName x $ mkHNm $ tnUniqRepr i
  cfgppVarHsNameFallback x (Just n) _ _ _ 	= cfgppHsName x n
  cfgppVarHsNameFallback x _ (Just u) _ _ 	= cfgppUID x u
  cfgppFollowAST _              			= False
  cfgppTyPPVarDflt							= \x pre tv mbpp -> cfgppVarHsName x (Just $ mkHNm $ pre ++ "_" ++ show tv) (Just tv) Nothing mbpp

{-# LINE 60 "src/ehc/Base/CfgPP.chs" #-}
data CfgPP_Plain   = CfgPP_Plain
data CfgPP_Core    = CfgPP_Core
data CfgPP_TyCore  = CfgPP_TyCore
data CfgPP_Grin    = CfgPP_Grin

{-# LINE 67 "src/ehc/Base/CfgPP.chs" #-}
instance CfgPP CfgPP_Plain

{-# LINE 71 "src/ehc/Base/CfgPP.chs" #-}
instance CfgPP CfgPP_Core where
  cfgppHsName    _ n 				= fst $ ppHsnEscapeWith '$' (hsnOkChars '$' $ copts) (hsnNotOkStrs copts) (`Set.member` leaveAsIs) n
    where copts = coreScanOpts emptyEHCOpts
          leaveAsIs = Set.fromList [hsnRowEmpty]
  cfgppConHsName     				= cfgppHsName
  cfgppFollowAST     				= const True
  cfgppUID _       u 				= ppUIDParseable u
  cfgppVarHsName x _ (Just u) _ _ 	= cfgppUID x u
  cfgppVarHsName x mn mu mi mp      = cfgppVarHsNameFallback x mn mu mi mp

{-# LINE 83 "src/ehc/Base/CfgPP.chs" #-}
ppNmTyCore = ppHsnEscaped (Right $ Set.fromList ['0'..'9']) '$' (hsnEscapeeChars '$' tycoreScanOpts)

instance CfgPP CfgPP_TyCore where
  cfgppHsName    _ = ppNmTyCore

{-# LINE 90 "src/ehc/Base/CfgPP.chs" #-}
instance CfgPP CfgPP_Grin where
  cfgppHsName    _ = ppHsnNonAlpha grinScanOpts

{-# LINE 99 "src/ehc/Base/CfgPP.chs" #-}
tnUniqRepr :: Int -> String
tnUniqRepr
  = lrepr
  where lrepr i = if i <= 26
                  then  [repr i]
                  else  let  (d,r) = i `divMod` 26
                        in   (repr d : lrepr r)
        repr    = (chr . (97+))

{-# LINE 114 "src/ehc/Base/CfgPP.chs" #-}
-- intended for parsing
ppCTag' :: CfgPP x => x -> CTag -> PP_Doc
ppCTag' x t
  = case t of
      CTagRec                      -> ppCurly "Rec"
      CTag ty nm tag arity mxarity -> ppCurlysCommas' [ppNm ty, ppNm nm, pp tag {- , pp arity, pp mxarity -}]
  where ppNm n = cfgppHsName x n

-- intended for parsing
ppCTagExtensive' :: CfgPP x => x -> CTag -> PP_Doc
ppCTagExtensive' x t
  = case t of
      CTagRec                      -> ppCurly "Rec"
      CTag ty nm tag arity mxarity -> ppCurlysCommas' [ppNm ty, ppNm nm, pp tag, pp arity, pp mxarity]
  where ppNm n = cfgppHsName x n

{-# LINE 132 "src/ehc/Base/CfgPP.chs" #-}
ppCTagsMp :: CfgPP x => x -> CTagsMp -> PP_Doc
ppCTagsMp x
  = mkl (mkl (ppCTag' x))
  where mkl pe = ppCurlysSemisBlock . map (\(n,e) -> cfgppHsName x n >-< indent 1 ("=" >#< pe e))