Something went wrong. Try again.
Define datatypes once, get polyglot results
Something went wrong. Try again.
32 kB · 828 lines
Haskell
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829module DataTypeTool.Parsing.ParserOld where
import qualified Antelude.List as Listimport qualified Antelude.List.NonEmpty as NEimport qualified Antelude.Maybe as Maybeimport Antelude.Monad ( fail , mapM , mapM_ , replicateM_ , void )import qualified Antelude.Monad as Monadimport Antelude.String ( fromString )
import qualified Data.List as UnsafeList ( head )import Data.Map.Strict ( (!) )import qualified Data.Map.Strict as Mapimport qualified Data.Set as Setimport qualified Data.Text as Text
import qualified DataTypeTool.Common.Utils as Comimport DataTypeTool.Config.Config ( LangConfiguration (EmptyConfig) , targets )import qualified DataTypeTool.Config.Config as Configimport qualified DataTypeTool.Parsing.Types as PT
import qualified System.Directory as Dirimport qualified System.Exit as Exit ( die )
import qualified Text.Megaparsec as MPimport qualified Text.Megaparsec.Char as MPCimport qualified Text.Megaparsec.Char.Lexer as MPCLimport qualified Text.Megaparsec.Debug as MPD
type Parser = MP.Parsec Void String
type Spacer = Parser ()
runParsers :: FilePath -> Config.Config -> IO ( List ( FilePath , Either (MP.ParseErrorBundle String Void) PT.DataTypeFile ) )runParsers typeFileDirectory config = let runReal :: List (FilePath, String) -> IO ( List ( FilePath , Either (MP.ParseErrorBundle String Void) PT.DataTypeFile ) ) runReal = List.map ( \(pth, str) -> ( List.stripPrefix typeFileDirectory pth |> Maybe.withDefault pth , ( case List.last str of Just '\n' -> str _ -> str <> "\n" ) |> MP.parse (parser (Config.spacing config)) pth ) ) .> return
runTest :: List (FilePath, String) -> IO ( List ( FilePath , Either (MP.ParseErrorBundle String Void) PT.DataTypeFile ) ) runTest lst = Monad.mapM_ ( \(pth, str) -> MP.parseTest (parser (Config.spacing config)) str ) lst >> return [] in case NE.head config.targets of EmptyConfig -> Exit.die "No targets defined. Please set up languages to generate types for." _ -> Com.recurseDirectory typeFileDirectory -- >>= runTest >>= runReal
parser :: Config.Spacing -> Parser PT.DataTypeFileparser spacing = let spacer :: Parser () spacer = case spacing of Config.Tabs -> tab Config.Spaces2 -> space2 Config.Spaces3 -> space3 Config.Spaces4 -> space4
spacePos :: Int spacePos = case spacing of Config.Tabs -> 4 Config.Spaces2 -> 2 Config.Spaces3 -> 3 Config.Spaces4 -> 4
dataTypeParser :: Parser PT.DataTypes dataTypeParser = MPCL.nonIndented spaceAny ( MP.choice [ MPCL.indentBlock spaceAny <| do voidString "alias " name <- nameParser MPC.space colon return ( MPCL.IndentMany (Just (MP.mkPos <| 1 + spacePos)) (aliasMapper name <. Map.toList <. Map.fromList) aliasParser ) , MPCL.indentBlock spaceAny <| do voidString "enum " name <- nameParser MPC.space colon return ( MPCL.IndentMany (Just (MP.mkPos <| 1 + spacePos)) (enumMapper name <. Map.toList <. Map.fromList) enumParser ) , MPCL.indentBlock spaceAny <| do voidString "model " name <- nameParser MPC.space colon return ( MPCL.IndentMany (Just (MP.mkPos <| 1 + spacePos)) (modelMapper name <. Map.toList <. Map.fromList) modelParser ) , MPCL.indentBlock spaceAny <| do voidString "constant " name <- nameParser MPC.space colon return ( MPCL.IndentMany (Just (MP.mkPos <| 1 + spacePos)) (constantMapper name <. Map.toList <. Map.fromList) constantParser ) ] )
aliasMapper :: Text -> [(String, PT.AliasParams)] -> Parser PT.DataTypes aliasMapper name map = let meta :: Maybe PT.MetaField meta = ( List.lookup "meta" map |> \case Just (PT.AliasMeta m) -> m _ -> Nothing )
type_ :: Maybe PT.Types type_ = ( List.lookup "type" map |> \case Just (PT.AliasType t) -> Just t _ -> Nothing ) in case type_ of Just t -> return <| PT.Alias name meta t _ -> fail "Insufficient parameters passed to alias type"
aliasParser :: Parser (String, PT.AliasParams) aliasParser = MPCL.lexeme spacer <| MP.choice [ MPCL.indentBlock spaceAny <| do voidString "meta:" indentWrapper "meta" (MP.mkPos <| 1 + (spacePos * 2)) (PT.AliasMeta <. metaMapper <. Map.toList <. Map.fromList) metaParser , MPCL.indentBlock spaceAny <| do voidString "type:" indentWrapper "type" (MP.mkPos <| 1 + (spacePos * 2)) (PT.AliasType <. UnsafeList.head) typeParser ]
enumMapper :: Text -> [(String, PT.EnumParams)] -> Parser PT.DataTypes enumMapper name map = let meta :: Maybe PT.MetaField meta = ( List.lookup "meta" map |> \case Just (PT.EnumMeta m) -> m _ -> Nothing )
members :: Maybe [PT.Values] members = ( List.lookup "members" map |> \case Just (PT.EnumMembers e) -> Just e _ -> Nothing ) in case members of Just m -> return <| PT.Enum name meta m _ -> fail "Insufficient parameters passed to enum type"
enumParser :: Parser (String, PT.EnumParams) enumParser = MPCL.lexeme spacer <| MP.choice [ MPCL.indentBlock spaceAny <| do voidString "meta:" indentWrapper "meta" (MP.mkPos <| 1 + (spacePos * 2)) (PT.EnumMeta <. metaMapper <. Map.toList <. Map.fromList) metaParser , MPCL.indentBlock spaceAny <| do voidString "members:" indentWrapper "members" (MP.mkPos <| 1 + (spacePos * 2)) PT.EnumMembers valueParser ]
modelMapper :: Text -> [(String, PT.ModelParams)] -> Parser PT.DataTypes modelMapper name map = let meta :: Maybe PT.MetaField meta = ( List.lookup "meta" map |> \case Just (PT.ModelMeta m) -> m _ -> Nothing )
fields :: Maybe [PT.ModelField] fields = ( List.lookup "fields" map |> \case Just (PT.ModelFields f) -> Just f _ -> Nothing ) in case fields of Just f -> return <| PT.Model name meta f _ -> fail "Insufficient parameters passed to model type"
modelParser :: Parser (String, PT.ModelParams) modelParser = MPCL.lexeme spacer <| MP.choice [ MPCL.indentBlock spaceAny <| do voidString "meta:" indentWrapper "meta" (MP.mkPos <| 1 + (spacePos * 2)) (PT.ModelMeta <. metaMapper <. Map.toList <. Map.fromList) metaParser , MPCL.indentBlock spaceAny <| do voidString "fields:" indentWrapper "fields" (MP.mkPos <| 1 + (spacePos * 2)) PT.ModelFields modelFieldsParser ]
modelFieldsParser :: Parser PT.ModelField modelFieldsParser = MPCL.lexeme spacer <| MPCL.indentBlock spaceAny <| do voidString "field " name <- nameParser MPC.space colon return ( MPCL.IndentMany (Just <| (MP.mkPos <| 1 + (spacePos * 3))) (return <. fieldMapper name) fieldParser )
fieldMapper :: Text -> [PT.Types] -> PT.ModelField fieldMapper name types = PT.ModelField name (UnsafeList.head types)
fieldParser :: Parser PT.Types fieldParser = MPCL.lexeme spacer <| MPCL.indentBlock spaceAny <| do voidString "type:" return ( MPCL.IndentMany (Just <| (MP.mkPos <| 1 + (spacePos * 4))) (return <. UnsafeList.head) typeParser )
constantMapper :: Text -> [(String, PT.ConstantParams)] -> Parser PT.DataTypes constantMapper name map = let meta :: Maybe PT.MetaField meta = ( List.lookup "meta" map |> \case Just (PT.ConstantMeta m) -> m _ -> Nothing )
type_ :: Maybe PT.Types type_ = ( List.lookup "type" map |> \case Just (PT.ConstantType t) -> Just t _ -> Nothing )
value :: Maybe PT.Values value = ( List.lookup "value" map |> \case Just (PT.ConstantValue v) -> Just v _ -> Nothing ) in case (type_, value) of (Just t, Just v) -> return <| PT.Constant name meta t v _ -> fail "Insufficient parameters passed to constant type"
constantParser :: Parser (String, PT.ConstantParams) constantParser = MPCL.lexeme spacer <| MP.choice [ MPCL.indentBlock spaceAny <| do voidString "meta:" indentWrapper "meta" (MP.mkPos <| 1 + (spacePos * 2)) (PT.ConstantMeta <. metaMapper <. Map.toList <. Map.fromList) metaParser , MPCL.indentBlock spaceAny <| do voidString "type:" indentWrapper "type" (MP.mkPos <| 1 + (spacePos * 2)) (PT.ConstantType <. UnsafeList.head) typeParser , MPCL.indentBlock spaceAny <| do voidString "value:" indentWrapper "value" (MP.mkPos <| 1 + (spacePos * 2)) (PT.ConstantValue <. UnsafeList.head) valueParser ]
metaMapper :: [(String, PT.MetaParams)] -> Maybe PT.MetaField metaMapper map = let doc :: Maybe Text doc = ( List.lookup "doc" map |> \case Just (PT.MetaDoc d) -> d _ -> Nothing )
ref :: Maybe [(FilePath, [PT.Types])] ref = ( List.lookup "ref" map |> \case Just (PT.MetaRef r) -> r _ -> Nothing )
lang :: Maybe [Text] lang = ( List.lookup "lang" map |> \case Just (PT.MetaLang l) -> l _ -> Nothing ) in case (doc, ref, lang) of (Nothing, Nothing, Nothing) -> fail "No parameters passed to meta field, but a meta field was opened." _ -> return <| PT.MetaField doc ref lang
metaParser :: Parser (String, PT.MetaParams) metaParser = MPCL.lexeme spacer <| MP.choice [ MPCL.indentBlock spaceAny <| do voidString "doc:" indentWrapper "doc" (MP.mkPos <| 1 + (spacePos * 3)) (PT.MetaDoc <. docMapper) docParser , MPCL.indentBlock spaceAny <| do voidString "ref:" indentWrapper "ref" (MP.mkPos <| 1 + (spacePos * 3)) (PT.MetaRef <. Just) refParser , MPCL.indentBlock spaceAny <| do voidString "lang:" indentWrapper "lang" (MP.mkPos <| 1 + (spacePos * 3)) (PT.MetaLang <. Just) langParser ]
docMapper :: [Text] -> Maybe Text docMapper docLines = Just <| List.foldl (\a b -> a <> Text.pack "\n" <> b) (Text.pack "") docLines
docParser :: Parser Text docParser = MPCL.lexeme spacer <| MP.manyTill MPCL.charLiteral eol >>= return <. Text.pack
refParser :: Parser (FilePath, [PT.Types]) refParser = MPCL.lexeme spacer <| do path <- pathParser colon types_ <- MP.sepBy1 definedTypeParser colon return <| ( path , types_ )
langParser :: Parser Text langParser = langLangParser
langLangParser :: Parser Text langLangParser = MPCL.lexeme spacer <| do lang <- MP.choice [ MPC.string "haskell" , MPC.string "python" , MPC.string "elm" , MPC.string "gleam" ] >>= return <. Text.pack eol return lang
typeParser :: Parser PT.Types typeParser = let type_ :: Parser PT.Types type_ = MP.choice [ PT.DTTStr <$ MPC.string "Str" , PT.DTTInt <$ MPC.string "Int" , PT.DTTFloat <$ MPC.string "Float" , PT.DTTBool <$ MPC.string "Bool" , do voidString "Dict " PT.DTTDict <$> typeParser , do voidString "List " PT.DTTList <$> typeParser , do voidString "Nullable " PT.DTTNullable <$> typeParser , do voidString "Set " PT.DTTSet <$> typeParser , do voidString "Tuple2" PT.DTTPair <$> do MPC.char ' ' typeParser <*> do MPC.char ' ' typeParser , do voidString "Tuple3" PT.DTTTrio <$> do MPC.char ' ' typeParser <*> do MPC.char ' ' typeParser <*> do MPC.char ' ' typeParser , do voidString "Tuple4" PT.DTTQuad <$> do MPC.char ' ' typeParser <*> do MPC.char ' ' typeParser <*> do MPC.char ' ' typeParser <*> do MPC.char ' ' typeParser , do voidString "Tuple5" PT.DTTQuint <$> do MPC.char ' ' typeParser <*> do MPC.char ' ' typeParser <*> do MPC.char ' ' typeParser <*> do MPC.char ' ' typeParser <*> do MPC.char ' ' typeParser , definedTypeParser ] in ( do MPC.char '(' spaceAny t <- type_ spaceAny MPC.char ')' return t ) <|> type_
valueParser :: Parser PT.Values valueParser = let val = MP.choice [ MPC.char '"' >> MP.manyTill MPCL.charLiteral (MPC.char '"') >>= return <. PT.VStr , ( MPCL.signed spaceAny <| MPCL.lexeme spacer <| MPCL.decimal ) >>= return <. PT.VInt , ( MPCL.signed spaceAny <| MPCL.lexeme spacer <| MPCL.float ) >>= return <. PT.VFloat , MP.choice [ PT.VBool True <$ MPC.string "True" , PT.VBool False <$ MPC.string "False" ] , MPCL.lexeme spaceAny <| voidString "Dict" >> spaceAny >> MP.between (MPCL.symbol spaceAny "[") (MPCL.symbol spaceAny "]") ( MP.sepBy ( MP.between (MPCL.symbol spaceAny "{") (MPCL.symbol spaceAny "}") ( do k <- MPC.char '"' >> MP.manyTill MPCL.charLiteral (MPC.char '"') voidString ", " v <- valueParser return (k, v) ) ) (voidString ", ") ) >>= return <. PT.VDict <. Map.fromList , MPCL.lexeme spaceAny <| voidString "List" >> spaceAny >> MP.between (MPCL.symbol spaceAny "[") (MPCL.symbol spaceAny "]") (MP.sepBy valueParser (MPC.char ',')) >>= return <. PT.VList , MP.choice [ do voidString "NotNull " jVal <- valueParser return <| PT.VNullable <| Just jVal , PT.VNullable Nothing <$ voidString "Null" ] , MPCL.lexeme spaceAny <| voidString "Set" >> spaceAny >> MP.between (MPCL.symbol spaceAny "[") (MPCL.symbol spaceAny "]") ( MP.sepBy valueParser (MPC.char ',') >>= return <. PT.VSet <. Set.fromList ) , MPCL.lexeme spaceAny <| voidString "Tuple2" >> spaceAny >> MP.between (MPCL.symbol spaceAny "{") (MPCL.symbol spaceAny "}") ( do a <- valueParser b <- valueParser return (a, b) ) >>= return <. PT.VTuple2 , MPCL.lexeme spaceAny <| voidString "Tuple3" >> spaceAny >> MP.between (MPCL.symbol spaceAny "{") (MPCL.symbol spaceAny "}") ( do a <- valueParser b <- valueParser c <- valueParser return (a, b, c) ) >>= return <. PT.VTuple3 , MPCL.lexeme spaceAny <| voidString "Tuple4" >> spaceAny >> MP.between (MPCL.symbol spaceAny "{") (MPCL.symbol spaceAny "}") ( do a <- valueParser b <- valueParser c <- valueParser d <- valueParser return (a, b, c, d) ) >>= return <. PT.VTuple4 , MPCL.lexeme spaceAny <| voidString "Tuple5" >> spaceAny >> MP.between (MPCL.symbol spaceAny "{") (MPCL.symbol spaceAny "}") ( do a <- valueParser b <- valueParser c <- valueParser d <- valueParser e <- valueParser return (a, b, c, d, e) ) >>= return <. PT.VTuple5 , MPCL.lexeme spaceAny <| nameParser >>= return <. PT.OtherValue ] in MP.between (MPCL.symbol spaceAny "(") (MPCL.symbol spaceAny ")") val <|> val
nameParser :: Parser Text nameParser = MPCL.lexeme spacer <| do first <- MPC.upperChar rest <- MP.many ( MP.choice [ MPC.alphaNumChar , MPC.char '_' ] ) return <| Text.pack (first : rest)
-- A specific packed version of nameParser definedTypeParser :: Parser PT.Types -- Specifically (DefinedDataType Text) definedTypeParser = MPCL.lexeme spacer <| do first <- MPC.upperChar rest <- MP.many ( MP.choice [ MPC.alphaNumChar , MPC.char '_' ] ) return <| PT.DefinedDataType <| Text.pack (first : rest)
pathParser :: Parser FilePath pathParser = MPCL.lexeme spacer <| MP.many ( MP.choice [ MPC.alphaNumChar , MPC.char '_' , MPC.char '-' , MPC.char '/' , MPC.char '\\' ] )
pathAsTextParser :: Parser Text pathAsTextParser = MPCL.lexeme spacer <| MP.many ( MP.choice [ MPC.alphaNumChar , MPC.char '_' , MPC.char '-' , MPC.char '/' , MPC.char '\\' ] ) >>= return <. Text.pack
anyNameParser :: Parser Text anyNameParser = MPCL.lexeme spacer <| do MP.many ( MP.choice [ MPC.alphaNumChar , MPC.char '_' ] ) >>= return <. Text.pack
indentWrapper :: String -> MP.Pos -> ([a] -> c) -> Parser a -> Parser ( MPCL.IndentOpt Parser (String, c) a ) indentWrapper field pos wrapperMapper parser = return ( MPCL.IndentMany (Just pos) ( \a -> return (field, wrapperMapper a) ) parser ) in MP.someTill dataTypeParser MP.eof
lineComment :: Parser ()lineComment = MPCL.skipLineComment "#"
space2 :: Parser ()space2 = MPCL.space (replicateM_ 2 (MPC.char ' ')) lineComment MP.empty
space3 :: Parser ()space3 = MPCL.space (replicateM_ 3 (MPC.char ' ')) lineComment MP.empty
space4 :: Parser ()space4 = MPCL.space (replicateM_ 4 (MPC.char ' ')) lineComment MP.empty
tab :: Parser ()tab = MPCL.space (void <| MPC.char '\t') lineComment MP.empty
spaceAny :: Parser ()spaceAny = MPCL.space MPC.space1 lineComment MP.empty
eol :: Parser ()eol = void MPC.eol
colon :: Parser ()colon = void (MPC.char ':')
voidString :: String -> Parser ()voidString str = void (MPC.string str)
nullParser :: Parser ()nullParser = return ()