Generate haskell comments

lib/namma-dsl/src/NammaDSL/DSL/Parser/API.hs

@@ -104,6 +104,7 @@ parseAllApis' = do
       obj <- preview (_Object) val
       let params = fromMaybe KM.empty $ preview (ix acc_params ._Object) obj
           endpoint = parseEndpoint params $ fromMaybe (error "Endpoint not found !") $ preview (ix acc_endpoint . _String) obj
+          endpointText = fromMaybe (error "Endpoint not found !") $ preview (ix acc_endpoint . _String) obj
           auth = getAuthType <$> preview (ix acc_auth . _String) obj
 
           req = parseRequest obj
@@ -139,7 +140,7 @@ parseAllApis' = do
               A.Null -> ApiMigration (toText k) Nothing
               _ -> error "String or Null migration params only supported for now"
 
-      return $ ApiTT allApiParts apiTp apiName auth headers multipart req res helperApi apiKind moduleName requestValidation migrations
+      return $ ApiTT allApiParts apiTp apiName endpointText auth headers multipart req res helperApi apiKind moduleName requestValidation migrations
     parseSingleApi _ _ _ _ = error "Api specs missing"
 
     parseRequest :: A.Object -> Maybe ApiReq

lib/namma-dsl/src/NammaDSL/DSL/Syntax/API.hs

