From 7fa24e37435235d3439b139ce40cdeea535b43ea Mon Sep 17 00:00:00 2001 From: ErasedSoul Date: Mon, 12 Aug 2024 11:54:39 +0530 Subject: [PATCH] WIP - Frontend Component Gen --- lib/namma-dsl/namma-dsl.cabal | 4 ++ lib/namma-dsl/src/NammaDSL/App.hs | 27 ++++++++++++ lib/namma-dsl/src/NammaDSL/Config.hs | 14 ++++++ .../src/NammaDSL/DSL/Parser/Frontend/Purs.hs | 44 ++++++++++++++++--- .../src/NammaDSL/DSL/Syntax/Frontend/Purs.hs | 10 ++--- .../src/NammaDSL/Generator/Purs/Common.hs | 26 +++++++++++ .../src/NammaDSL/Generator/Purs/Component.hs | 13 ++++++ 7 files changed, 127 insertions(+), 11 deletions(-) create mode 100644 lib/namma-dsl/src/NammaDSL/Generator/Purs/Common.hs create mode 100644 lib/namma-dsl/src/NammaDSL/Generator/Purs/Component.hs diff --git a/lib/namma-dsl/namma-dsl.cabal b/lib/namma-dsl/namma-dsl.cabal index 976bfa61..7ce96eeb 100644 --- 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 index 2e97e473..56f8e7c7 100644 --- 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 index 78edf4b3..0c3c7b48 100644 --- 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 index b765ca66..92485910 100644 --- 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 index 7dcc49b6..a134e14f 100644 --- 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 new file mode 100644 index 00000000..88f72aa8 --- /dev/null +++ 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 new file mode 100644 index 00000000..a63b21f0 --- /dev/null +++ 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