diff --git a/lib/namma-dsl/namma-dsl.cabal b/lib/namma-dsl/namma-dsl.cabal index 784aa450..7ce96eeb 100644 --- a/lib/namma-dsl/namma-dsl.cabal +++ b/lib/namma-dsl/namma-dsl.cabal @@ -30,10 +30,12 @@ library NammaDSL.App NammaDSL.Config NammaDSL.DSL.Parser.API + NammaDSL.DSL.Parser.Frontend.Purs NammaDSL.DSL.Parser.Storage NammaDSL.DSL.Parser.TechDesign NammaDSL.DSL.Syntax.API NammaDSL.DSL.Syntax.Common + NammaDSL.DSL.Syntax.Frontend.Purs NammaDSL.DSL.Syntax.Storage NammaDSL.DSL.Syntax.TechDesign NammaDSL.Generator.Haskell @@ -49,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 @@ -152,10 +156,12 @@ test-suite namma-dsl-tests NammaDSL.App NammaDSL.Config NammaDSL.DSL.Parser.API + NammaDSL.DSL.Parser.Frontend.Purs NammaDSL.DSL.Parser.Storage NammaDSL.DSL.Parser.TechDesign NammaDSL.DSL.Syntax.API NammaDSL.DSL.Syntax.Common + NammaDSL.DSL.Syntax.Frontend.Purs NammaDSL.DSL.Syntax.Storage NammaDSL.DSL.Syntax.TechDesign NammaDSL.Generator.Haskell @@ -171,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/AccessorTH.hs b/lib/namma-dsl/src/NammaDSL/AccessorTH.hs index a0cb8e09..577da69b 100644 --- a/lib/namma-dsl/src/NammaDSL/AccessorTH.hs +++ b/lib/namma-dsl/src/NammaDSL/AccessorTH.hs @@ -67,5 +67,9 @@ $( makeAccKeysTH extImports moduleMapper tdComments + modelType + defaults + defaultType + viewConfigType |] ) diff --git a/lib/namma-dsl/src/NammaDSL/App.hs b/lib/namma-dsl/src/NammaDSL/App.hs index 2e97e473..d8060f93 100644 --- a/lib/namma-dsl/src/NammaDSL/App.hs +++ b/lib/namma-dsl/src/NammaDSL/App.hs @@ -14,16 +14,19 @@ 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 import NammaDSL.Generator.Haskell.ApiTypes import NammaDSL.Generator.Purs -import NammaDSL.Generator.Purs.TechDesign (applyTechDesignChanges) +import NammaDSL.Generator.Purs.Component +import NammaDSL.Generator.Purs.TechDesign (applyChange, applyTechDesignChanges) import NammaDSL.Generator.SQL import NammaDSL.Utils import System.Directory @@ -99,6 +102,40 @@ 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 config pursfrontend pursRead = do + let allComponentCode = generateAllComponents pursRead config (pursfrontend ^. components) + mapM_ + ( \(ComponentGenCode {..}) -> do + writeToFileIfNotExists componentGenPath (componentGenName <> ".purs") (show reExportModule) + writeToFileIfNotExists componentGenPath ("Controller.purs") (show controllerBaseCode) + writeToFileIfNotExists componentGenPath ("View.purs") (show viewCode) + mapM_ applyChange controllerExtraChanges + ) + allComponentCode + +mkPursScreen :: FrontendConfig -> PursFrontend -> FrontendPursRead -> IO () +mkPursScreen = error "TODO" -- sai moonohar + 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..10bf6a85 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 :: String, + _fScreenModulePrefix :: String, + _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 new file mode 100644 index 00000000..347bd20a --- /dev/null +++ b/lib/namma-dsl/src/NammaDSL/DSL/Parser/Frontend/Purs.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module NammaDSL.DSL.Parser.Frontend.Purs where + +import Control.Lens.Combinators +import Control.Lens.Operators +import Control.Monad.Trans.RWS.Lazy +import Data.Aeson +import Data.Aeson.Lens (key, _Array, _Object, _String, _Value) +import Data.Bifunctor +import qualified Data.ByteString as BS +import Data.Default +import Data.List (find) +import qualified Data.List.Extra as L +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Yaml as Yaml +import NammaDSL.AccessorTH +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 (makeTypeQualified, mkList, toModelList) +import Prelude + +frontendPursParser :: FrontendPursRead -> FilePath -> IO PursFrontend +frontendPursParser frontendPursRead filepath = do + contents <- BS.readFile filepath + case Yaml.decodeEither' contents of + Left _ -> error "Not a Valid Yaml" + Right yml -> do + evalParser parsePursFrontend (frontendPursRead {_fPursYamlObject = yml}) def + +parsePursFrontend :: FrontendPursM () +parsePursFrontend = do + parseModelList + makeComponentsQualified + +parseModelList :: FrontendPursM () +parseModelList = do + yaml <- asks _fPursYamlObject + let modelList = filter ((/= "imports") . fst) $ toModelList yaml + mapM_ + ( \(modelName, model) -> do + let modelType = fromMaybe (error $ "Model type required for purs model " <> modelName) (model ^? ix acc_modelType . _String) + case modelType of + "Component" -> parseComponent modelName model + "Screen" -> parseScreen modelName model + _ -> error $ "Invalid model type for purs model " <> modelName + ) + modelList + +parseComponent :: String -> Object -> FrontendPursM () +parseComponent _compName _obj = do + let typeList = fromMaybe [] $ _obj ^? ix acc_types . _Value . to mkList + mkTypeList = + map + ( \(typeName, typeObj) -> + let fields = mkList typeObj + declType = maybe PTYPE (getRequiredDeclType . T.pack . snd) $ find (("declType" ==) . fst) fields + actualFields = filter (("declType" /=) . fst) fields + in PursType typeName declType (map (\(fieldName, fieldType) -> PursField fieldName fieldType) actualFields) + ) + typeList + defaultList = fromMaybe [] $ _obj ^? ix acc_defaults . _Value . to mkList + mkDefaultList = + map + ( \(defaultName, defaultObj) -> + let fields = mkList defaultObj + defaultType = maybe PTYPE (getRequiredDeclType . T.pack . snd) $ find (("defaultType" ==) . fst) fields + actualFields = filter (("defaultType" /=) . fst) fields + in PursDefaultObj defaultName defaultType (map (\(fieldName, fieldType) -> PursField fieldName fieldType) actualFields) + ) + defaultList + viewConfigType' = _obj ^? ix acc_viewConfigType . _String . to T.unpack + pCom = Component _compName mkTypeList mkDefaultList [] viewConfigType' + modify $ \s -> s {_components = _components s ++ [pCom]} + +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 .~ (L.nub figuredImports) + +parseScreen :: String -> Object -> FrontendPursM () +parseScreen _screenName _obj = pure () -- TODO diff --git a/lib/namma-dsl/src/NammaDSL/DSL/Parser/Storage.hs b/lib/namma-dsl/src/NammaDSL/DSL/Parser/Storage.hs index 26c04b1c..c4524eca 100644 --- a/lib/namma-dsl/src/NammaDSL/DSL/Parser/Storage.hs +++ b/lib/namma-dsl/src/NammaDSL/DSL/Parser/Storage.hs @@ -1190,12 +1190,6 @@ getProperConstraint txt = case L.trim txt of "!SecondaryKey" -> Forced SecondaryKey _ -> error "No a proper contraint type" -toModelList :: Object -> [(String, Object)] -toModelList obj = - KM.toList obj >>= \(k, v) -> case v of - Object o -> [(toString k, o)] - _ -> [] - mkListObject :: Value -> [(String, Object)] mkListObject (Object obj) = KM.toList obj >>= \(k, v) -> case v of diff --git a/lib/namma-dsl/src/NammaDSL/DSL/Syntax/Frontend/Purs.hs b/lib/namma-dsl/src/NammaDSL/DSL/Syntax/Frontend/Purs.hs new file mode 100644 index 00000000..a134e14f --- /dev/null +++ b/lib/namma-dsl/src/NammaDSL/DSL/Syntax/Frontend/Purs.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE TemplateHaskell #-} + +module NammaDSL.DSL.Syntax.Frontend.Purs where + +import Control.Lens +import Data.Aeson +import Data.Default +import NammaDSL.DSL.Syntax.Common +import NammaDSL.DSL.Syntax.TechDesign +import Prelude + +data Screen = Screen + { + } -- TODO + +$(makeLenses ''Screen) + +data PursField = PursField + { _pfieldName :: String, + _pfieldType :: String + } + +$(makeLenses ''PursField) + +data PursDefaultObj = PursDefaultObj + { _pdefaultObjName :: String, + _pdefaultObjType :: PRecordType, + _pdefaultFieldsValue :: [PursField] + } + +$(makeLenses ''PursDefaultObj) + +data PursType = PursType + { _ptypeName :: String, + _ptypeOf :: PRecordType, + _ptypeFields :: [PursField] + } + +$(makeLenses ''PursType) + +data Component = Component + { _componentName :: String, + _componentTypes :: [PursType], + _componentDefauts :: [PursDefaultObj], + _componentImports :: [String], + _viewConfigType :: Maybe String + } + +$(makeLenses ''Component) + +instance Default Component where + def = Component mempty [] [] [] Nothing + +data PursFrontend = PursFrontend + { _extraFileChanges :: [Ann Change], + _components :: [Component], + _screens :: [Screen] + } + +$(makeLenses ''PursFrontend) + +data FrontendPursRead = FrontendPursRead + { _fPursDefaultImportMapper :: [(String, String)], + _fPursDefaultImports :: [String], + _fPursYamlObject :: Object, + _fPursComponentModulePrefix :: String, + _fPursScreenModulePrefix :: String + } + +$(makeLenses ''FrontendPursRead) + +instance Default FrontendPursRead where + def = FrontendPursRead [] [] mempty mempty mempty + +type FrontendPursM = ParserM FrontendPursRead PursFrontend + +instance Default PursFrontend where + def = PursFrontend [] [] [] diff --git a/lib/namma-dsl/src/NammaDSL/Generator/Purs/CST.hs b/lib/namma-dsl/src/NammaDSL/Generator/Purs/CST.hs index 71293835..89b8ffda 100644 --- a/lib/namma-dsl/src/NammaDSL/Generator/Purs/CST.hs +++ b/lib/namma-dsl/src/NammaDSL/Generator/Purs/CST.hs @@ -10,6 +10,7 @@ import Data.Char (isDigit) import Data.Default import qualified Data.List as L import Data.Maybe +import Data.String.Builder (literal) import Data.Text (Text) import qualified Data.Text as T import Data.Text.IO as T @@ -18,7 +19,9 @@ import Language.PureScript.CST.Types import Language.PureScript.Names (ModuleName (..), ProperName (..), runModuleName) import Language.PureScript.PSString (mkString) import qualified Language.PureScript.PSString as PS +import NammaDSL.DSL.Parser.TechDesign (etImp) import NammaDSL.DSL.Syntax.TechDesign as ReExport +import NammaDSL.GeneratorCore (Code (..)) import Prelude doCSTChanges :: FilePath -> [(Module () -> Module ())] -> IO () @@ -30,6 +33,13 @@ doCSTChanges pursFilePath changes = do let newMd = foldl (\acc f -> f acc) md changes T.writeFile pursFilePath (P.printModule newMd) +viewModule :: FilePath -> IO () +viewModule pursFilePath = do + contents <- T.readFile pursFilePath + case snd (P.parse contents) of + Left err -> print err + Right md -> print md + pToken :: Text -> Token pToken txt = TokUpperName [] txt @@ -43,6 +53,9 @@ pName leadingComments trailingComments tok val = nameValue = val } +pNameIdent :: LC -> EC -> Text -> Name Ident +pNameIdent lc ec txt = pName lc ec (pToken txt) (Ident txt) + pSourceToken :: LC -> EC -> Token -> SourceToken pSourceToken leadingComments trailingComments tok = SourceToken @@ -87,12 +100,52 @@ pImport qualifiedName txt = ) } +pSeperated :: forall a. Text -> [a] -> Maybe (Separated a) +pSeperated sepTok items = + let sourceToken = pSourceToken [] [] (TokLowerName [] sepTok) + sepModuleExports = case items of + [] -> Nothing + (x : xs) -> + Just $ + Separated + { sepHead = x, + sepTail = zip (repeat sourceToken) xs + } + in sepModuleExports + +pWrapped :: forall a. Token -> Token -> a -> Wrapped a +pWrapped openTok endTok val = + Wrapped + { wrpOpen = pSourceToken [] [Space 1] openTok, + wrpValue = val, + wrpClose = pSourceToken [Space 1] [] endTok + } + +pExports :: [Text] -> Maybe (DelimitedNonEmpty (Export ())) +pExports exports = (pWrapped TokLeftParen TokRightParen) <$> (pSeperated "," $ map ((ExportValue ()) . (pNameIdent [] [])) exports) + +pModule :: Text -> [Text] -> Module () +pModule moduleName reExports = + Module + { modAnn = (), + modKeyword = pSourceToken [] [Space 1] (TokLowerName [] "module"), + modNamespace = pName [] [Space 1] (TokUpperName [] moduleName) (ModuleName moduleName), + modExports = pExports reExports, + modImports = [], + modDecls = [], + modTrailingComments = [], + modWhere = pSourceToken [Space 1] [] (TokLowerName [] "where\n") + } + addImports :: [PImport] -> Module () -> Module () addImports imports mod' = let oldImportDecls = modImports mod' newImportDecls = foldl (\acc imp -> addImportIfNotPresent imp acc) oldImportDecls imports in mod' {modImports = newImportDecls} +putImports :: [ImportDecl ()] -> Module () -> Module () +putImports imports mod' = mod' {modImports = imports} + addImportIfNotPresent :: PImport -> [ImportDecl ()] -> [ImportDecl ()] addImportIfNotPresent imp@(PImport val typ) _imports = let newImport = case typ of @@ -127,6 +180,41 @@ isDeclSignature = \case DeclSignature _ _ -> True _ -> False +pDeclSignature :: Text -> Text -> Declaration () +pDeclSignature declName typeName = + DeclSignature + () + ( Labeled + { lblLabel = pNameIdent [Line LF, Line LF] [] declName, + lblSep = pSourceToken [Space 1] [] (TokDoubleColon ASCII), + lblValue = pTypeVar () [Space 1] [] typeName + } + ) + +pTypeWithArrow :: Text -> [Text] -> (Text, [ImportDecl ()]) +pTypeWithArrow extra types = + let reqImports = map (\imp -> pImport (Just imp) imp) (T.pack <$> (etImp $ T.unpack <$> types)) + arrowedType = T.intercalate " -> " types + typeExtraWithArrowed = extra <> " " <> arrowedType + in (typeExtraWithArrowed, reqImports) + +pToBeImplementedFunction :: Text -> Text -> Text -> Module () -> Module () +pToBeImplementedFunction declName typeName defaultExpr md = + md + { modDecls = + modDecls md + ++ [ pDeclSignature declName typeName, + DeclValue + () + ( ValueBindingFields + { valName = pNameIdent [Line LF] [] declName, + valBinders = [], + valGuarded = Unconditional (pSourceToken [Space 1] [Space 1] (TokEquals)) (Where {whereExpr = pExprVar [] [] defaultExpr, whereBindings = Nothing}) + } + ) + ] + } + isDeclWithName :: Text -> Declaration a -> Bool isDeclWithName searchName decl = getName decl == searchName @@ -489,3 +577,6 @@ addNewDecl recType recName = in case recType of PNEWTYPE -> DeclNewtype () dh eqTok consName def PTYPE -> DeclType () dh eqTok def + +moduleToCode :: Module () -> Code +moduleToCode md = Code (literal . T.unpack $ P.printModule md) 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..2f47ddec --- /dev/null +++ b/lib/namma-dsl/src/NammaDSL/Generator/Purs/Component.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module NammaDSL.Generator.Purs.Component where + +import Control.Lens ((^.)) +import Control.Lens.Combinators +import Data.Function ((&)) +import Data.Maybe (fromMaybe) +import Data.Text (Text, pack) +import qualified Data.Text as T +import NammaDSL.Config +import NammaDSL.DSL.Syntax.Frontend.Purs +import NammaDSL.DSL.Syntax.TechDesign +import NammaDSL.Generator.Purs.CST +import NammaDSL.Generator.Purs.Common +import NammaDSL.GeneratorCore +import NammaDSL.Lib hiding (Q, Writer) +import qualified NammaDSL.Lib.TH as TH +import qualified NammaDSL.Lib.Types as TH +import System.Directory +import System.FilePath +import Prelude + +data ComponentGenCode = ComponentGenCode + { componentGenName :: String, + componentGenPath :: FilePath, + reExportModule :: Code, + controllerBaseCode :: Code, + controllerExtraChanges :: [Ann Change], + viewCode :: Code + } + deriving (Show, Eq) + +generateAllComponents :: FrontendPursRead -> FrontendConfig -> [Component] -> [ComponentGenCode] +generateAllComponents fpRead fpc comps = map (generateComponent fpRead fpc) comps + +generateComponent :: FrontendPursRead -> FrontendConfig -> Component -> ComponentGenCode +generateComponent fRead fconfig component = + ComponentGenCode + { componentGenName = component ^. componentName, + componentGenPath = componentGenerationPath, + reExportModule = reExportModuleCode, + controllerBaseCode = mempty, + controllerExtraChanges = [], + viewCode = viewCode' + } + where + (viewTypeSig, viewTypeQImps) = + pTypeWithArrow + "forall w." + [ "(" <> T.pack controllerModuleName <> ".Action -> Effect Unit)", + fromMaybe (T.pack $ controllerModuleName <> ".Config") (T.pack <$> component ^. viewConfigType), + "PrestoDOM (Effect Unit) w" + ] + reExportModuleName = (fRead ^. fPursComponentModulePrefix) <> "." <> (component ^. componentName) + viewModuleName = (fRead ^. fPursComponentModulePrefix) <> "." <> (component ^. componentName) <> ".View" + controllerModuleName = (fRead ^. fPursComponentModulePrefix) <> "." <> (component ^. componentName) <> ".Controller" + reExportModuleCode = + moduleToCode $ + (pModule (T.pack reExportModuleName) ["module Reexport"]) + & putImports + [ pImport (Just "Reexport") (T.pack viewModuleName), + pImport (Just "Reexport") (T.pack controllerModuleName) + ] + viewCode' = + moduleToCode $ + (pModule (T.pack viewModuleName) []) + & putImports + ( viewTypeQImps + ++ [ pImport Nothing "Effect (Effect)", + pImport Nothing "Prelude (Unit)", + pImport Nothing "PrestoDOM (PrestoDOM, linearLayout)" + ] + ) + & pToBeImplementedFunction "view" viewTypeSig "linearLayout [] []" + controllerBaseCode = + moduleToCode $ + (pModule (T.pack controllerModuleName) []) + & putImports + ( map ((\imp -> pImport (pure imp) imp) . T.pack) (component ^. componentImports) + ) + componentGenerationPath = (fconfig ^. fGenRootPath) changeModuleToPath (fRead ^. fPursComponentModulePrefix) (component ^. componentName) + +changeModuleToPath :: String -> FilePath +changeModuleToPath = T.unpack . (T.replace "." "/") . T.pack diff --git a/lib/namma-dsl/src/NammaDSL/Utils.hs b/lib/namma-dsl/src/NammaDSL/Utils.hs index 741d9763..fd04256f 100644 --- a/lib/namma-dsl/src/NammaDSL/Utils.hs +++ b/lib/namma-dsl/src/NammaDSL/Utils.hs @@ -197,6 +197,11 @@ instance MakeList Key Value where mkList (Array arr) = (concatMap mkList) $ V.toList arr mkList _ = [] +instance MakeList String Value where + mkList (Object obj) = KM.toList obj >>= \(k, v) -> [(toString k, v)] + mkList (Array arr) = (concatMap mkList) $ V.toList arr + mkList _ = [] + instance MakeList Text Text where mkList (Object obj) = KM.toList obj >>= \(k, v) -> case v of @@ -361,5 +366,12 @@ parseModeConfig = ) LHE.knownExtensions } + errorT :: Text -> c errorT = error . T.unpack + +toModelList :: Object -> [(String, Object)] +toModelList obj = + KM.toList obj >>= \(k, v) -> case v of + Object o -> [(toString k, o)] + _ -> [] diff --git a/lib/namma-dsl/tests/Main.hs b/lib/namma-dsl/tests/Main.hs index 5b9dd681..302c0e8c 100644 --- a/lib/namma-dsl/tests/Main.hs +++ b/lib/namma-dsl/tests/Main.hs @@ -7,6 +7,8 @@ import NammaDSL.App import NammaDSL.DSL.Parser.Storage (SQL_MANIPULATION, sqlCleanedLineParser) import Prelude +--import qualified NammaDSL.Generator.Purs.CST as PCST + --import qualified Data.Text as T storageYamlFilePath :: FilePath @@ -29,4 +31,10 @@ sql :: String -> SQL_MANIPULATION -- Just for quick testing sql = sqlCleanedLineParser main :: IO () -main = pure () -- generateAllExample +main = runFrontendGenerator "./tests/frontend-config.dhall" "./tests/frontend.yaml" + +-- PCST.viewModule "/Users/anirbandas/work/nWork/nnn/nammayatri/Frontend/ui-customer/src/Components/ChooseYourRide/View.purs" +-- runFrontendGenerator "./tests/frontend-config.dhall" "./tests/frontend.yaml" +--runTechDesign "./tests/tech-design-config.dhall" "./tests/tech-design.yaml" + +--pure () -- generateAllExample diff --git a/lib/namma-dsl/tests/frontend-config.dhall b/lib/namma-dsl/tests/frontend-config.dhall new file mode 100644 index 00000000..0b4c2f71 --- /dev/null +++ b/lib/namma-dsl/tests/frontend-config.dhall @@ -0,0 +1,31 @@ +let rootPrefix = + "/Users/anirbandas/work/nWork/namma-dsl/lib/namma-dsl/tests/src-read-only" + +let defaultImportModules = + [ { _1 = "Int", _2 = "Prim" }, { _1 = "Array", _2 = "Prim" } ] + +let defaultImports = [ "Common.Types.Config", "Prim2 as Prim2" ] + +let GeneratorType = + < SERVANT_API + | SERVANT_API_DASHBOARD + | API_TYPES + | DOMAIN_HANDLER + | DOMAIN_HANDLER_DASHBOARD + | BEAM_QUERIES + | CACHED_QUERIES + | BEAM_TABLE + | DOMAIN_TYPE + | SQL + | PURE_SCRIPT_FRONTEND + | PURE_SCRIPT_FRONTEND_COMPONENT + | PURE_SCRIPT_FRONTEND_SCREEN + > + +in { _fGenRootPath = rootPrefix + , _fComponentModulePrefix = "Front.Components" + , _fScreenModulePrefix = "Front.Screens" + , _fDefaultImportMapper = defaultImportModules + , _fDefaultImports = defaultImports + , _fGenerate = [ GeneratorType.PURE_SCRIPT_FRONTEND_COMPONENT ] + } diff --git a/lib/namma-dsl/tests/frontend.yaml b/lib/namma-dsl/tests/frontend.yaml new file mode 100644 index 00000000..3f5f2fea --- /dev/null +++ b/lib/namma-dsl/tests/frontend.yaml @@ -0,0 +1,11 @@ +imports: + String: Prim + +ChooseYourRide: + modelType: Component + types: + Car: + make: String + model: String + year: Int + color: String \ No newline at end of file diff --git a/lib/namma-dsl/tests/pursfrontend.yaml b/lib/namma-dsl/tests/pursfrontend.yaml new file mode 100644 index 00000000..8951eb47 --- /dev/null +++ b/lib/namma-dsl/tests/pursfrontend.yaml @@ -0,0 +1,55 @@ +# in dhall +# default import mapper for purs frontend + + +purs + + +# similar to backend dsl imports just for frontend +imports: + .. + +: + modelType: < component | screen > + types: + : + : + : + : + : + + : + : + : + + defaults: + : + defaultType: + : + : + + viewPassedConfigType: + +: + modelType: component + types: + : + : + : + : + : + : + : + viewPassedConfigType: + +: + modelType: screen + types: + : + : + : + : + : + : + # Screens might have specific informations + # will figure them out