@@ -74,6 +74,7 @@ data ApiTT = ApiTT
   { _urlParts :: [UrlParts],
     _apiType :: ApiType,
     _apiName :: Maybe Text,
+    _apiEndpoint :: Text,
     _authType :: Maybe AuthType,
     _header :: [HeaderType],
     _apiMultipartType :: Maybe ApiMultipart,

lib/namma-dsl/src/NammaDSL/Generator/Haskell/Common.hs

@@ -336,3 +336,22 @@ mkFullUserActionType apiRead apiTT = do
   let moduleUserActionType = screamingSnake $ T.unpack (apiTT ^. apiModuleName)
   let endpointUserActionType = mkUserActionTypeName apiTT
   pure (folderUserActionType, moduleUserActionType, endpointUserActionType)
+
+-- example:
+-- ============================================================================
+------------- postMerchantConfigFarePolicyDriverExtraFeeBoundsCreate ----------
+
+delimiterComment :: String -> Writer r CodeUnit
+delimiterComment handlerName = do
+  let delimiterLength = 80
+  commentW $ " " <> replicate (delimiterLength - 4) '='
+  commentW $
+    replicate 11 '-'
+      <> " "
+      <> handlerName
+      <> do
+        let remainder = delimiterLength - length handlerName - 16
+        if remainder > 0
+          then " " <> replicate remainder '-'
+          else ""
+  addNewLineW

lib/namma-dsl/src/NammaDSL/Generator/Haskell/Dashboard/DomainHandler.hs

@@ -143,6 +143,7 @@ handlerFunctionDef serverName clientFuncName apiT = do
       apiUnits = map apiSignatureUnit signatureUnits
       showType = cT . T.unpack <$> filter (/= T.empty) (init allTypes)
       handlerTypes = apiAuthTypeMapperServant DOMAIN_HANDLER_DASHBOARD apiT <> showType <> [cT "Environment.Flow" ~~ cT (T.unpack $ last allTypes)]
+  delimiterComment $ T.unpack functionName
   TH.decsW $ do
     TH.sigDW (TH.mkNameT functionName) $ do
       TH.forallT [] [] $

lib/namma-dsl/src/NammaDSL/Generator/Haskell/Dashboard/Servant.hs

@@ -119,11 +119,24 @@ mkCodeBody generationType apiRead = do
   let allApis = input ^. apis
   tellM . fromMaybe mempty $
     interpreter input $ do
+      generateApiListComment
       generateAPIType SERVANT_API_DASHBOARD apiRead
       generateAPIHandler apiRead
       forM_ allApis $ generateServantApiType generationType apiRead
       forM_ allApis $ handlerFunctionDef generationType apiRead
 
+generateApiListComment :: Writer CodeUnit
+generateApiListComment = do
+  input <- ask
+  let moduleName' = input ^. moduleName
+  commentW $ T.unpack moduleName' <> "APIs:"
+  let apiPrefix' =
+        T.unpack $
+          fromMaybe (headToLower $ input ^. moduleName) $
+            input ^. apiPrefix
+  forM_ (input ^. apis) \api -> do
+    commentW $ show (api ^. apiType) <> " /" <> apiPrefix' <> T.unpack (api ^. apiEndpoint)
+
 generateAPIHandler :: ApiRead -> Writer CodeUnit
 generateAPIHandler apiRead = do
   input <- ask

lib/namma-dsl/src/NammaDSL/Generator/Haskell/DomainHandler.hs

@@ -79,7 +79,7 @@ mkCodeBody apiKind = do
       forM_ (_apis input) $ generateHandlerFunction apiKind
 
 generateHandlerFunction :: ApiKind -> ApiTT -> Writer CodeUnit
-generateHandlerFunction apiKind apiT = decsW $ do
+generateHandlerFunction apiKind apiT = do
   let functionName = handlerFunctionText apiT
       authToType = apiAuthTypeMapperDomainHandler apiT
       signatureUnits = case apiKind of
@@ -89,25 +89,27 @@ generateHandlerFunction apiKind apiT = decsW $ do
       apiUnits = map apiSignatureUnit signatureUnits
       showType = cT . T.unpack <$> filter (/= T.empty) (init allTypes)
       handlerTypes = authToType <> showType <> [cT "Environment.Flow" ~~ cT (T.unpack $ last allTypes)]
-  TH.sigDW (mkNameT functionName) $ do
-    TH.forallT [] [] $
-      TH.appendInfixT "->" $ NE.fromList handlerTypes
-  TH.funDW (mkNameT functionName) $ do
-    let pats = case apiKind of
-          UI -> []
-          DASHBOARD -> vP "_merchantShortId" : vP "_opCity" : generateParamsPat apiUnits
-    TH.clauseW pats $
-      TH.normalB $
-        TH.doEW $ do
-          case apiKind of
-            UI -> noBindSW $ vE "error" ~* strE "Logic yet to be decided"
-            DASHBOARD -> do
-              whenJust (apiT ^. requestValidation) $ \validationFunc -> do
-                let reqParam = case findRequest apiUnits of
-                      Just paramText -> vE paramText
-                      Nothing -> error $ "Did not found request for validation: " <> T.unpack functionName
-                TH.noBindSW $ vE "Kernel.Utils.Validation.runRequestValidation" ~* vE (T.unpack validationFunc) ~* reqParam
-              noBindSW $ appendE $ vE "error" NE.:| strE "Logic yet to be decided" : generateParamsExp apiUnits -- just for avoid unused vars error
+  delimiterComment $ T.unpack functionName
+  decsW $ do
+    TH.sigDW (mkNameT functionName) $ do
+      TH.forallT [] [] $
+        TH.appendInfixT "->" $ NE.fromList handlerTypes
+    TH.funDW (mkNameT functionName) $ do
+      let pats = case apiKind of
+            UI -> []
+            DASHBOARD -> vP "_merchantShortId" : vP "_opCity" : generateParamsPat apiUnits
+      TH.clauseW pats $
+        TH.normalB $
+          TH.doEW $ do
+            case apiKind of
+              UI -> noBindSW $ vE "error" ~* strE "Logic yet to be decided"
+              DASHBOARD -> do
+                whenJust (apiT ^. requestValidation) $ \validationFunc -> do
+                  let reqParam = case findRequest apiUnits of
+                        Just paramText -> vE paramText
+                        Nothing -> error $ "Did not found request for validation: " <> T.unpack functionName
+                  TH.noBindSW $ vE "Kernel.Utils.Validation.runRequestValidation" ~* vE (T.unpack validationFunc) ~* reqParam
+                noBindSW $ appendE $ vE "error" NE.:| strE "Logic yet to be decided" : generateParamsExp apiUnits -- just for avoid unused vars error
 
 _ShortId :: Q TH.Type
 _ShortId = cT "Kernel.Types.Id.ShortId"

lib/namma-dsl/src/NammaDSL/Lib/Interpreter.hs

@@ -1,7 +1,8 @@
 module NammaDSL.Lib.Interpreter where
 
 import Control.Monad.Writer hiding (Writer)
-import qualified Data.List as L
+import Data.Functor ((<&>))
+-- import qualified Data.List as L
 import qualified Language.Haskell.TH as TH
 import qualified Language.Haskell.TH.Ppr as Ppr
 import qualified Language.Haskell.TH.PprLib as Ppr
@@ -12,36 +13,49 @@ import Prelude
 interpreter :: r -> Writer r CodeUnit -> Maybe String
 interpreter env unitW = do
   let codeUnits = runQ env . execWriterT $ unitW
-  let codeTree = foldMap mkCodeTree codeUnits
-  if codeTree == mempty
+  let codeStringDecs =
+        concat $
+          codeUnits <&> \case
+            CodeDec codeDecs -> interpretDecs codeDecs
+            CodeSplice _ -> mempty
+            CodeComment comment -> interpretComment comment
+  -- splices should be in the end of module
+  let codeStringSplices =
+        concat $
+          codeUnits <&> \case
+            CodeDec _ -> mempty
+            CodeSplice splice -> interpretSplice splice
+            CodeComment _ -> mempty
+  let codeString = codeStringDecs <> codeStringSplices
+  if codeString == mempty
     then Nothing
-    else Just $ interpret codeTree
-
-mkCodeTree :: CodeUnit -> CodeTree
-mkCodeTree (CodeDec codeDecs) = mempty{codeDecs = codeDecs}
--- mkCodeTree (CodeImport codeImport) = mempty{codeImports = [codeImport]}
--- mkCodeTree (CodeExtension codeExtension) = mempty{codeExtensions = [codeExtension]}
-mkCodeTree (CodeSplice codeSplice') = mempty{codeSplices = [codeSplice']}
-
-interpret :: CodeTree -> String
-interpret CodeTree {..} = do
-  -- interpret :: String -> CodeTree -> String
-  -- interpret moduleName CodeTree {..} = do
-  -- L.intercalate "\n" (interpretExtension <$> codeExtensions)
-  --   <> "\n\n"
-  --   <> "module "
-  --   <> moduleName
-  --   <> " where"
-  -- <> "\n\n"
-  -- <> L.intercalate "\n" (interpretImport <$> codeImports)
-  -- <> "\n\n"
-  interpretDecs codeDecs
-    <> "\n\n"
-    <> L.intercalate "\n\n" (interpretSplice <$> codeSplices)
-    <> "\n\n"
+    else Just codeString
+
+-- mkCodeTree :: CodeUnit -> CodeTree
+-- mkCodeTree (CodeDec codeDecs) = mempty{codeDecs = codeDecs}
+-- -- mkCodeTree (CodeImport codeImport) = mempty{codeImports = [codeImport]}
+-- -- mkCodeTree (CodeExtension codeExtension) = mempty{codeExtensions = [codeExtension]}
+-- mkCodeTree (CodeSplice codeSplice') = mempty{codeSplices = [codeSplice']}
+
+-- interpret :: CodeUnit -> String
+-- interpret CodeTree {..} = do
+--   -- interpret :: String -> CodeTree -> String
+--   -- interpret moduleName CodeTree {..} = do
+--   -- L.intercalate "\n" (interpretExtension <$> codeExtensions)
+--   --   <> "\n\n"
+--   --   <> "module "
+--   --   <> moduleName
+--   --   <> " where"
+--   -- <> "\n\n"
+--   -- <> L.intercalate "\n" (interpretImport <$> codeImports)
+--   -- <> "\n\n"
+--   interpretDecs codeDecs
+--     <> "\n\n"
+--     <> L.intercalate "\n\n" (interpretSplice <$> codeSplices)
+--     <> "\n\n"
 
 interpretDecs :: [TH.Dec] -> String
