WIP - Frontend Component Gen

nammayatri · Aug 12, 2024 · 7fa24e3 · 7fa24e3
1 parent c50d681
commit 7fa24e3
Show file tree

Hide file tree

Showing 7 changed files with 127 additions and 11 deletions.
diff --git a/lib/namma-dsl/namma-dsl.cabal b/lib/namma-dsl/namma-dsl.cabal
@@ -51,6 +51,8 @@ library
       NammaDSL.Generator.Haskell.Servant
       NammaDSL.Generator.Purs
       NammaDSL.Generator.Purs.API
+      NammaDSL.Generator.Purs.Common
+      NammaDSL.Generator.Purs.Component
       NammaDSL.Generator.Purs.CST
       NammaDSL.Generator.Purs.TechDesign
       NammaDSL.Generator.SQL
@@ -175,6 +177,8 @@ test-suite namma-dsl-tests
       NammaDSL.Generator.Haskell.Servant
       NammaDSL.Generator.Purs
       NammaDSL.Generator.Purs.API
+      NammaDSL.Generator.Purs.Common
+      NammaDSL.Generator.Purs.Component
       NammaDSL.Generator.Purs.CST
       NammaDSL.Generator.Purs.TechDesign
       NammaDSL.Generator.SQL

diff --git a/lib/namma-dsl/src/NammaDSL/App.hs b/lib/namma-dsl/src/NammaDSL/App.hs
@@ -14,10 +14,12 @@ import Dhall (inputFile)
 import Dhall.Marshal.Decode (auto)
 import NammaDSL.Config
 import NammaDSL.DSL.Parser.API
+import NammaDSL.DSL.Parser.Frontend.Purs
 import NammaDSL.DSL.Parser.Storage
 import NammaDSL.DSL.Parser.TechDesign (techDesignParser)
 import NammaDSL.DSL.Syntax.API
 import NammaDSL.DSL.Syntax.Common as ReExport
+import NammaDSL.DSL.Syntax.Frontend.Purs
 import NammaDSL.DSL.Syntax.Storage
 import NammaDSL.DSL.Syntax.TechDesign (TechDRead (..))
 import NammaDSL.Generator.Haskell
@@ -99,6 +101,31 @@ runTechDesign configPath yamlPath = do
   tDChanges <- techDesignParser techDesignRead yamlPath
   applyTechDesignChanges tDChanges
 
+runFrontendGenerator :: FilePath -> FilePath -> IO ()
+runFrontendGenerator configPath _yamlPath = do
+  config <- (inputFile auto configPath) :: IO FrontendConfig
+  let frontendPursRead =
+        FrontendPursRead
+          { _fPursDefaultImportMapper = config ^. fDefaultImportMapper,
+            _fPursYamlObject = mempty,
+            _fPursDefaultImports = config ^. fDefaultImports,
+            _fPursComponentModulePrefix = config ^. fComponentModulePrefix,
+            _fPursScreenModulePrefix = config ^. fScreenModulePrefix
+          }
+  pursFrontendDef <- frontendPursParser frontendPursRead _yamlPath
+  let when' = \(t, f) -> when (elem t (config ^. fGenerate)) $ f config pursFrontendDef frontendPursRead
+  mapM_
+    when'
+    [ (PURE_SCRIPT_FRONTEND_COMPONENT, mkPursComponent),
+      (PURE_SCRIPT_FRONTEND_SCREEN, mkPursScreen)
+    ]
+
+mkPursComponent :: FrontendConfig -> PursFrontend -> FrontendPursRead -> IO ()
+mkPursComponent = error "TODO"
+
+mkPursScreen :: FrontendConfig -> PursFrontend -> FrontendPursRead -> IO ()
+mkPursScreen = error "TODO"
+
 getHashObjectAtHEAD :: FilePath -> IO (Maybe String)
 getHashObjectAtHEAD filePath = do
   let gitCommand = "git ls-tree -r HEAD " ++ filePath

diff --git a/lib/namma-dsl/src/NammaDSL/Config.hs b/lib/namma-dsl/src/NammaDSL/Config.hs
@@ -23,6 +23,8 @@ data GenerationType
   | DOMAIN_TYPE
   | SQL
   | PURE_SCRIPT_FRONTEND
+  | PURE_SCRIPT_FRONTEND_COMPONENT
+  | PURE_SCRIPT_FRONTEND_SCREEN
   deriving (Generic, Show, Eq, FromDhall)
 
 data InputPath = InputPath
@@ -103,3 +105,15 @@ data TechDesignConfig = TechDesignConfig
   deriving (Generic, Show, FromDhall)
 
 $(makeLenses ''TechDesignConfig)
+
+data FrontendConfig = FrontendConfig
+  { _fGenRootPath :: FilePath,
+    _fComponentModulePrefix :: FilePath,
+    _fScreenModulePrefix :: FilePath,
+    _fDefaultImportMapper :: [(String, String)],
+    _fDefaultImports :: [String],
+    _fGenerate :: [GenerationType]
+  }
+  deriving (Generic, Show, FromDhall)
+
+$(makeLenses ''FrontendConfig)
diff --git a/lib/namma-dsl/src/NammaDSL/DSL/Parser/Frontend/Purs.hs b/lib/namma-dsl/src/NammaDSL/DSL/Parser/Frontend/Purs.hs
@@ -24,11 +24,11 @@ import Data.Maybe
 import qualified Data.Text as T
 import qualified Data.Yaml as Yaml
 import NammaDSL.AccessorTH
-import NammaDSL.DSL.Parser.TechDesign (getRequiredDeclType)
+import NammaDSL.DSL.Parser.TechDesign (etImp, getRequiredDeclType)
 import NammaDSL.DSL.Syntax.Common
 import NammaDSL.DSL.Syntax.Frontend.Purs
 import NammaDSL.DSL.Syntax.TechDesign
