diff --git a/hindent.cabal b/hindent.cabal index 04297e5da..dfd822869 100644 --- a/hindent.cabal +++ b/hindent.cabal @@ -60,6 +60,9 @@ library HIndent.Ast.Declaration.Family.Type HIndent.Ast.Declaration.Family.Type.Injectivity HIndent.Ast.Declaration.Family.Type.ResultSignature + HIndent.Ast.Declaration.Foreign + HIndent.Ast.Declaration.Foreign.CallingConvention + HIndent.Ast.Declaration.Foreign.Safety HIndent.Ast.Declaration.Instance.Class HIndent.Ast.Declaration.Instance.Family.Data HIndent.Ast.Declaration.Instance.Family.Type diff --git a/src/HIndent/Ast/Declaration.hs b/src/HIndent/Ast/Declaration.hs index 711306c42..6db05a53c 100644 --- a/src/HIndent/Ast/Declaration.hs +++ b/src/HIndent/Ast/Declaration.hs @@ -14,6 +14,7 @@ import HIndent.Ast.Declaration.Data import HIndent.Ast.Declaration.Default import HIndent.Ast.Declaration.Family.Data import HIndent.Ast.Declaration.Family.Type +import HIndent.Ast.Declaration.Foreign import HIndent.Ast.Declaration.Instance.Class import HIndent.Ast.Declaration.Instance.Family.Data import HIndent.Ast.Declaration.Instance.Family.Type @@ -40,7 +41,7 @@ data Declaration | Signature Signature | StandaloneKindSignature StandaloneKind | Default DefaultDeclaration - | ForDecl (GHC.ForeignDecl GHC.GhcPs) + | Foreign ForeignDeclaration | WarningDecl (GHC.WarnDecls GHC.GhcPs) | AnnDecl (GHC.AnnDecl GHC.GhcPs) | RuleDecl (GHC.RuleDecls GHC.GhcPs) @@ -61,7 +62,7 @@ instance CommentExtraction Declaration where nodeComments Signature {} = NodeComments [] [] [] nodeComments StandaloneKindSignature {} = NodeComments [] [] [] nodeComments Default {} = NodeComments [] [] [] - nodeComments ForDecl {} = NodeComments [] [] [] + nodeComments Foreign {} = NodeComments [] [] [] nodeComments WarningDecl {} = NodeComments [] [] [] nodeComments AnnDecl {} = NodeComments [] [] [] nodeComments RuleDecl {} = NodeComments [] [] [] @@ -82,7 +83,7 @@ instance Pretty Declaration where pretty' (Signature x) = pretty x pretty' (StandaloneKindSignature x) = pretty x pretty' (Default x) = pretty x - pretty' (ForDecl x) = pretty x + pretty' (Foreign x) = pretty x pretty' (WarningDecl x) = pretty x pretty' (AnnDecl x) = pretty x pretty' (RuleDecl x) = pretty x @@ -109,7 +110,7 @@ mkDeclaration (GHC.ValD _ x) = Bind $ mkBind x mkDeclaration (GHC.SigD _ x) = Signature $ mkSignature x mkDeclaration (GHC.KindSigD _ x) = StandaloneKindSignature $ mkStandaloneKind x mkDeclaration (GHC.DefD _ x) = Default $ mkDefaultDeclaration x -mkDeclaration (GHC.ForD _ x) = ForDecl x +mkDeclaration (GHC.ForD _ x) = Foreign $ mkForeignDeclaration x mkDeclaration (GHC.WarningD _ x) = WarningDecl x mkDeclaration (GHC.AnnD _ x) = AnnDecl x mkDeclaration (GHC.RuleD _ x) = RuleDecl x diff --git a/src/HIndent/Ast/Declaration/Foreign.hs b/src/HIndent/Ast/Declaration/Foreign.hs new file mode 100644 index 000000000..118de5d86 --- /dev/null +++ b/src/HIndent/Ast/Declaration/Foreign.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} + +module HIndent.Ast.Declaration.Foreign + ( ForeignDeclaration + , mkForeignDeclaration + ) where + +import Data.Maybe +import qualified GHC.Types.ForeignCall as GHC +import qualified GHC.Types.SourceText as GHC +import qualified GHC.Types.SrcLoc as GHC +import HIndent.Ast.Declaration.Foreign.CallingConvention +import HIndent.Ast.Declaration.Foreign.Safety +import HIndent.Ast.NodeComments +import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC +import {-# SOURCE #-} HIndent.Pretty +import HIndent.Pretty.Combinators +import HIndent.Pretty.NodeComments +#if MIN_VERSION_ghc_lib_parser(9, 8, 0) +import qualified GHC.Data.FastString as GHC +#endif +data ForeignDeclaration + = ForeignImport + { convention :: CallingConvention + , safety :: Safety + , srcIdent :: Maybe String + , dstIdent :: GHC.LIdP GHC.GhcPs + , signature :: GHC.LHsSigType GHC.GhcPs + } + | ForeignExport + { convention :: CallingConvention + , srcIdent :: Maybe String + , dstIdent :: GHC.LIdP GHC.GhcPs + , signature :: GHC.LHsSigType GHC.GhcPs + } + +instance CommentExtraction ForeignDeclaration where + nodeComments ForeignImport {} = NodeComments [] [] [] + nodeComments ForeignExport {} = NodeComments [] [] [] + +instance Pretty ForeignDeclaration where + pretty' ForeignImport {..} = + spaced + $ [string "foreign import", pretty convention, pretty safety] + ++ maybeToList (fmap string srcIdent) + ++ [pretty dstIdent, string "::", pretty signature] + pretty' ForeignExport {..} = + spaced + $ [string "foreign export", pretty convention] + ++ maybeToList (fmap string srcIdent) + ++ [pretty dstIdent, string "::", pretty signature] + +mkForeignDeclaration :: GHC.ForeignDecl GHC.GhcPs -> ForeignDeclaration +#if MIN_VERSION_ghc_lib_parser(9, 8, 0) +mkForeignDeclaration GHC.ForeignImport { fd_fi = (GHC.CImport (GHC.L _ src) (GHC.L _ conv) (GHC.L _ sfty) _ _) + , .. + } = ForeignImport {..} + where + convention = mkCallingConvention conv + safety = mkSafety sfty + srcIdent = + case src of + GHC.SourceText s -> Just $ GHC.unpackFS s + _ -> Nothing + dstIdent = fd_name + signature = fd_sig_ty +mkForeignDeclaration GHC.ForeignExport { fd_fe = (GHC.CExport (GHC.L _ src) (GHC.L _ (GHC.CExportStatic _ _ conv))) + , .. + } = ForeignExport {..} + where + convention = mkCallingConvention conv + srcIdent = + case src of + GHC.SourceText s -> Just $ GHC.unpackFS s + _ -> Nothing + dstIdent = fd_name + signature = fd_sig_ty +#elif MIN_VERSION_ghc_lib_parser(9, 6, 0) +mkForeignDeclaration GHC.ForeignImport { fd_fi = (GHC.CImport (GHC.L _ src) (GHC.L _ conv) (GHC.L _ sfty) _ _) + , .. + } = ForeignImport {..} + where + convention = mkCallingConvention conv + safety = mkSafety sfty + srcIdent = + case src of + GHC.SourceText s -> Just s + _ -> Nothing + dstIdent = fd_name + signature = fd_sig_ty +mkForeignDeclaration GHC.ForeignExport { fd_fe = (GHC.CExport (GHC.L _ src) (GHC.L _ (GHC.CExportStatic _ _ conv))) + , .. + } = ForeignExport {..} + where + convention = mkCallingConvention conv + srcIdent = + case src of + GHC.SourceText s -> Just s + _ -> Nothing + dstIdent = fd_name + signature = fd_sig_ty +#else +mkForeignDeclaration GHC.ForeignImport { fd_fi = (GHC.CImport (GHC.L _ conv) (GHC.L _ sfty) _ _ (GHC.L _ src)) + , .. + } = ForeignImport {..} + where + convention = mkCallingConvention conv + safety = mkSafety sfty + srcIdent = + case src of + GHC.SourceText s -> Just s + _ -> Nothing + dstIdent = fd_name + signature = fd_sig_ty +mkForeignDeclaration GHC.ForeignExport { fd_fe = (GHC.CExport (GHC.L _ (GHC.CExportStatic _ _ conv)) (GHC.L _ src)) + , .. + } = ForeignExport {..} + where + convention = mkCallingConvention conv + srcIdent = + case src of + GHC.SourceText s -> Just s + _ -> Nothing + dstIdent = fd_name + signature = fd_sig_ty +#endif diff --git a/src/HIndent/Ast/Declaration/Foreign/CallingConvention.hs b/src/HIndent/Ast/Declaration/Foreign/CallingConvention.hs new file mode 100644 index 000000000..491ae1641 --- /dev/null +++ b/src/HIndent/Ast/Declaration/Foreign/CallingConvention.hs @@ -0,0 +1,34 @@ +module HIndent.Ast.Declaration.Foreign.CallingConvention + ( CallingConvention + , mkCallingConvention + ) where + +import qualified GHC.Types.ForeignCall as GHC +import HIndent.Ast.NodeComments +import {-# SOURCE #-} HIndent.Pretty +import HIndent.Pretty.Combinators +import HIndent.Pretty.NodeComments + +data CallingConvention + = CCall + | CApi + | StdCall + | Prim + | JavaScript + +instance CommentExtraction CallingConvention where + nodeComments _ = NodeComments [] [] [] + +instance Pretty CallingConvention where + pretty' CCall = string "ccall" + pretty' CApi = string "capi" + pretty' StdCall = string "stdcall" + pretty' Prim = string "prim" + pretty' JavaScript = string "javascript" + +mkCallingConvention :: GHC.CCallConv -> CallingConvention +mkCallingConvention GHC.CCallConv = CCall +mkCallingConvention GHC.StdCallConv = StdCall +mkCallingConvention GHC.CApiConv = CApi +mkCallingConvention GHC.PrimCallConv = Prim +mkCallingConvention GHC.JavaScriptCallConv = JavaScript diff --git a/src/HIndent/Ast/Declaration/Foreign/Safety.hs b/src/HIndent/Ast/Declaration/Foreign/Safety.hs new file mode 100644 index 000000000..03bd187a3 --- /dev/null +++ b/src/HIndent/Ast/Declaration/Foreign/Safety.hs @@ -0,0 +1,28 @@ +module HIndent.Ast.Declaration.Foreign.Safety + ( Safety + , mkSafety + ) where + +import qualified GHC.Types.ForeignCall as GHC +import HIndent.Ast.NodeComments +import {-# SOURCE #-} HIndent.Pretty +import HIndent.Pretty.Combinators +import HIndent.Pretty.NodeComments + +data Safety + = Safe + | Interruptible + | Unsafe + +instance CommentExtraction Safety where + nodeComments _ = NodeComments [] [] [] + +instance Pretty Safety where + pretty' Safe = string "safe" + pretty' Interruptible = string "interruptible" + pretty' Unsafe = string "unsafe" + +mkSafety :: GHC.Safety -> Safety +mkSafety GHC.PlaySafe = Safe +mkSafety GHC.PlayInterruptible = Interruptible +mkSafety GHC.PlayRisky = Unsafe diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs index e182c4870..66b1a8ab9 100644 --- a/src/HIndent/Pretty.hs +++ b/src/HIndent/Pretty.hs @@ -7,7 +7,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE InstanceSigs #-} -- | Pretty printing. -- @@ -33,7 +32,6 @@ import qualified GHC.Hs as GHC import GHC.Stack import qualified GHC.Types.Basic as GHC import qualified GHC.Types.Fixity as GHC -import qualified GHC.Types.ForeignCall as GHC import qualified GHC.Types.Name as GHC import qualified GHC.Types.Name.Reader as GHC import qualified GHC.Types.SourceText as GHC @@ -1544,64 +1542,6 @@ instance Pretty GHC.GhcPs (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) where pretty' GHC.HsWC {..} = pretty hswc_body - -instance Pretty (GHC.ForeignDecl GHC.GhcPs) where - pretty' GHC.ForeignImport {..} = - spaced - [ string "foreign import" - , pretty fd_fi - , pretty fd_name - , string "::" - , pretty fd_sig_ty - ] - pretty' GHC.ForeignExport {..} = - spaced - [ string "foreign export" - , pretty fd_fe - , pretty fd_name - , string "::" - , pretty fd_sig_ty - ] -#if MIN_VERSION_ghc_lib_parser(9,8,0) -instance Pretty (GHC.ForeignImport GHC.GhcPs) where - pretty' (GHC.CImport (GHC.L _ (GHC.SourceText s)) conv safety _ _) = - spaced [pretty conv, pretty safety, output s] - pretty' (GHC.CImport _ conv safety _ _) = spaced [pretty conv, pretty safety] -#elif MIN_VERSION_ghc_lib_parser(9,6,0) -instance Pretty (GHC.ForeignImport GHC.GhcPs) where - pretty' (GHC.CImport (GHC.L _ (GHC.SourceText s)) conv safety _ _) = - spaced [pretty conv, pretty safety, string s] - pretty' (GHC.CImport _ conv safety _ _) = spaced [pretty conv, pretty safety] -#else -instance Pretty GHC.ForeignImport where - pretty' (GHC.CImport conv safety _ _ (GHC.L _ (GHC.SourceText s))) = - spaced [pretty conv, pretty safety, string s] - pretty' (GHC.CImport conv safety _ _ _) = spaced [pretty conv, pretty safety] -#endif - -#if MIN_VERSION_ghc_lib_parser(9,8,0) -instance Pretty (GHC.ForeignExport GHC.GhcPs) where - pretty' (GHC.CExport (GHC.L _ (GHC.SourceText s)) conv) = - spaced [pretty conv, output s] - pretty' (GHC.CExport _ conv) = pretty conv -#elif MIN_VERSION_ghc_lib_parser(9,6,0) -instance Pretty (GHC.ForeignExport GHC.GhcPs) where - pretty' (GHC.CExport (GHC.L _ (GHC.SourceText s)) conv) = - spaced [pretty conv, string s] - pretty' (GHC.CExport _ conv) = pretty conv -#else -instance Pretty GHC.ForeignExport where - pretty' (GHC.CExport conv (GHC.L _ (GHC.SourceText s))) = - spaced [pretty conv, string s] - pretty' (GHC.CExport conv _) = pretty conv -#endif -instance Pretty GHC.CExportSpec where - pretty' (GHC.CExportStatic _ _ x) = pretty x - -instance Pretty GHC.Safety where - pretty' GHC.PlaySafe = string "safe" - pretty' GHC.PlayInterruptible = string "interruptible" - pretty' GHC.PlayRisky = string "unsafe" #if MIN_VERSION_ghc_lib_parser(9,6,1) instance Pretty (GHC.AnnDecl GHC.GhcPs) where pretty' (GHC.HsAnnotation _ (GHC.ValueAnnProvenance name) expr) = @@ -1853,13 +1793,6 @@ instance Pretty (GHC.RuleBndr GHC.GhcPs) where pretty' (GHC.RuleBndrSig _ name sig) = parens $ spaced [pretty name, string "::", pretty sig] -instance Pretty GHC.CCallConv where - pretty' GHC.CCallConv = string "ccall" - pretty' GHC.CApiConv = string "capi" - pretty' GHC.StdCallConv = string "stdcall" - pretty' GHC.PrimCallConv = string "prim" - pretty' GHC.JavaScriptCallConv = string "javascript" - instance Pretty GHC.HsSrcBang where pretty' (GHC.HsSrcBang _ unpack strictness) = do pretty unpack diff --git a/src/HIndent/Pretty.hs-boot b/src/HIndent/Pretty.hs-boot index 7bbad5059..c5ebc0e3c 100644 --- a/src/HIndent/Pretty.hs-boot +++ b/src/HIndent/Pretty.hs-boot @@ -77,8 +77,6 @@ instance Pretty (GHC.HsPatSynDir GHC.GhcPs) instance Pretty PatInsidePatDecl -instance Pretty (GHC.ForeignDecl GHC.GhcPs) - instance Pretty (GHC.WarnDecls GHC.GhcPs) instance Pretty (GHC.AnnDecl GHC.GhcPs)