From 0e9255ef8b017ef94464f18e262ddef3ec890c59 Mon Sep 17 00:00:00 2001 From: ErasedSoul Date: Sun, 23 Jun 2024 05:41:31 +0530 Subject: [PATCH] Extraction implementation --- lib/namma-dsl/namma-dsl.cabal | 10 ++ lib/namma-dsl/package.yaml | 4 + lib/namma-dsl/src/NammaDSL/Lib/Extractor.hs | 112 ++++++++++++++++++++ lib/namma-dsl/tests/Main.hs | 17 ++- 4 files changed, 142 insertions(+), 1 deletion(-) create mode 100644 lib/namma-dsl/src/NammaDSL/Lib/Extractor.hs diff --git a/lib/namma-dsl/namma-dsl.cabal b/lib/namma-dsl/namma-dsl.cabal index b6fdeeef..8d114e6c 100644 --- a/lib/namma-dsl/namma-dsl.cabal +++ b/lib/namma-dsl/namma-dsl.cabal @@ -49,6 +49,7 @@ library NammaDSL.Generator.SQL.Table NammaDSL.GeneratorCore NammaDSL.Lib + NammaDSL.Lib.Extractor NammaDSL.Lib.Interpreter NammaDSL.Lib.TH NammaDSL.Lib.Types @@ -104,7 +105,11 @@ library , extra , filepath , flatparse + , ghc + , ghc-paths + , haskell-src-exts , haskell-src-meta + , interpolate , lens , lens-aeson , mtl @@ -161,6 +166,7 @@ test-suite namma-dsl-tests NammaDSL.Generator.SQL.Table NammaDSL.GeneratorCore NammaDSL.Lib + NammaDSL.Lib.Extractor NammaDSL.Lib.Interpreter NammaDSL.Lib.TH NammaDSL.Lib.Types @@ -216,7 +222,11 @@ test-suite namma-dsl-tests , extra , filepath , flatparse + , ghc + , ghc-paths + , haskell-src-exts , haskell-src-meta + , interpolate , lens , lens-aeson , mtl diff --git a/lib/namma-dsl/package.yaml b/lib/namma-dsl/package.yaml index 835d9f93..5122fabf 100644 --- a/lib/namma-dsl/package.yaml +++ b/lib/namma-dsl/package.yaml @@ -92,6 +92,10 @@ dependencies: - pretty - haskell-src-meta - regex-compat + - ghc + - ghc-paths + - haskell-src-exts + - interpolate ghc-options: - -Wall diff --git a/lib/namma-dsl/src/NammaDSL/Lib/Extractor.hs b/lib/namma-dsl/src/NammaDSL/Lib/Extractor.hs new file mode 100644 index 00000000..de2c5222 --- /dev/null +++ b/lib/namma-dsl/src/NammaDSL/Lib/Extractor.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE QuasiQuotes #-} + +module NammaDSL.Lib.Extractor where + +import Control.Monad.Extra (fromMaybeM) +import Control.Monad.State +import Data.Aeson +import Data.Bool (bool) +import Data.List (find, intercalate) +import Data.List.Split (wordsBy) +import Data.Maybe (catMaybes, fromMaybe) +import Data.String.Interpolate (i) +import GHC.Driver.Monad +import Language.Haskell.Exts +import Safe (headMay) +import System.Directory +import Prelude + +data EXT_TO = EXT_TO EXT_RT DataName [(FieldName, FieldType)] deriving (Show, Eq, Ord) + +data EXT_RT = EXT_NT | EXT_D | EXT_T deriving (Show, Eq, Ord) + +type ModName = String + +type DataName = String + +type FieldName = String + +type FieldType = String + +data CondLStyle = ENUM | RECORD deriving (Show, Eq, Ord) + +-- lets not worry about InfixConDecl for now + +data AnalysisState = AnalysisState + { rootPathPrefix :: [FilePath], + extImports :: Object, + haskellImports :: Object, + remaining :: [FieldType], + result :: [EXT_TO] + } + deriving (Show, Eq, Ord) + +type AnalysisM a = StateT AnalysisState IO a + +getModuleFilePath :: FilePath -> ModName -> AnalysisM (Maybe FilePath) +getModuleFilePath rootPath moduleName = do + let partialModulePath = intercalate "/" (wordsBy (== '.') moduleName) + expectedAbsFilePath = rootPath <> "/" <> partialModulePath <> ".hs" + fileExists <- liftIO $ doesFileExist expectedAbsFilePath + pure $ bool Nothing (Just expectedAbsFilePath) fileExists + +deepAnalysis :: ModName -> DataName -> AnalysisM [EXT_TO] +deepAnalysis moduleName dName = do + rootPaths <- gets rootPathPrefix + correctFilePath <- fromMaybeM (error $ "No Filepath found for module: " <> moduleName) $ (headMay . catMaybes) <$> mapM (flip getModuleFilePath moduleName) rootPaths + parsedHaskellFile <- liftIO $ parseFile correctFilePath + let decs = case parsedHaskellFile of + ParseOk (Module _ _ _ _ decl_) -> decl_ + _ -> error $ "Error parsing hs file of module: " <> moduleName + rawEXT_TO = fromMaybe (error [i|Unable to find data type: #{dName} in module #{moduleName}|]) $ findEXT_TO dName decs + liftIO $ print rawEXT_TO + -- TODO -- + pure [] + +findEXT_TO :: DataName -> [Decl SrcSpanInfo] -> Maybe EXT_TO +findEXT_TO dName decls = + find isTargetDataDecl decls >>= \case + -- TODO: Check the other possible types. I dont think we need Gadts for now .. might required later. + TypeDecl _ declHead tp -> do + let pTp = prettyPrint tp + pure $ EXT_TO EXT_T (declHeadToString declHead) [("enum", pTp)] + DataDecl _ dataOrNew _ declHead constructors _ -> + pure $ EXT_TO (dataOrNewToRecordType dataOrNew) (declHeadToString declHead) (extractCondlInfos constructors) + _ -> Nothing + where + isTargetDataDecl :: Decl SrcSpanInfo -> Bool + isTargetDataDecl = \case + (DataDecl _ _ _ (DHead _ dclName) _ _) -> nameToString dclName == dName + (TypeDecl _ (DHead _ tclName) _) -> nameToString tclName == dName + _ -> False + + nameToString :: Name l -> String + nameToString = \case + Ident _ s -> s + Symbol _ s -> s + + dataOrNewToRecordType :: DataOrNew l -> EXT_RT + dataOrNewToRecordType = \case + DataType _ -> EXT_D + NewType _ -> EXT_NT + + declHeadToString :: DeclHead SrcSpanInfo -> String + declHeadToString = \case + DHead _ dhName -> nameToString dhName + DHInfix _ _ dhiName -> nameToString dhiName + DHParen _ declHead -> declHeadToString declHead + DHApp _ declHead _ -> declHeadToString declHead + + extractCondlInfos :: [QualConDecl l] -> [(FieldName, FieldType)] + extractCondlInfos qCondDecs + | all isEnumStyleConDecl qCondDecs = [("enum", (intercalate ",") $ map prettyPrint qCondDecs)] + | [(QualConDecl _ _ _ (RecDecl _ _ fields))] <- qCondDecs = map extractField fields + | otherwise = [] -- TODO: Its not the right way to handle this case. + extractField :: FieldDecl l -> (FieldName, FieldType) -- TODO: Later check for _, might not be required but some corner cases might break + extractField (FieldDecl _ names tp) = (intercalate "_" (map nameToString names), prettyPrint tp) + + isEnumStyleConDecl :: QualConDecl l -> Bool + isEnumStyleConDecl (QualConDecl _ _ _ conDecl) = case conDecl of + ConDecl _ _ _ -> True + RecDecl _ _ _ -> False + InfixConDecl _ _ _ _ -> False diff --git a/lib/namma-dsl/tests/Main.hs b/lib/namma-dsl/tests/Main.hs index 6f179b46..d32e0350 100644 --- a/lib/namma-dsl/tests/Main.hs +++ b/lib/namma-dsl/tests/Main.hs @@ -3,8 +3,10 @@ module Main where +import Control.Monad.State import NammaDSL.App import NammaDSL.DSL.Parser.Storage (SQL_MANIPULATION, sqlCleanedLineParser) +import NammaDSL.Lib.Extractor import Prelude storageYamlFilePath :: FilePath @@ -18,7 +20,20 @@ generateAllExample = do runStorageGenerator "./tests/dsl-config.dhall" storageYamlFilePath runApiGenerator "./tests/dsl-config.dhall" apiYamlFilePath -sql :: String -> SQL_MANIPULATION -- Just for quick testing +runningTheAnalysis :: IO () +runningTheAnalysis = do + let initialState = + AnalysisState + { rootPathPrefix = ["/Users/anirbandas/work/nWork/namma-dsl/lib/namma-dsl/src2", "/Users/anirbandas/work/nWork/namma-dsl/lib/namma-dsl/src"], + extImports = mempty, + haskellImports = mempty, + remaining = ["NammaDSL.Lib.Types.CodeTree"], + result = [] + } + rr <- evalStateT (deepAnalysis "NammaDSL.DSL.Syntax.Storage" "FieldDef") initialState + print rr + +sql :: String -> SQL_MANIPULATION sql = sqlCleanedLineParser main :: IO ()