Add preprocessor backend pretty-printer (#231)

hs-bindgen/hs-bindgen.cabal

@@ -65,6 +65,10 @@ library
       HsBindgen.Backend.HsSrcExts
       HsBindgen.Backend.HsSrcExts.Render
       HsBindgen.Backend.HsSrcExts.Translation
+      HsBindgen.Backend.PP
+      HsBindgen.Backend.PP.Render.Simple
+      HsBindgen.Backend.PP.Render.Simple.Internal
+      HsBindgen.Backend.PP.Translation
       HsBindgen.Backend.TH
       HsBindgen.C.Fold
       HsBindgen.C.Fold.Common
@@ -112,6 +116,7 @@ library
     , haskell-src-exts   >= 1.23    && < 1.24
     , mtl                >= 2.2     && < 2.4
     , parsec             >= 3.1     && < 3.2
+    , pretty             >= 1.1     && < 1.2
     , pretty-show        >= 1.10    && < 1.11
     , regex-pcre-builtin >= 0.95    && < 0.96
     , scientific         >= 0.3.7   && < 0.4

hs-bindgen/src/HsBindgen/Backend/PP.hs

@@ -0,0 +1,136 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module HsBindgen.Backend.PP (
+    -- * Resolved Name
+    ResolvedName(..)
+  , BE(..)
+    -- * Backend monad
+  , M
+  , runM
+  , GenState(..)
+  ) where
+
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.Char qualified as Char
+import Data.String
+import Data.Text (Text)
+import Data.Text qualified as Text
+
+import HsBindgen.Backend.Common
+import HsBindgen.Hs.AST.Name
+import HsBindgen.Hs.AST.Type
+
+{-------------------------------------------------------------------------------
+  Backend definition
+-------------------------------------------------------------------------------}
+
+data ResolvedName = ResolvedIdent String | ResolvedOperator String
+  deriving (Eq, Show)
+
+instance IsString ResolvedName where
+  fromString s
+      | all isIdentChar s = ResolvedIdent s
+      | otherwise         = ResolvedOperator s
+    where
+      isIdentChar :: Char -> Bool
+      isIdentChar c = Char.isAlphaNum c || c == '_' || c == '\''
+
+data BE = BE
+
+instance BackendRep BE where
+  type Name BE = ResolvedName
+  type Expr BE = SExpr BE
+  type Decl BE = SDecl BE
+  type Ty   BE = SType BE
+
+  resolve BE = \case
+    Unit_type            -> resolvePrelude "()"
+    Unit_constructor     -> resolvePrelude "()"
+    Applicative_pure     -> resolvePrelude "pure"
+    Applicative_seq      -> resolvePrelude "<*>"
+    Monad_return         -> resolvePrelude "return"
+    Monad_seq            -> resolvePrelude ">>"
+    Storable_Storable    -> resolveForeign "Storable"
+    Storable_sizeOf      -> resolveForeign "sizeOf"
+    Storable_alignment   -> resolveForeign "alignment"
+    Storable_peekByteOff -> resolveForeign "peekByteOff"
+    Storable_pokeByteOff -> resolveForeign "pokeByteOff"
+    Storable_peek        -> resolveForeign "peek"
+    Storable_poke        -> resolveForeign "poke"
+    Foreign_Ptr          -> resolveForeign "Ptr"
+    PrimType hsPrimType  -> case hsPrimType of
+      HsPrimVoid    -> resolveDataVoid "Void"
+      HsPrimCChar   -> resolveForeignC "CChar"
+      HsPrimCSChar  -> resolveForeignC "CSChar"
+      HsPrimCUChar  -> resolveForeignC "CUChar"
+      HsPrimCInt    -> resolveForeignC "CInt"
+      HsPrimCUInt   -> resolveForeignC "CUInt"
+      HsPrimCShort  -> resolveForeignC "CShort"
+      HsPrimCUShort -> resolveForeignC "CUShort"
+      HsPrimCLong   -> resolveForeignC "CLong"
+      HsPrimCULong  -> resolveForeignC "CULong"
+      HsPrimCLLong  -> resolveForeignC "CLLong"
+      HsPrimCULLong -> resolveForeignC "CULLong"
+      HsPrimCBool   -> resolveForeignC "CBool"
+      HsPrimCFloat  -> resolveForeignC "CFloat"
+      HsPrimCDouble -> resolveForeignC "CDouble"
+
+  mkExpr BE = id
+
+  mkDecl BE = id
+
+  mkType BE = id
+
+instance Backend BE where
+  newtype M BE a = Gen { unwrapGen :: ReaderT Int (State GenState) a }
+    deriving newtype (
+        Functor
+      , Applicative
+      , Monad
+      , MonadState GenState
+      )
+
+  fresh _ = \x k -> withFreshName x $ k . Fresh . ResolvedIdent . Text.unpack
+
+{-------------------------------------------------------------------------------
+  Generation state
+-------------------------------------------------------------------------------}
+
+data GenState = GenState
+
+initGenState :: GenState
+initGenState = GenState
+
+{-------------------------------------------------------------------------------
+  Monad functionality
+-------------------------------------------------------------------------------}
+
+runM :: M BE a -> (a, GenState)
+runM = flip runState initGenState . flip runReaderT 0 . unwrapGen
+
+withFreshName :: HsName NsVar -> (Text -> M BE a) -> M BE a
+withFreshName x k = Gen $ do
+    i <- ask
+    local succ $ unwrapGen (k (getHsName x <> Text.pack (show i)))
+
+{-------------------------------------------------------------------------------
+  Name resolution
+-------------------------------------------------------------------------------}
+
+qualify :: String -> ResolvedName -> ResolvedName
+qualify q = \case
+    ResolvedIdent    s -> ResolvedIdent    $ q ++ '.' : s
+    ResolvedOperator s -> ResolvedOperator $ q ++ '.' : s
+
+resolveDataVoid :: ResolvedName -> ResolvedName
+resolveDataVoid = qualify "Data.Void"
+
+resolveForeign :: ResolvedName -> ResolvedName
+resolveForeign = qualify "Foreign"
+
+resolveForeignC :: ResolvedName -> ResolvedName
+resolveForeignC = qualify "Foreign.C"
+
+resolvePrelude :: ResolvedName -> ResolvedName
+resolvePrelude = id

hs-bindgen/src/HsBindgen/Backend/PP/Render/Simple.hs

@@ -0,0 +1,168 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HsBindgen.Backend.PP.Render.Simple (
+    HsRenderOpts(..)
+  , render
+  , renderIO
+  ) where
+
+import Data.Default
+import Data.Text qualified as Text
+import System.IO
+
+import HsBindgen.Backend.Common
+import HsBindgen.Backend.PP
+import HsBindgen.Backend.PP.Translation
+import HsBindgen.Hs.AST.Name
+import HsBindgen.Backend.PP.Render.Simple.Internal
+
+{-------------------------------------------------------------------------------
+  Options
+-------------------------------------------------------------------------------}
+
+-- | Rendering options
+newtype HsRenderOpts = HsRenderOpts {
+      hsLineLength :: Int
+    }
+  deriving stock (Show)
+
+instance Default HsRenderOpts where
+  def = HsRenderOpts {
+      hsLineLength = 80
+    }
+
+{-------------------------------------------------------------------------------
+  Rendering
+-------------------------------------------------------------------------------}
+
+-- | Render generated bindings
+render :: HsRenderOpts -> Module -> String
+render HsRenderOpts{..} = renderPretty (mkContext hsLineLength)
+
+-- | Write rendered bindings to the specified file (or @stdout@)
+renderIO :: HsRenderOpts -> Maybe FilePath -> Module -> IO ()
+renderIO opts Nothing   modl = putStrLn $ render opts modl
+renderIO opts (Just fp) modl = withFile fp WriteMode $ \h ->
+    hPutStrLn h $ render opts modl
+
+{-------------------------------------------------------------------------------
+  Module instance
+-------------------------------------------------------------------------------}
+
+instance Pretty Module where
+  pretty Module{..} = vsep $
+      hsep ["module", string moduleName, "where"]
+    : map pretty moduleDecls
+
+{-------------------------------------------------------------------------------
+  SDecl instance
+-------------------------------------------------------------------------------}
+
+instance Pretty (SDecl BE) where
+  pretty = \case
+    DVar name expr -> fsep
+      [ pretty name <+> char '='
+      , nest 2 $ pretty expr
+      ]
+
+    DInst Instance{..} -> vsep $
+        hsep ["instance", pretty instanceClass, pretty instanceType, "where"]
+      : ( flip map instanceDecs $ \(name, expr) -> nest 2 $ fsep
+            [ pretty name <+> char '='
+            , nest 2 $ pretty expr
+            ]
+        )
+
+    DRecord Record{..} ->
+      let d = hsep ["data", pretty dataType, char '=', pretty dataCon]
+      in  hang d 2 $ vlist '{' '}'
+            [ hsep [pretty fld, "::", pretty typ]
+            | (fld, typ) <- dataFields
+            ]
+
+    DNewtype Newtype{..} ->
+      let d = hsep ["newtype", pretty newtypeName, char '=', pretty newtypeCon]
+      in  hang d 2 $ vlist '{' '}'
+            [ hsep [pretty newtypeField, "::", pretty newtypeType]
+            ]
+
+{-------------------------------------------------------------------------------
+  SType instance
+-------------------------------------------------------------------------------}
+
+instance Pretty (SType BE) where
+  prettyPrec prec = \case
+    TGlobal g -> pretty $ resolve BE g
+
+    TCon n -> pretty n
+
+    TApp c x -> parensWhen (prec > 0) $ prettyPrec 1 c <+> prettyPrec 1 x
+
+{-------------------------------------------------------------------------------
+  SExpr instance
+-------------------------------------------------------------------------------}
+
+instance Pretty (SExpr BE) where
+  prettyPrec prec = \case
+    EGlobal g -> pretty $ resolve BE g
+
+    EVar x -> pretty $ getFresh x
+
+    ECon n -> pretty n
+
+    EInt i -> showToCtxDoc i
+
+    EApp f x -> parensWhen (prec > 3) $ prettyPrec 3 f <+> prettyPrec 4 x
+
+    e@(EInfix _op x EInfix{}) | prec <= 2 ->
+      hang (prettyPrec 1 x) 2 $ vcat (getInfixes e)
+    EInfix op x y
+      | prec > 2 -> parens $
+          hsep [prettyPrec 1 x, ppInfix (resolve BE op), prettyPrec 1 y]
+      | otherwise -> fsep
+          [ prettyPrec 1 x
+          , nest 2 $ ppInfix (resolve BE op) <+> prettyPrec 1 y
+          ]
+
+    ELam mPat body -> parensWhen (prec > 1) $ fsep
+      [ char '\\' >< maybe "_" (pretty . getFresh) mPat <+> "->"
+      , nest 2 $ pretty body
+      ]
+
+    ECase x ms -> hang (hsep ["case", pretty x, "of"]) 2 $
+      vcat . flip map ms $ \(cnst, params, body) -> fsep
+        [ hsep $ pretty cnst : map (prettyPrec 3 . getFresh) params ++ ["->"]
+        , nest 2 $ pretty body
+        ]
+
+    EInj x -> prettyPrec prec x
+
+getInfixes :: SExpr BE -> [CtxDoc]
+getInfixes = \case
+    EInfix op _x y@(EInfix _op x _y) ->
+      ppInfix (resolve BE op) <+> prettyPrec 1 x : getInfixes y
+    EInfix op _x y -> [ppInfix (resolve BE op) <+> prettyPrec 1 y]
+    _otherwise -> []
+
+{-------------------------------------------------------------------------------
+  Name instances
+-------------------------------------------------------------------------------}
+
+instance Pretty Global where
+  pretty = pretty . resolve BE
+
+instance Pretty ResolvedName where
+  pretty = \case
+    ResolvedIdent s    -> string s
+    ResolvedOperator s -> parens $ string s
+
+instance Pretty (HsName ns) where
+  pretty = string . Text.unpack . getHsName
+
+ppInfix :: ResolvedName -> CtxDoc
+ppInfix = \case
+    ResolvedIdent s    -> hcat [char '`', string s, char '`']
+    ResolvedOperator s -> string s