pinch-gen (empty) → 0.4.0.0
raw patch · 7 files changed
+812/−0 lines, 7 filesdep +basedep +bytestringdep +directorysetup-changed
Dependencies added: base, bytestring, directory, filepath, language-thrift, megaparsec, mtl, optparse-applicative, prettyprinter, text, unordered-containers
Files
- CHANGELOG.md +4/−0
- LICENSE +0/−0
- Setup.hs +2/−0
- pinch-gen.cabal +37/−0
- src/Main.hs +41/−0
- src/Pinch/Generate.hs +512/−0
- src/Pinch/Generate/Pretty.hs +216/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+0.4 (2021-XX-XX)+================++* First version. Released on an unsuspecting world.
+ LICENSE view
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ pinch-gen.cabal view
@@ -0,0 +1,37 @@+cabal-version: >=1.10++name: pinch-gen+version: 0.4.0.0+-- synopsis:+synopsis: A code generator for the pinch Thrift library.+homepage: https://github.com/phile314/pinch-gen+bug-reports: https://github.com/phile314/pinch-gen/issues+license: BSD3+license-file: LICENSE+author: Tiko Energy Systems (Philipp Hausmann)+maintainer: philipp.hausmann@tiko.energy+category: Development+build-type: Simple+extra-source-files: CHANGELOG.md++executable pinch-gen+ main-is: Main.hs+ hs-source-dirs: src+ other-modules: Pinch.Generate+ , Pinch.Generate.Pretty+ build-depends: base >=4.12 && < 4.16+ , bytestring+ , directory+ , filepath+ , language-thrift >= 0.12.0.0+ , megaparsec+ , mtl+ , optparse-applicative+ , prettyprinter+ , text+ , unordered-containers+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/phile314/pinch-gen
+ src/Main.hs view
@@ -0,0 +1,41 @@+module Main where+++import Options.Applicative++import Pinch.Generate++import Data.Text as T+import System.FilePath++data Options = Options+ { inputFile :: FilePath+ , outputDir :: FilePath+ , genSettings :: Settings+ }+ deriving (Show)+++pOptions :: Parser Options+pOptions = Options+ <$> strOption (long "in" <> metavar "IN_FILE" <> help "Thrift input file")+ <*> strOption (long "out" <> metavar "OUT_DIR" <> help "Output folder")+ <*> pGenSettings++pGenSettings :: Parser Settings+pGenSettings = Settings+ <$> strOption (long "hashable-vec-mod" <> help "Module containing hashable instances for vector")+ <*> flag True False (long "no-generate-arbitrary")+ <*> many (strOption (long "extra-import" <> metavar "IMPORT"))++main :: IO ()+main = do+ opts <- execParser pOpts++ generate (genSettings opts) (inputFile opts) (outputDir opts)++ where+ pOpts = info (pOptions <**> helper)+ ( fullDesc+ <> progDesc "Generate Haskell files from a thrift input file."+ <> header "Thrift Haskell Code Generator")
+ src/Pinch/Generate.hs view
@@ -0,0 +1,512 @@+{-# LANGUAGE OverloadedStrings #-}++module Pinch.Generate where++import Control.Applicative+import Control.Exception+import Control.Monad.Reader+import qualified Data.ByteString as BS+import Data.Char+import qualified Data.HashMap.Strict as Map+import Data.List+import Data.Maybe+import qualified Data.Text as T+import Data.Text.Encoding+import Data.Text.Prettyprint.Doc+import Data.Text.Prettyprint.Doc.Render.Text+import Data.Void+import Language.Thrift.AST as A+import Language.Thrift.Parser+import qualified Pinch.Generate.Pretty as H+import System.Directory+import System.FilePath+import System.IO+import Text.Megaparsec (SourcePos)+import qualified Text.Megaparsec as P+import qualified Text.Megaparsec.Error as E+import qualified Text.Megaparsec.Pos as Pos++data Settings+ = Settings+ { sHashableVectorInstanceModule :: T.Text+ , sGenerateArbitrary :: Bool+ , sExtraImports :: [T.Text]+ } deriving (Show)++generate :: Settings -> FilePath -> FilePath -> IO ()+generate s inp out = do+ thrift <- loadFile inp++ mods <- gProgram s inp thrift++++ forM_ mods $ \mod -> do+ let targetFile = out </> moduleFile mod+ createDirectoryIfMissing True (dropFileName targetFile)+ withFile targetFile WriteMode (\h -> hPutDoc h $ pretty mod)++moduleFile :: H.Module -> FilePath+moduleFile m =+ (foldr (</>) "" parts) <.> "hs"+ where+ (H.ModuleName n) = H.modName m+ parts = map T.unpack $ T.splitOn "." n++extractModuleName :: FilePath -> T.Text+extractModuleName f = mconcat $ map capitalize parts+ where+ fileName = dropExtension $ takeFileName f+ parts = T.splitOn "_" $ T.pack fileName++extractNamespace :: [Header SourcePos] -> Maybe T.Text+extractNamespace headers =+ listToMaybe $ mapMaybe (\x -> case x of+ HeaderNamespace (Namespace l n _) | l == "hs" || l == "*" -> Just (n <> ".")+ _ -> Nothing+ ) headers+++loadFile :: FilePath -> IO (Program SourcePos)+loadFile inp = do+ thrift <- parseFromFile' inp+ case thrift of+ Left err -> do+ putStrLn "Could not parse thrift file."+ throwIO $ err+ Right s -> pure s++parseFromFile' :: FilePath -> IO (Either (E.ParseErrorBundle T.Text Void) (Program SourcePos))+parseFromFile' path = P.runParser thriftIDL path . decodeUtf8 <$> BS.readFile path++++gProgram :: Settings -> FilePath -> Program SourcePos -> IO [H.Module]+gProgram s inp (Program headers defs) = do+ (imports, tyMaps) <- unzip <$> traverse (gInclude baseDir) incHeaders++ let tyMap = Map.unions tyMaps+ let (typeDecls, clientDecls, serverDecls) = unzip3 $ runReader (traverse gDefinition defs) $ Context tyMap s+ let mkMod suffix = H.Module (H.ModuleName $ modBaseName <> suffix)+ [ H.PragmaLanguage "TypeFamilies, DeriveGeneric, TypeApplications"+ , H.PragmaOptsGhc "-fno-warn-unused-imports -fno-warn-name-shadowing -fno-warn-unused-matches" ]+ pure $+ [ -- types+ mkMod ".Types"+ (imports ++ defaultImports ++ map+ (\n -> H.ImportDecl (H.ModuleName n) True H.IEverything)+ (sExtraImports s ++ if sGenerateArbitrary s then [ "Test.QuickCheck" ] else [])+ )+ (concat typeDecls)+ , -- client+ mkMod ".Client"+ ( [ impTypes+ , H.ImportDecl (H.ModuleName "Pinch.Client") True H.IEverything+ ] ++ imports ++ defaultImports)+ (concat clientDecls)+ , -- server+ mkMod ".Server"+ ( [ impTypes+ , H.ImportDecl (H.ModuleName "Pinch.Server") True H.IEverything+ ] ++ imports ++ defaultImports)+ (concat serverDecls)+ ]++ where+ ns = fromMaybe "" $ extractNamespace headers+ modBaseName = ns <> extractModuleName inp+ baseDir = dropFileName inp+ incHeaders = mapMaybe (\x -> case x of+ HeaderInclude i -> Just i+ _ -> Nothing)+ headers+ impTypes = H.ImportDecl (H.ModuleName $ modBaseName <> ".Types") False H.IEverything+ defaultImports =+ [ H.ImportDecl (H.ModuleName "Prelude") True H.IEverything+ , H.ImportDecl (H.ModuleName "Control.Applicative") True H.IEverything+ , H.ImportDecl (H.ModuleName "Control.Exception") True H.IEverything+ , H.ImportDecl (H.ModuleName "Pinch") True H.IEverything+ , H.ImportDecl (H.ModuleName "Pinch.Server") True H.IEverything+ , H.ImportDecl (H.ModuleName "Pinch.Internal.RPC") True H.IEverything+ , H.ImportDecl (H.ModuleName "Data.Text") True H.IEverything+ , H.ImportDecl (H.ModuleName "Data.ByteString") True H.IEverything+ , H.ImportDecl (H.ModuleName "Data.Int") True H.IEverything+ , H.ImportDecl (H.ModuleName "Data.Vector") True H.IEverything+ , H.ImportDecl (H.ModuleName "Data.HashMap.Strict") True H.IEverything+ , H.ImportDecl (H.ModuleName "Data.HashSet") True H.IEverything+ , H.ImportDecl (H.ModuleName "GHC.Generics") True H.IEverything+ , H.ImportDecl (H.ModuleName "Data.Hashable") True H.IEverything+ , H.ImportDecl (H.ModuleName $ sHashableVectorInstanceModule s) False (H.IJust [])+ ]++type ModuleMap = Map.HashMap T.Text H.ModuleName++data Context+ = Context+ { cModuleMap :: ModuleMap+ , cSettings :: Settings+ }++type GenerateM = Reader Context++gInclude :: FilePath -> Include SourcePos -> IO (H.ImportDecl, ModuleMap)+gInclude dir i = do+ -- TODO handle recursive includes ...+ (Program headers _) <- loadFile (dir </> (T.unpack $ includePath i))+ let modName = H.ModuleName $ fromMaybe "" (extractNamespace headers) <> extractModuleName (T.unpack $ includePath i) <> ".Types"+ let thriftModName = T.pack $ dropExtension $ T.unpack $ includePath i+ pure (H.ImportDecl modName True H.IEverything, Map.singleton thriftModName modName)++gDefinition :: Definition SourcePos -> GenerateM ([H.Decl], [H.Decl], [H.Decl])+gDefinition def = case def of+ ConstDefinition _ -> pure ([], [], [])+ TypeDefinition ty -> (\x -> (x, [], [])) <$> gType ty+ ServiceDefinition s -> gService s++gType :: Type SourcePos -> GenerateM [H.Decl]+gType ty = case ty of+ TypedefType t -> gTypedef t+ EnumType e -> gEnum e+ StructType s -> gStruct s+ _ -> pure []++gTypedef :: Typedef SourcePos -> GenerateM [H.Decl]+gTypedef def = do+ tyRef <- gTypeReference $ typedefTargetType def+ pure [H.TypeDecl (H.TyCon $ capitalize $ typedefName $ def) tyRef]++gTypeReference :: TypeReference SourcePos -> GenerateM H.Type+gTypeReference ref = case ref of+ StringType _ _ -> tyCon "Data.Text.Text"+ BinaryType _ _ -> tyCon "Data.ByteString.ByteString"+ BoolType _ _ -> tyCon "Prelude.Bool"+ DoubleType _ _ -> tyCon "Prelude.Double"+ I16Type _ _ -> tyCon "Data.Int.Int16"+ I32Type _ _ -> tyCon "Data.Int.Int32"+ I64Type _ _ -> tyCon "Data.Int.Int64"+ ListType elemTy _ _ -> H.TyApp (H.TyCon $ "Data.Vector.Vector") <$> traverse gTypeReference [elemTy]+ MapType kTy vTy _ _ -> H.TyApp (H.TyCon $ "Data.HashMap.Strict.HashMap") <$> traverse gTypeReference [kTy, vTy]+ SetType ty _ _ -> H.TyApp (H.TyCon $ "Data.HashSet.HashSet") <$> traverse gTypeReference [ty]+ DefinedType ty _ -> case T.splitOn "." ty of+ xs@(x1:x2:_) -> do+ map <- asks cModuleMap+ case Map.lookup (mconcat $ init xs) map of+ Nothing -> tyCon $ capitalize ty+ Just (H.ModuleName n) -> pure $ H.TyCon $ n <> "." <> capitalize (last xs)+ _ -> tyCon $ capitalize ty+ ty -> error $ "Unsupported type: " <> show ty++ where tyCon = pure . H.TyCon++gEnum :: A.Enum SourcePos -> GenerateM [H.Decl]+gEnum e = do+ settings <- asks cSettings+ pure (+ [ H.DataDecl tyName cons [ derivingEq, derivingOrd, derivingGenerics, derivingShow, derivingBounded ]+ , H.InstDecl (H.InstHead [] clPinchable (H.TyCon tyName))+ [ H.TypeDecl (H.TyApp tag [ H.TyCon tyName ]) (H.TyCon $ "Pinch.TEnum")+ , H.FunBind pinch'+ , H.FunBind [unpinch']+ ]+ , H.InstDecl (H.InstHead [] "Prelude.Enum" (H.TyCon tyName))+ [ H.FunBind fromEnum'+ , H.FunBind (toEnum' ++ [toEnumDef])+ ]+ , H.InstDecl (H.InstHead [] clHashable (H.TyCon tyName)) []+ ] ++ if sGenerateArbitrary settings then [+ H.InstDecl (H.InstHead [] clArbitrary (H.TyCon tyName)) [+ H.FunBind [ arbitrary ]+ ]+ ] else [])+ where+ tyName = enumName e+ unpinch = H.Match "unpinch" [H.PVar "x"]+ (H.EApp "Prelude.fmap" [ "Prelude.toEnum Prelude.. Prelude.fromIntegral", H.EApp "Pinch.unpinch" [ "x" ]])+ (cons, fromEnum', toEnum', pinch', unpinchAlts') = unzip5 $ map gEnumDef $ zip [0..] $ enumValues e++ defAlt = H.Alt (H.PVar "_")+ (H.EApp "Prelude.fail"+ [ H.EInfix "Prelude.<>"+ (H.ELit $ H.LString $ "Unknown value for type " <> enumName e <> ": ")+ (H.EApp "Prelude.show" [ "val"] )+ ]+ )+ toEnumDef = H.Match "toEnum" [H.PVar "_"] (H.EApp "Prelude.error" [ H.ELit $ H.LString $ "Unknown value for enum " <> enumName e <> "." ])+ unpinch' = H.Match "unpinch" [H.PVar "v"]+ ( H.EDo+ [ H.StmBind (Just $ H.PVar "val") (H.EApp "Pinch.unpinch" ["v"])+ , H.StmBind Nothing (H.ECase (H.ETyAnn "val" (H.TyCon $ "Data.Int.Int32")) (unpinchAlts' ++ [defAlt]) )+ ]+ )+ arbitrary = H.Match "arbitrary" [] (+ H.EApp "Test.QuickCheck.elements" [H.EList $ map (H.EVar . enumDefName) $ enumValues e]+ )++gEnumDef :: (Integer, EnumDef SourcePos) -> (H.ConDecl, H.Match, H.Match, H.Match, H.Alt)+gEnumDef (i, ed) =+ ( H.ConDecl conName []+ , H.Match "fromEnum" [H.PCon conName []] (H.ELit $ H.LInt index)+ , H.Match "toEnum" [H.PLit $ H.LInt index] (H.EVar conName)+ , H.Match "pinch" [H.PCon conName []]+ ( H.EApp "Pinch.pinch"+ [ H.ETyAnn (H.ELit $ H.LInt index) (H.TyCon $ "Data.Int.Int32") ]+ )+ , H.Alt (H.PLit $ H.LInt index) (H.EApp "Prelude.pure" [ H.EVar conName ])+ )+ where+ index = fromMaybe i $ enumDefValue ed+ conName = enumDefName ed++gStruct :: Struct SourcePos -> GenerateM [H.Decl]+gStruct s = case structKind s of+ UnionKind -> (++ [hashable]) <$> unionDatatype tyName (structFields s) SRCNone+ StructKind -> (++ [hashable]) <$> structDatatype tyName (structFields s)+ ExceptionKind -> (++ [hashable, ex]) <$> structDatatype tyName (structFields s)+ where+ tyName = structName s+ hashable = H.InstDecl (H.InstHead [] clHashable (H.TyCon tyName)) []+ ex = H.InstDecl (H.InstHead [] clException (H.TyCon tyName)) []+++structDatatype :: T.Text -> [Field SourcePos] -> GenerateM [H.Decl]+structDatatype nm fs = do+ fields <- traverse (gField $ decapitalize $ nm) $ zip [1..] fs+ let (_, nms, tys, _) = unzip4 fields+ let stag = H.TypeDecl (H.TyApp tag [ H.TyCon nm ]) (H.TyCon $ "Pinch.TStruct")+ let pinch = H.FunBind+ [ H.Match "pinch" [H.PCon nm $ map H.PVar nms]+ ( H.EApp "Pinch.struct" [ H.EList $ flip map fields $ \(fId, fNm, fTy, fReq) ->+ let+ op = if fReq then "Pinch..=" else "Pinch.?="+ in H.EInfix op (H.ELit $ H.LInt fId) (H.EVar fNm)+ ])+ ]+ let unpinch = H.FunBind+ [ H.Match "unpinch" [H.PVar "value"] $+ foldl'+ (\acc (fId, fNm, fTy, fReq) ->+ H.EInfix "Prelude.<*>" acc (+ H.EInfix (if fReq then "Pinch..:" else "Pinch..:?")+ "value"+ (H.ELit $ H.LInt fId)+ )+ )+ (H.EApp "Prelude.pure" [ H.EVar $ nm ] )+ fields+ ]+ let arbitrary = H.FunBind+ [ H.Match "arbitrary" [] $+ foldl'+ (\acc _ ->+ H.EInfix "Prelude.<*>" acc (+ "Test.QuickCheck.arbitrary"+ )+ )+ (H.EApp "Prelude.pure" [ H.EVar $ nm ] )+ fields+ ]+ settings <- asks cSettings+ pure $+ [ H.DataDecl nm+ [ H.RecConDecl nm (zip nms tys)+ ]+ [ derivingEq, derivingGenerics, derivingShow ]+ , H.InstDecl (H.InstHead [] clPinchable (H.TyCon nm)) [ stag, pinch, unpinch ]+ ] ++ (if sGenerateArbitrary settings then [+ H.InstDecl (H.InstHead [] clArbitrary (H.TyCon nm)) [ arbitrary ]+ ] else [])++data ServiceResultCon = SRCNone | SRCVoid H.Name++unionDatatype :: T.Text -> [Field SourcePos] -> ServiceResultCon -> GenerateM [H.Decl]+unionDatatype nm fs defCon = do+ fields <- traverse (gField $ nm) $ zip [1..] $ map (\f -> f { fieldRequiredness = Just Required, fieldName = capitalize (fieldName f) } ) fs+ let stag = H.TypeDecl (H.TyApp tag [ H.TyCon nm ]) (H.TyCon $ "Pinch.TUnion")+ let pinch = H.FunBind $+ map (\(fId, fNm, _, _) ->+ H.Match "pinch" [H.PCon fNm [H.PVar "x"]]+ ( H.EApp "Pinch.union" [ H.ELit $ H.LInt fId, "x"]+ )++ ) fields ++ case defCon of+ SRCNone -> []+ SRCVoid c ->+ [ H.Match "pinch" [H.PCon (nm <> c) []]+ ( H.EApp "Pinch.pinch" [ "Pinch.Internal.RPC.Unit" ]+ )+ ]+ let unpinch = H.FunBind+ [ H.Match "unpinch" [H.PVar "v"] $+ foldl'+ (\acc (fId, fNm, _, _) ->+ H.EInfix "Control.Applicative.<|>" acc (+ H.EInfix "Prelude.<$>"+ (H.EVar fNm)+ (H.EInfix "Pinch..:" "v" $ H.ELit $ H.LInt fId)+ )+ )+ ( case defCon of+ SRCNone -> "Control.Applicative.empty"+ SRCVoid c ->+ H.EInfix "Prelude.<$" (H.EVar (nm <> c))+ "(Pinch.unpinch v :: Pinch.Parser Pinch.Internal.RPC.Unit)"+ )+ fields+ ]+ let cons = map (\(_, nm, ty, _) -> H.ConDecl nm [ ty ]) fields ++ case defCon of+ SRCNone -> []+ SRCVoid c -> [H.ConDecl (nm <> c) []]+ let arbitrary = H.FunBind+ [ H.Match "arbitrary" [] $+ H.EApp "Test.QuickCheck.oneof"+ [ H.EList $+ map+ (\(_, nm, _, _) ->+ H.EInfix "Prelude.<$>" (H.EVar nm) "Test.QuickCheck.arbitrary"+ )+ fields+ ]+ ]+ settings <- asks cSettings+ pure $+ [ H.DataDecl nm+ cons+ [ derivingEq, derivingGenerics, derivingShow ]+ , H.InstDecl (H.InstHead [] clPinchable (H.TyCon nm)) [ stag, pinch, unpinch ]+ ] ++ (if sGenerateArbitrary settings then [+ H.InstDecl (H.InstHead [] clArbitrary (H.TyCon nm)) [ arbitrary ]+ ] else [])++gField :: T.Text -> (Integer, Field SourcePos) -> GenerateM (Integer, H.Name, H.Type, Bool)+gField prefix (i, f) = do+ (req, ty) <- gFieldType f+ let index = fromMaybe i (fieldIdentifier f)+ pure (index, prefix <> "_" <> fieldName f, ty, req)+++gService :: Service SourcePos -> GenerateM ([H.Decl], [H.Decl], [H.Decl])+gService s = do+ (nms, tys, handlers, calls, tyDecls) <- unzip5 <$> traverse gFunction (serviceFunctions s)+ let serverDecls =+ [ H.DataDecl serviceTyName [ H.RecConDecl serviceConName $ zip nms tys ] []+ , H.TypeSigDecl (prefix <> "_mkServer") (H.TyLam [H.TyCon serviceConName] (H.TyCon "Pinch.Server.ThriftServer"))+ , H.FunBind+ [ H.Match (prefix <> "_mkServer") [H.PVar "server"]+ ( H.ELet "functions" + (H.EApp "Data.HashMap.Strict.fromList" [ H.EList handlers ] )+ ( H.EApp "Pinch.Server.createServer"+ [ (H.ELam ["nm"]+ (H.EApp "Data.HashMap.Strict.lookup"+ [ "nm", "functions" ]+ )+ )+ ]+ )+ )+ ]+ ]+ pure (concat tyDecls, concat calls, serverDecls)+ where+ serviceTyName = capitalize $ serviceName s+ serviceConName = capitalize $ serviceName s+ prefix = decapitalize $ serviceName s++gFieldType :: Field SourcePos -> GenerateM (Bool, H.Type)+gFieldType f = do+ ty <- gTypeReference (fieldValueType f)+ case fieldRequiredness f of+ Just Optional -> pure (False, H.TyApp (H.TyCon $ "Prelude.Maybe") [ ty ])+ _ -> pure (True, ty)++gFunction :: Function SourcePos -> GenerateM (H.Name, H.Type, H.Exp, [H.Decl], [H.Decl])+gFunction f = do+ argTys <- traverse (fmap snd . gFieldType) (functionParameters f)+ retType <- maybe (pure tyUnit) gTypeReference (functionReturnType f)+++ argDataTy <- structDatatype argDataTyNm (functionParameters f)+ let catchers = map+ (\e -> H.EApp "Control.Exception.Handler"+ [ H.EInfix "Prelude.." "Prelude.pure" (H.EVar $ dtNm <> "_" <> capitalize (fieldName e))+ ]+ ) exceptions+ let resultField = fmap (\ty -> Field (Just 0) (Just Optional) ty "success" Nothing [] Nothing (Pos.initialPos "")) (functionReturnType f)+ (resultDecls, resultDataTy, resultDataCon) <- case (functionReturnType f, exceptions) of+ (Nothing, []) -> pure ([], H.TyCon "Pinch.Internal.RPC.Unit", "Pinch.Internal.RPC.Unit")+ _ -> do+ let thriftResultInst = H.InstDecl (H.InstHead [] "Pinch.Internal.RPC.ThriftResult" (H.TyCon dtNm))+ [ H.TypeDecl (H.TyApp (H.TyCon "ResultType") [ H.TyCon dtNm ]) retType+ , H.FunBind (+ map (\e -> H.Match "unwrap" [H.PCon (dtNm <> "_" <> capitalize (fieldName e)) [H.PVar "x"]] (H.EApp "Control.Exception.throwIO" ["x"])) exceptions+ ++ [ H.Match "unwrap" [H.PCon (dtNm <> "_Success") (const (H.PVar "x") <$> maybeToList (functionReturnType f))] (H.EApp "Prelude.pure" (maybeToList $ ("x" <$ functionReturnType f) <|> pure "()"))]+ )+ , H.FunBind [H.Match "wrap" ["m"] (+ ( H.EApp "Control.Exception.catches"+ [ H.EInfix+ (if isNothing (functionReturnType f) then "Prelude.<$" else "Prelude.<$>")+ (H.EVar $ dtNm <> "_Success")+ "m"+ , H.EList catchers+ ]+ ) ) ]+ ]+ dt <- unionDatatype+ dtNm+ (maybeToList resultField ++ exceptions)+ (case functionReturnType f of+ Nothing -> SRCVoid "_Success"+ _ -> SRCNone+ )+ pure ((thriftResultInst : dt), H.TyCon dtNm, H.EVar $ dtNm <> "_Success")+++ let srvFunTy = H.TyLam ([H.TyCon "Pinch.Server.Context"] ++ argTys) (H.TyApp tyIO [retType])+ let clientFunTy = H.TyLam argTys (H.TyApp (H.TyCon "Pinch.Client.ThriftCall") [resultDataTy])+ let callSig = H.TypeSigDecl nm $ clientFunTy+ let call = H.FunBind+ [ H.Match nm ( map (H.PVar . fieldName) $ functionParameters f)+ ( H.EApp (if functionOneWay f then "Pinch.Client.TOneway" else "Pinch.Client.TCall")+ [ H.ELit $ H.LString $ functionName f+ , H.EApp (H.EVar argDataTyNm) $ map (H.EVar . fieldName) (functionParameters f)+ ]+ )+ ]+ let handler = H.ETuple+ [ H.ELit $ H.LString $ functionName f+ , H.EApp (if functionOneWay f then "Pinch.Server.OnewayHandler" else "Pinch.Server.CallHandler")+ [ H.ELam [ "ctx", H.PCon argDataTyNm (map H.PVar argVars) ] (+ (if functionOneWay f then id else+ (\c -> H.EApp (H.ETyApp "Pinch.Internal.RPC.wrap" [ resultDataTy ]) [c])+ )+ (H.EApp (H.EVar nm) (["server", "ctx"] ++ map H.EVar argVars))+ )+ ]+ ]++ pure ( nm, srvFunTy, handler, [callSig, call], (argDataTy ++ resultDecls))+ where+ nm = decapitalize $ functionName f+ dtNm = capitalize (functionName f) <> "_Result"+ argVars = take (length $ functionParameters f) $ map T.singleton ['a'..]+ argDataTyNm = capitalize $ functionName f <> "_Args"+ exceptions = concat $ maybeToList $ functionExceptions f++tag = H.TyCon $ "Tag"+clPinchable = "Pinch.Pinchable"+clHashable = "Data.Hashable.Hashable"+tyUnit = H.TyCon $ "()"+tyIO = H.TyCon $ "Prelude.IO"+clException = "Control.Exception.Exception"+clArbitrary = "Test.QuickCheck.Arbitrary"++decapitalize :: T.Text -> T.Text+decapitalize s = if T.null s then "" else T.singleton (toLower $ T.head s) <> T.tail s++capitalize :: T.Text -> T.Text+capitalize s = if T.null s then "" else T.singleton (toUpper $ T.head s) <> T.tail s++derivingShow = H.DeriveClass $ H.TyCon $ "Prelude.Show"+derivingEq = H.DeriveClass $ H.TyCon $ "Prelude.Eq"+derivingOrd = H.DeriveClass $ H.TyCon $ "Prelude.Ord"+derivingGenerics = H.DeriveClass $ H.TyCon $ "GHC.Generics.Generic"+derivingBounded = H.DeriveClass $ H.TyCon $ "Prelude.Bounded"
+ src/Pinch/Generate/Pretty.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Pinch.Generate.Pretty where++import Data.String+import qualified Data.Text as T+import Data.Text.Prettyprint.Doc++newtype ModuleName = ModuleName T.Text+ deriving (Show)+type TypeName = T.Text+type Name = T.Text+type ClassName = T.Text++data Module = Module+ { modName :: ModuleName+ , modPragmas :: [Pragma]+ , modImports :: [ImportDecl]+ , modDecls :: [Decl]+ }+ deriving (Show)++data Pragma+ = PragmaLanguage T.Text+ | PragmaOptsGhc T.Text+ deriving (Show)++data ImportDecl = ImportDecl+ { iName :: ModuleName+ , iQualified :: Bool+ , iThings :: ImportNames+ }+ deriving (Show)++data ImportNames+ = IEverything+ | IJust [ Name ]+ deriving (Show)++data Decl+ = TypeDecl Type Type+ | DataDecl TypeName [ConDecl] [Deriving]+ | InstDecl InstHead [Decl]+ | FunBind [Match]+ | TypeSigDecl Name Type+ deriving (Show)++data Deriving+ = DeriveClass Type+ deriving (Show)++data ConDecl+ = ConDecl Name [Type]+ | RecConDecl Name [(Name, Type)]+ deriving (Show)++data Type+ = TyApp Type [Type]+ | TyCon TypeName+ | TyLam [Type] Type+ deriving (Show)+++data InstHead+ = InstHead [Constraint] ClassName Type+ deriving (Show)++data Constraint+ = CClass ClassName Type+ deriving (Show)++data Match = Match Name [Pat] Exp+ deriving (Show)++data Pat+ = PVar Name+ | PLit Lit+ | PCon Name [Pat]+ deriving (Show)++data Exp+ = EVar Name+ | EApp Exp [Exp]+ | ELit Lit+ | ETyAnn Exp Type+ | ECase Exp [Alt]+ | EDo [Stm]+ | EInfix Name Exp Exp+ | EList [Exp]+ | ELam [Pat] Exp+ | ETuple [Exp]+ | ELet Name Exp Exp+ | ETyApp Exp [Type]+ deriving (Show)++data Stm+ = StmBind (Maybe Pat) Exp+ deriving (Show)++data Alt+ = Alt Pat Exp+ deriving (Show)++data Lit+ = LInt Integer+ | LString T.Text+ deriving (Show)++instance Pretty ModuleName where+ pretty (ModuleName x) = pretty x++instance Pretty Module where+ pretty mod =+ vsep (map pretty $ modPragmas mod) <> line <> line+ <> "module" <+> pretty (modName mod) <+> "where" <> line <> line+ <> vsep (map pretty $ modImports mod) <> line <> line+ <> vsep (map pretty $ modDecls mod)++instance Pretty Pragma where+ pretty p = case p of+ PragmaLanguage p -> "{-# LANGUAGE" <+> pretty p <+> "#-}"+ PragmaOptsGhc o -> "{-# OPTIONS_GHC" <+> pretty o <+> "#-}"++instance Pretty ImportDecl where+ pretty i = "import" <+> (if (iQualified i) then "qualified" else "") <+> pretty (iName i) <> pretty (iThings i)++instance Pretty ImportNames where+ pretty i = case i of+ IEverything -> ""+ IJust xs -> " " <> (parens $ cList $ map pretty xs)++instance Pretty Decl where+ pretty decl = case decl of+ TypeDecl t1 t2 -> "type" <+> pretty t1 <+> "=" <+> pretty t2 <> line+ DataDecl t [] ds -> "data" <+> pretty t <+> prettyDerivings ds <> line+ DataDecl t (c:cs) ds -> nest 2 (vsep $+ [ "data" <+> pretty t+ , "=" <+> pretty c+ ] ++ (map (\c -> "|" <+> pretty c) cs) ++ [ prettyDerivings ds ]+ ) <> line+ InstDecl h decls -> (nest 2 $ vsep $ [ pretty h ] ++ map pretty decls) <> line+ FunBind ms -> vsep (map pretty ms) <> line+ TypeSigDecl n ty -> pretty n <+> "::" <+> pretty ty++prettyDerivings :: [Deriving] -> Doc a+prettyDerivings [] = ""+prettyDerivings ds = "deriving" <+> (parens $ cList $ map pretty ds)++instance Pretty Deriving where+ pretty (DeriveClass c) = pretty c++instance Pretty ConDecl where+ pretty (ConDecl n args) = hsep $ [ pretty n ] ++ map pretty args+ pretty (RecConDecl n args) = hsep $ [ pretty n, "{", fields, "}" ]+ where fields = cList $ map (\(n, v) -> pretty n <+> "::" <+> pretty v) args++instance Pretty InstHead where+ pretty (InstHead cs n ty) = "instance" <> context <+> pretty n <+> pretty ty <+> "where"+ where context = if null cs then "" else space <> parens (cList $ map pretty cs) <+> "=>" <+> pretty n <+> pretty ty <+> "where"++instance Pretty Constraint where+ pretty (CClass cl n) = pretty cl <+> pretty n++instance Pretty Type where+ pretty ty = case ty of+ TyApp t1 ts -> parens $ pretty t1 <+> hsep (map pretty ts)+ TyCon t -> pretty t+ TyLam ts t -> concatWith (surround (space <> "->" <> space)) (map (parens . pretty) ts ++ [pretty t])++instance Pretty Match where+ pretty (Match n ps e) = pretty n <+> hsep (map pretty ps) <+> "=" <+> pretty e++instance Pretty Pat where+ pretty p = case p of+ (PVar x) -> pretty x+ (PLit i) -> pretty i+ (PCon n []) -> pretty n+ (PCon n xs) -> parens $ pretty n <+> hsep (map pretty xs)++instance Pretty Exp where+ pretty e = case e of+ EVar n -> pretty n+ EApp e es -> pretty e <+> hsep (map (parens . pretty) es)+ ELit l -> pretty l+ ETyAnn e ty -> parens $ pretty e <+> "::" <+> pretty ty+ ECase e as -> nest 2 $ vsep $ ["case" <+> pretty e <+> "of"] ++ map pretty as+ EDo s -> nest 2 $ vsep $ ["do"] ++ map pretty s+ EInfix op e1 e2 -> parens $ hsep [ pretty e1, pretty op, pretty e2]+ EList es -> "[" <+> cList (map pretty es) <+> "]"+ ELam ps e -> parens $ "\\" <> hsep (map pretty ps) <+> "->" <+> pretty e+ ETuple es -> nest 2 $ tupled $ map pretty es+ ELet nm e1 e2 -> "let" <+> pretty nm <+> "=" <+> indent 2 (pretty e1) <+> "in" <+> pretty e2+ ETyApp e tys -> pretty e <+> hsep (map (("@"<>) . parens . pretty) tys)++instance Pretty Alt where+ pretty (Alt p e) = pretty p <+> "->" <+> pretty e++instance Pretty Stm where+ pretty s = case s of+ StmBind Nothing e -> pretty e+ StmBind (Just p) e -> pretty p <+> "<-" <+> pretty e++instance Pretty Lit where+ pretty l = case l of+ LInt i -> pretty i+ LString t -> "\"" <> pretty t <> "\""++cList = concatWith (surround (comma <> space))+++instance IsString Exp where+ fromString = EVar . T.pack++instance IsString Pat where+ fromString = PVar . T.pack