{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.Brittany.Internal.Utils where import qualified Data.ByteString as B import qualified Data.Coerce import Data.Data import Data.Generics.Aliases import qualified Data.Generics.Uniplate.Direct as Uniplate import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import DataTreePrint import qualified GHC.Data.FastString as GHC import qualified GHC.Driver.Session as GHC import qualified GHC.Hs.Extension as HsExtension import qualified GHC.OldList as List import GHC.Types.Name.Occurrence as OccName (occNameString) import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Utils.Outputable as GHC import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils import qualified Text.PrettyPrint as PP parDoc :: String -> PP.Doc parDoc = PP.fsep . fmap PP.text . List.words parDocW :: [String] -> PP.Doc parDocW = PP.fsep . fmap PP.text . List.words . List.unwords showSDoc_ :: GHC.SDoc -> String showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags showOutputable :: (GHC.Outputable a) => a -> String showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags fromMaybeIdentity :: Identity a -> Maybe a -> Identity a fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y fromOptionIdentity :: Identity a -> Maybe a -> Identity a fromOptionIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y -- maximum monoid over N+0 -- or more than N, because Num is allowed. newtype Max a = Max { getMax :: a } deriving (Eq, Ord, Show, Bounded, Num) instance (Num a, Ord a) => Semigroup (Max a) where (<>) = Data.Coerce.coerce (max :: a -> a -> a) instance (Num a, Ord a) => Monoid (Max a) where mempty = Max 0 mappend = (<>) newtype ShowIsId = ShowIsId String deriving Data instance Show ShowIsId where show (ShowIsId x) = x data A x = A ShowIsId x deriving Data customLayouterF :: ExactPrint.Types.Anns -> LayouterF customLayouterF anns layoutF = DataToLayouter $ f `extQ` showIsId `extQ` fastString `extQ` bytestring `extQ` occName `extQ` srcSpan `ext2Q` located where DataToLayouter f = defaultLayouterF layoutF simpleLayouter :: String -> NodeLayouter simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) showIsId :: ShowIsId -> NodeLayouter showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case Left True -> PP.parens $ PP.text s Left False -> PP.text s Right _ -> PP.text s fastString = simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString srcSpan :: GHC.SrcSpan -> NodeLayouter srcSpan ss = simpleLayouter -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}" $ "{" ++ showOutputable ss ++ "}" located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a where annStr = case cast ss of Just (s :: GHC.SrcSpan) -> ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns) Nothing -> ShowIsId "nnnnnnnn" customLayouterNoAnnsF :: LayouterF customLayouterNoAnnsF layoutF = DataToLayouter $ f `extQ` showIsId `extQ` fastString `extQ` bytestring `extQ` occName `extQ` srcSpan `ext2Q` located where DataToLayouter f = defaultLayouterF layoutF simpleLayouter :: String -> NodeLayouter simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) showIsId :: ShowIsId -> NodeLayouter showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case Left True -> PP.parens $ PP.text s Left False -> PP.text s Right _ -> PP.text s fastString = simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString srcSpan :: GHC.SrcSpan -> NodeLayouter srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}" located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter located (GHC.L _ss a) = runDataToLayouter layoutF a -- displayBriDocTree :: BriDoc -> PP.Doc -- displayBriDocTree = \case -- BDWrapAnnKey annKey doc -> def "BDWrapAnnKey" -- $ PP.text (show annKey) -- $+$ displayBriDocTree doc -- BDEmpty -> PP.text "BDEmpty" -- BDLit t -> def "BDLit" $ PP.text (show t) -- BDSeq list -> def "BDSeq" $ displayList list -- BDCols sig list -> def "BDCols" $ PP.text (show sig) -- $+$ displayList list -- BDSeparator -> PP.text "BDSeparator" -- BDPar rol indent lines -> def "BDPar" $ displayBriDocTree rol -- $+$ PP.text (show indent) -- $+$ displayList lines -- BDAlt alts -> def "BDAlt" $ displayList alts -- BDExternal ast _t -> def "BDExternal" (astToDoc ast) -- BDSpecialPostCommentLoc _ -> PP.text "BDSpecialPostCommentLoc" -- where -- def x r = PP.text x $+$ PP.nest 2 r -- displayList :: [BriDoc] -> PP.Doc -- displayList [] = PP.text "[]" -- displayList (x:xr) = PP.cat $ PP.text "[" <+> displayBriDocTree x -- : [PP.text "," <+> displayBriDocTree t | t<-xr] -- ++ [PP.text "]"] -- displayBriDocSimpleTree :: BriDocSimple -> PP.Doc -- displayBriDocSimpleTree = \case -- BDSWrapAnnKey annKey doc -> def "BDSWrapAnnKey" -- $ PP.text (show annKey) -- $+$ displayBriDocSimpleTree doc -- BDSLit t -> def "BDSLit" $ PP.text (show t) -- BDSSeq list -> def "BDSSeq" $ displayList list -- BDSCols sig list -> def "BDSCols" $ PP.text (show sig) -- $+$ displayList list -- BDSSeparator -> PP.text "BDSSeparator" -- BDSPar rol indent lines -> def "BDSPar" $ displayBriDocSimpleTree rol -- $+$ PP.text (show indent) -- $+$ displayList lines -- BDSExternal annKey _subKeys _t -> def "BDSExternal" (PP.text $ show annKey) -- BDSSpecialPostCommentLoc _ -> PP.text "BDSSpecialPostCommentLoc" -- where -- def x r = PP.text x $+$ PP.nest 2 r -- displayList :: [BriDocSimple] -> PP.Doc -- displayList [] = PP.text "[]" -- displayList (x:xr) = PP.cat $ PP.text "[" <+> displayBriDocSimpleTree x -- : [PP.text "," <+> displayBriDocSimpleTree t | t<-xr] -- ++ [PP.text "]"] traceIfDumpConf :: (MonadMultiReader Config m, Show a) => String -> (DebugConfig -> Identity (Semigroup.Last Bool)) -> a -> m () traceIfDumpConf s accessor val = do whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do trace ("---- " ++ s ++ " ----\n" ++ show val) $ return () tellDebugMess :: MonadMultiWriter (Seq String) m => String -> m () tellDebugMess s = mTell $ Seq.singleton s tellDebugMessShow :: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m () tellDebugMessShow = tellDebugMess . show -- i should really put that into multistate.. mModify :: MonadMultiState s m => (s -> s) -> m () mModify f = mGet >>= mSet . f astToDoc :: Data ast => ast -> PP.Doc astToDoc ast = printTreeWithCustom 160 customLayouterNoAnnsF ast briDocToDoc :: BriDoc -> PP.Doc briDocToDoc = astToDoc . removeAnnotations where removeAnnotations = Uniplate.transform $ \case BDAnnotationPrior _ x -> x BDAnnotationKW _ _ x -> x BDAnnotationRest _ x -> x x -> x briDocToDocWithAnns :: BriDoc -> PP.Doc briDocToDocWithAnns = astToDoc annsDoc :: ExactPrint.Types.Anns -> PP.Doc annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) breakEither :: (a -> Either b c) -> [a] -> ([b], [c]) breakEither _ [] = ([], []) breakEither fn (a1:aR) = case fn a1 of Left b -> (b : bs, cs) Right c -> (bs, c : cs) where (bs, cs) = breakEither fn aR spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs) where (ys, xs) = spanMaybe f xR spanMaybe _ xs = ([], xs) data FirstLastView a = FirstLastEmpty | FirstLastSingleton a | FirstLast a [a] a splitFirstLast :: [a] -> FirstLastView a splitFirstLast [] = FirstLastEmpty splitFirstLast [x] = FirstLastSingleton x splitFirstLast (x1:xr) = FirstLast x1 (List.init xr) (List.last xr) -- TODO: move to uniplate upstream? -- aka `transform` transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on) transformUp f = g where g = f . Uniplate.descend g _transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on) _transformDown f = g where g = Uniplate.descend g . f transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x _transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) _transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x -- | similar to List.lines, but treating the case of final newline character -- in such a manner that this function is the inverse of @intercalate "\n"@. lines' :: String -> [String] lines' s = case break (== '\n') s of (s1, []) -> [s1] (s1, [_]) -> [s1, ""] (s1, (_:r)) -> s1 : lines' r absurdExt :: HsExtension.NoExtCon -> a absurdExt = HsExtension.noExtCon