uhc-light-1.1.9.3: src/UHC/Light/Compiler/Base/CfgPP.hs

{-# LANGUAGE ExistentialQuantification #-}

module UHC.Light.Compiler.Base.CfgPP
( ppScanoptsNm
, CfgPP' (..), CfgPP (..)
, CfgPP_Plain (..), CfgPP_Core (..), CfgPP_Grin (..)
, ppCoreNm
, 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
import UHC.Util.ScanUtils

{-# LINE 43 "src/ehc/Base/CfgPP.chs" #-}
-- | Prettyprint 'HsName' with scanopts, taking care of properly escaping based on scan info (used when parsing)
ppScanoptsNm :: ScanOpts -> HsName -> PP_Doc
ppScanoptsNm copts n = fst $ ppHsnEscapeWith '$' (hsnOkChars '$' $ copts) (hsnNotOkStrs copts) (`Set.member` leaveAsIs) n
    where leaveAsIs = Set.fromList [hsnRowEmpty]

{-# LINE 54 "src/ehc/Base/CfgPP.chs" #-}
-- | API for PP config
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

data CfgPP = forall x . CfgPP' x => CfgPP x

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

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

{-# LINE 90 "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]
  -}
  cfgppHsName    _ n 				= ppScanoptsNm (coreScanOpts emptyEHCOpts) n
  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 105 "src/ehc/Base/CfgPP.chs" #-}
instance CfgPP' CfgPP_Grin where
  cfgppHsName    _ = ppHsnNonAlpha grinScanOpts

{-# LINE 114 "src/ehc/Base/CfgPP.chs" #-}
ppCoreNm :: HsName -> PP_Doc
ppCoreNm = cfgppHsName CfgPP_Core

{-# LINE 123 "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 138 "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 156 "src/ehc/Base/CfgPP.chs" #-}
ppCTagsMp :: CfgPP' x => x -> CTagsMp -> PP_Doc
ppCTagsMp x
  = mkl (mkl (ppCTag' x))
  where mkl :: (x -> PP_Doc) -> AssocL HsName x -> PP_Doc
        mkl pe = ppCurlysSemisBlock . map (\(n,e) -> cfgppHsName x n >-< indent 1 ("=" >#< pe e))