-interpretDecs = pprint'
+interpretDecs = (<> "\n\n") . pprint'
 
 -- interpretImport :: Import -> String
 -- interpretImport (Import m) = "import " <> m
@@ -52,7 +66,11 @@ interpretDecs = pprint'
 -- interpretExtension (Extension e) = "{-# LANGUAGE " <> e <> " #-}"
 
 interpretSplice :: Splice -> String
-interpretSplice (Splice e) = "$(" <> pprint' e <> ")"
+interpretSplice (Splice e) = "$(" <> pprint' e <> ")" <> "\n\n"
+
+interpretComment :: Comment -> String
+interpretComment (Comment str) = "--" <> str <> "\n"
+interpretComment AddNewLine = "\n"
 
 myStyle :: Pretty.Style
 myStyle = Pretty.style {Pretty.lineLength = 300}

lib/namma-dsl/src/NammaDSL/Lib/TH.hs

@@ -425,3 +425,9 @@ matchWOD patQ bodyQ = do
   pat <- patQ
   body <- bodyQ
   pure $ TH.Match pat body []
+
+commentW :: String -> Writer r CodeUnit
+commentW str = tell [CodeComment (Comment str)]
+
+addNewLineW :: Writer r CodeUnit
+addNewLineW = tell [CodeComment AddNewLine]

