Merge branch 'master' into we-can’t-have-nice-things

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

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)
 

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

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)

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)

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..=)
   ]

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 }
+
 }