-import NammaDSL.Utils (mkList, toModelList)
+import NammaDSL.Utils (makeTypeQualified, mkList, toModelList)
 import Prelude
 
 frontendPursParser :: FrontendPursRead -> FilePath -> IO PursFrontend
@@ -42,6 +42,7 @@ frontendPursParser frontendPursRead filepath = do
 parsePursFrontend :: FrontendPursM ()
 parsePursFrontend = do
   parseModelList
+  makeComponentsQualified
 
 parseModelList :: FrontendPursM ()
 parseModelList = do
@@ -83,10 +84,41 @@ parseComponent _compName _obj = do
       pCom = Component _compName mkTypeList mkDefaultList [] viewConfigType'
   modify $ \s -> s {_components = _components s ++ [pCom]}
 
-parseComponentRequiredImports :: FrontendPursM ()
-parseComponentRequiredImports = do
-  _dNames <- get
-  error "TODO"
+makeComponentsQualified :: FrontendPursM ()
+makeComponentsQualified = do
+  defaultTypeImportMapper <- asks _fPursDefaultImportMapper
+  yaml <- asks _fPursYamlObject
+  pf <- get
+  let dNames = (pf ^. components) & map _componentName
+      qType = makeTypeQualified defaultTypeImportMapper Nothing Nothing (Just dNames) mempty yaml
+      qualifiedComponents =
+        map
+          ( \comp ->
+              let types = comp ^. componentTypes
+                  qualifiedTypes =
+                    map
+                      ( \tp ->
+                          let fields = tp ^. ptypeFields
+                              qualifiedFields =
+                                map
+                                  ( \field ->
+                                      let fieldType = field ^. pfieldType
+                                       in field & pfieldType .~ qType fieldType
+                                  )
+                                  fields
+                           in tp & ptypeFields .~ qualifiedFields
+                      )
+                      types
+               in comp & componentTypes .~ qualifiedTypes
+          )
+          (pf ^. components)
+  modify $ \s -> s {_components = figureComponentImports <$> qualifiedComponents}
+
+figureComponentImports :: Component -> Component
+figureComponentImports comp = do
+  let potentialImportStrings = map _pfieldType $ (comp ^. componentTypes & concatMap _ptypeFields) <> (comp ^. componentDefauts & concatMap _pdefaultFieldsValue)
+      figuredImports = etImp potentialImportStrings
+  comp & componentImports .~ figuredImports
 
 parseScreen :: String -> Object -> FrontendPursM ()
 parseScreen _screenName _obj = pure () -- TODO
diff --git a/lib/namma-dsl/src/NammaDSL/DSL/Syntax/Frontend/Purs.hs b/lib/namma-dsl/src/NammaDSL/DSL/Syntax/Frontend/Purs.hs
@@ -11,9 +11,7 @@ import Prelude
 
 data Screen = Screen
   {
-  }
-
--- TODO
+  } -- TODO
 
 $(makeLenses ''Screen)
 
@@ -64,13 +62,15 @@ $(makeLenses ''PursFrontend)
 data FrontendPursRead = FrontendPursRead
   { _fPursDefaultImportMapper :: [(String, String)],
     _fPursDefaultImports :: [String],
-    _fPursYamlObject :: Object
+    _fPursYamlObject :: Object,
+    _fPursComponentModulePrefix :: String,
+    _fPursScreenModulePrefix :: String
   }
 
 $(makeLenses ''FrontendPursRead)
 
 instance Default FrontendPursRead where
-  def = FrontendPursRead [] [] mempty
+  def = FrontendPursRead [] [] mempty mempty mempty
 
 type FrontendPursM = ParserM FrontendPursRead PursFrontend
 

diff --git a/lib/namma-dsl/src/NammaDSL/Generator/Purs/Common.hs b/lib/namma-dsl/src/NammaDSL/Generator/Purs/Common.hs
@@ -0,0 +1,26 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# OPTIONS_GHC -Wno-unused-local-binds #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+
+module NammaDSL.Generator.Purs.Common where
+
+import Data.Maybe (fromMaybe)
+import Data.Text (Text, pack)
+import qualified Data.Text as T
+import NammaDSL.DSL.Syntax.Frontend.Purs
+import NammaDSL.DSL.Syntax.TechDesign
+import NammaDSL.Generator.Purs.CST
+import Prelude
+
+class ToChange a where
+  toChange :: a -> [Change]
+
+instance ToChange PursType where
+  toChange (PursType {..}) =
+    [AddRecord _ptypeOf (pack _ptypeName)]
+      ++ map (\(PursField n t) -> AddField (pack _ptypeName) (pack n) (pack t)) _ptypeFields
+
+instance ToChange PursDefaultObj where
+  toChange (PursDefaultObj {..}) =
+    [AddRecord _pdefaultObjType (pack _pdefaultObjName)] -- TODO: Need to add default addition in cst
+      ++ map (\(PursField n t) -> AddField (pack _pdefaultObjName) (pack n) (pack t)) _pdefaultFieldsValue
diff --git a/lib/namma-dsl/src/NammaDSL/Generator/Purs/Component.hs b/lib/namma-dsl/src/NammaDSL/Generator/Purs/Component.hs
@@ -0,0 +1,13 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# OPTIONS_GHC -Wno-unused-local-binds #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+
+module NammaDSL.Generator.Purs.Component where
+
+import Data.Maybe (fromMaybe)
+import Data.Text (Text, pack)
+import qualified Data.Text as T
+import NammaDSL.DSL.Syntax.Frontend.Purs
+import NammaDSL.DSL.Syntax.TechDesign
+import NammaDSL.Generator.Purs.CST
+import Prelude