diff --git a/semantic-ast/src/Main.hs b/semantic-ast/src/Main.hs index dad56930f..8b53be1b3 100644 --- a/semantic-ast/src/Main.hs +++ b/semantic-ast/src/Main.hs @@ -3,8 +3,8 @@ module Main (main) where import System.Environment import TreeSitter.Unmarshal -import TreeSitter.Python.AST -import TreeSitter.Python +import qualified TreeSitter.Python.AST as AST +import qualified TreeSitter.Python as Python import Source.Range import Source.Span import Data.ByteString.Char8 @@ -12,42 +12,53 @@ import Data.ByteString (pack, readFile, ByteString) import System.IO (FilePath) import Options.Applicative hiding (style) import Data.Semigroup ((<>)) -import Text.Pretty.Simple (pPrint) +import Text.Pretty.Simple (pPrint, pPrintNoColor) +import Data.Foldable (traverse_) +import Control.Monad ((>=>)) data SemanticAST = SemanticAST { format :: Format - , source :: Either FilePath Prelude.String + , noColor :: Bool + , source :: Either [FilePath] String } +-- Usage: semantic-ast --format ARG [--no-color] (--sourceString STRING | FILEPATHS…) parseAST :: Parser SemanticAST parseAST = SemanticAST <$> option auto ( long "format" <> help "Specify desired output: show, json, sexpression" ) - <*> (Left <$> strOption - ( long "sourceFile" - <> metavar "FILEPATH" - <> help "Specify filepath containing source code to parse" ) + <*> switch + ( long "no-color" + <> help "Print with color: --color" + ) + <*> (Left <$> some + (Options.Applicative.argument str (metavar "FILEPATH(S)")) <|> Right <$> strOption ( long "sourceString" <> metavar "STRING" <> help "Specify source input to parse" )) + main :: IO () main = generateAST =<< execParser opts + generateAST :: SemanticAST -> IO () -generateAST (SemanticAST format source) = do - bytestring <- case source of - Left filePath -> do - Data.ByteString.readFile filePath - Right source -> do - pure $ Data.ByteString.Char8.pack source - ast <- parseByteString @TreeSitter.Python.AST.Module @(Range, Span) tree_sitter_python bytestring - case format of - Show -> print ast - Pretty -> pPrint ast +generateAST (SemanticAST format noColor source) = + getByteStrings >>= traverse_ go + where getByteStrings = case source of + Left filePaths -> traverse Data.ByteString.readFile filePaths + Right source -> pure [Data.ByteString.Char8.pack source] + go = ast >=> display + ast = parseByteString @AST.Module @(Range, Span) Python.tree_sitter_python + display = case format of + Show -> print + Pretty | noColor -> pPrintNoColor + | otherwise -> pPrint + +-- need AST in scope for case format and .. opts :: ParserInfo SemanticAST opts = info (parseAST <**> helper) @@ -56,5 +67,8 @@ opts = info (parseAST <**> helper) <> header "semantic-ast is a package used to parse source code" ) -- TODO: Define formats for json, sexpression, etc. -data Format = Show | Pretty +data Format = Show + | Pretty deriving (Read) + +-- bool field would break Read diff --git a/semantic-core/src/Core/Core.hs b/semantic-core/src/Core/Core.hs index 481a11b7b..84b475da3 100644 --- a/semantic-core/src/Core/Core.hs +++ b/semantic-core/src/Core/Core.hs @@ -26,6 +26,7 @@ module Core.Core , load , record , (...) +, (.?) , (.=) , Ann(..) , ann @@ -75,6 +76,8 @@ data Core f a | Record [(Name, f a)] -- | Projection from a record. | f a :. Name + -- | Projection of a record, with failure. + | f a :? Name -- | Assignment of a value to the reference returned by the lhs. | f a := f a deriving (Foldable, Functor, Generic1, Traversable) @@ -105,6 +108,7 @@ instance RightModule Core where Load b >>=* f = Load (b >>= f) Record fs >>=* f = Record (map (fmap (>>= f)) fs) (a :. b) >>=* f = (a >>= f) :. b + (a :? b) >>=* f = (a >>= f) :. b (a := b) >>=* f = (a >>= f) := (b >>= f) @@ -209,6 +213,11 @@ a ... b = send (a :. b) infixl 9 ... +(.?) :: (Carrier sig m, Member Core sig) => m a -> Name -> m a +a .? b = send (a :? b) + +infixl 9 .? + (.=) :: (Carrier sig m, Member Core sig) => m a -> m a -> m a a .= b = send (a := b) diff --git a/semantic-core/src/Core/Eval.hs b/semantic-core/src/Core/Eval.hs index 01ac38d0f..f7c23b5d7 100644 --- a/semantic-core/src/Core/Eval.hs +++ b/semantic-core/src/Core/Eval.hs @@ -20,7 +20,7 @@ import Control.Monad ((>=>)) import Core.Core as Core import Core.Name import Data.Functor -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) import GHC.Stack import Prelude hiding (fail) import Source.Span @@ -68,6 +68,11 @@ eval Analysis{..} eval = \case a :. b -> do a' <- ref a a' ... b >>= maybe (freeVariable (show b)) (deref' b) + a :? b -> do + a' <- ref a + mFound <- a' ... b + bool (isJust mFound) + a := b -> do b' <- eval b addr <- ref a diff --git a/semantic-core/src/Core/Parser.hs b/semantic-core/src/Core/Parser.hs index 34e417364..412dab5de 100644 --- a/semantic-core/src/Core/Parser.hs +++ b/semantic-core/src/Core/Parser.hs @@ -1,29 +1,39 @@ -{-# LANGUAGE FlexibleContexts, TypeOperators #-} +{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, TypeOperators #-} module Core.Parser ( core , lit , expr , record , comp - , lvalue ) where -- Consult @doc/grammar.md@ for an EBNF grammar. import Control.Applicative import Control.Effect.Carrier +import Control.Monad import Core.Core ((:<-) (..), Core) import qualified Core.Core as Core import Core.Name import qualified Data.Char as Char import Data.Foldable (foldl') +import Data.Function import Data.String +import Text.Parser.LookAhead (LookAheadParsing) import qualified Text.Parser.Token as Token import qualified Text.Parser.Token.Highlight as Highlight +import qualified Text.Parser.Token.Style as Style import Text.Trifecta hiding (ident) -- * Identifier styles and derived parsers +newtype CoreParser m a = CoreParser { runCoreParser :: m a } + deriving (Alternative, Applicative, CharParsing, DeltaParsing, Errable, Functor, LookAheadParsing, Monad, MonadPlus, Parsing) + +instance TokenParsing m => TokenParsing (CoreParser m) where + someSpace = Style.buildSomeSpaceParser (void (satisfy Char.isSpace)) comments + where comments = Style.CommentStyle "" "" "//" False + validIdentifierStart :: Char -> Bool validIdentifierStart c = not (Char.isDigit c) && isSimpleCharacter c @@ -48,7 +58,7 @@ identifier = choice [quote, plain] "identifier" where -- * Parsers (corresponding to EBNF) core :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) -core = expr +core = runCoreParser expr expr :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) expr = ifthenelse <|> lambda <|> rec <|> load <|> assign @@ -61,7 +71,9 @@ application :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t application = projection `chainl1` (pure (Core.$$)) projection :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) -projection = foldl' (Core....) <$> atom <*> many (namedValue <$ dot <*> name) +projection = foldl' (&) <$> atom <*> many (choice [ flip (Core..?) <$ symbol ".?" <*> identifier + , flip (Core....) <$ dot <*> identifier + ]) atom :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) atom = choice @@ -93,13 +105,6 @@ rec = Core.rec <$ reserved "rec" <*> name <* symbolic '=' <*> expr "recursiv load :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) load = Core.load <$ reserved "load" <*> expr -lvalue :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) -lvalue = choice - [ projection - , ident - , parens expr - ] - -- * Literals name :: (TokenParsing m, Monad m) => m (Named Name) diff --git a/semantic-core/src/Core/Pretty.hs b/semantic-core/src/Core/Pretty.hs index 808f02f69..5babed821 100644 --- a/semantic-core/src/Core/Pretty.hs +++ b/semantic-core/src/Core/Pretty.hs @@ -74,6 +74,7 @@ prettyCore style = unPrec . go . fmap name Load p -> prec 3 (keyword "load" <+> withPrec 9 (go p)) item :. body -> prec 9 (withPrec 9 (go item) <> symbol "." <> name body) + item :? body -> prec 9 (withPrec 9 (go item) <> symbol ".?" <> name body) lhs := rhs -> prec 3 . group . nest 2 $ vsep [ withPrec 4 (go lhs) diff --git a/semantic-core/test/Generators.hs b/semantic-core/test/Generators.hs index 01cfd6feb..d96a82cdf 100644 --- a/semantic-core/test/Generators.hs +++ b/semantic-core/test/Generators.hs @@ -70,5 +70,6 @@ expr = Gen.recursive Gen.choice atoms , Gen.subterm expr Core.load , record expr , Gen.subtermM expr (\ x -> (x Core....) . namedValue <$> name) + , Gen.subtermM expr (\ x -> (x Core..?) . namedValue <$> name) , Gen.subterm2 expr expr (Core..=) ] diff --git a/semantic-python/src/Prelude.score b/semantic-python/src/Prelude.score index d8b4b94f8..8a158a7b0 100644 --- a/semantic-python/src/Prelude.score +++ b/semantic-python/src/Prelude.score @@ -1,8 +1,12 @@ { - type <- \name -> \bases -> \dict -> - #record { __name: name, __bases: bases, __dict: dict }; + type <- \name -> \super -> \slots -> + #record { __name: name, __super: super, __slots: slots }; object <- type "object" #unit #record{}; - #record { type: type, object: object } + getitem <- rec getitem = \item -> \attr -> + if item.slots.?attr then item.slots.attr else #unit; + + #record { type: type, object: object, getitem: getitem } + }