lib/namma-dsl/src/NammaDSL/Lib/Types.hs

@@ -3,9 +3,9 @@ module NammaDSL.Lib.Types where
 import Control.Monad.Reader
 import Control.Monad.Writer hiding (Writer)
 import Data.Function (flip)
-import Data.Semigroup
+-- import Data.Semigroup
 import qualified Language.Haskell.TH as TH
-import Prelude (Eq)
+import Prelude (Eq, String)
 
 -- In future this monad can include TH.Q or error handling, now these effects are not used
 type Q r = Reader r
@@ -17,40 +17,43 @@ runQ = flip runReader
 
 -- data CodeUnit = CodeDec [TH.Dec] | CodeImport Import | CodeExtension Extension | CodeSplice Splice
 
-data CodeUnit = CodeDec [TH.Dec] | CodeSplice Splice
+data CodeUnit = CodeDec [TH.Dec] | CodeSplice Splice | CodeComment Comment
 
 -- data Import = Import String | ImportQualified String (Maybe String)
 
 -- newtype Extension = Extension String
 
 newtype Splice = Splice TH.Exp deriving (Eq)
 
+-- sometimes extra new line required after comment
+data Comment = Comment String | AddNewLine
+
 type Writer r w = WriterT [w] (Q r) ()
 
 -- we can use CodeTree at once instead of [CodeUnit]
 -- FIXME use existing GeneratorInput
-data CodeTree = CodeTree
-  { -- codeImports :: [Import],
-    codeDecs :: [TH.Dec],
-    codeSplices :: [Splice]
-    --codeExtensions :: [Extension]
-  }
-  deriving (Eq)
-
-instance Monoid CodeTree where
-  mempty =
-    CodeTree
-      { --codeImports = mempty,
-        codeDecs = mempty,
-        codeSplices = mempty
-        --codeExtensions = mempty
-      }
-
-instance Semigroup CodeTree where
-  a <> b =
-    CodeTree
-      { --codeImports = codeImports a <> codeImports b,
-        codeDecs = codeDecs a <> codeDecs b,
-        codeSplices = codeSplices a <> codeSplices b
-        --codeExtensions = codeExtensions a <> codeExtensions b
-      }
+-- data CodeTree = CodeTree
+--   { -- codeImports :: [Import],
+--     codeDecs :: [TH.Dec],
+--     codeSplices :: [Splice]
+--     --codeExtensions :: [Extension]
+--   }
+--   deriving (Eq)
+
+-- instance Monoid CodeTree where
+--   mempty =
+--     CodeTree
+--       { --codeImports = mempty,
+--         codeDecs = mempty,
+--         codeSplices = mempty
+--         --codeExtensions = mempty
+--       }
+
+-- instance Semigroup CodeTree where
+--   a <> b =
+--     CodeTree
+--       { --codeImports = codeImports a <> codeImports b,
+--         codeDecs = codeDecs a <> codeDecs b,
+--         codeSplices = codeSplices a <> codeSplices b
+--         --codeExtensions = codeExtensions a <> codeExtensions b
+--       }