Merge pull request github#675 from github/great-exportations

Track exports in exception tracing modules

Author: robrix

semantic-analysis/.gitignore

@@ -1,2 +1,2 @@
-test.json
-test.py
+*.json
+*.py

semantic-analysis/python.tsg

@@ -93,6 +93,15 @@
   attr (@this.node -> @else.node) type = "alternative"
 }
 
+(function_definition name: (_) @name body: (_) @body) @this
+{
+  node @this.node
+  attr (@this.node) type = "function"
+  attr (@this.node) name = (source-text @name)
+  edge @this.node -> @body.node
+  attr (@this.node -> @body.node) type = "body"
+}
+
 (module (_) @child) @this
 {
   edge @this.node -> @child.node

semantic-analysis/src/Analysis/Analysis/Concrete.hs

@@ -28,17 +28,15 @@ import           Control.Algebra
 import           Control.Carrier.Fresh.Strict
 import           Control.Carrier.Reader hiding (Local)
 import           Control.Effect.Labelled
-import           Control.Monad.Trans.Class (MonadTrans(..))
+import           Control.Monad.Trans.Class (MonadTrans (..))
 import           Data.Foldable (foldl')
 import           Data.Function (fix, on)
-import           Data.Semigroup (Last(..))
+import           Data.Semigroup (Last (..))
 import           Data.Text as Text (Text)
 import           Prelude hiding (fail)
-import           Source.Span
-import qualified System.Path as Path
 
 data Concrete
-  = Closure Path.AbsRelFile Span (Named (Concrete -> Concrete))
+  = Closure Reference [Name] ([Concrete] -> Concrete)
   | Unit
   | Bool Bool
   | Int Int
@@ -62,14 +60,14 @@ instance Show Concrete where
   showsPrec p = showsPrec p . quote
 
 
-newtype Elim a = EApp a
+newtype Elim a = EApp [a]
   deriving (Eq, Foldable, Functor, Ord, Show, Traversable)
 
 vvar :: Name -> Concrete
 vvar n = Neutral n Nil
 
 velim :: Concrete -> Elim Concrete -> Concrete
-velim (Closure _ _ f) (EApp a) = namedValue f a
+velim (Closure _ _ f) (EApp a) = f a
 velim (Neutral h as)  a        = Neutral h (as :> a)
 velim _               _        = error "velim: cannot eliminate" -- FIXME: fail in the monad instead
 
@@ -84,7 +82,7 @@ vsubst n v = go
       | otherwise -> Neutral n'     as'
       where
       as' = fmap go <$> as
-    Closure p s b -> Closure p s ((go .) <$> b) -- NB: Shadowing can’t happen because n' can’t occur inside b
+    Closure r n b -> Closure r n (go . b) -- NB: Shadowing can’t happen because n' can’t occur inside b
     Unit          -> Unit
     Bool b        -> Bool b
     Int i         -> Int i
@@ -93,24 +91,24 @@ vsubst n v = go
 
 data FO
   = FOVar Name
-  | FOClosure Path.AbsRelFile Span (Named FO)
+  | FOClosure Reference [Name] FO
   | FOUnit
   | FOBool Bool
   | FOInt Int
   | FOString Text
-  | FOApp FO FO
+  | FOApp FO [FO]
   deriving (Eq, Ord, Show)
 
 
 quote :: Concrete -> FO
 quote = \case
 -- FIXME: should quote take a Level incremented under binders?
-  Closure path span body -> FOClosure path span ((\ f -> quote (f (vvar (namedName body)))) <$> body)
-  Unit                   -> FOUnit
-  Bool b                 -> FOBool b
-  Int i                  -> FOInt i
-  String s               -> FOString s
-  Neutral n sp           -> foldl' (\ f (EApp a) -> FOApp f (quote a)) (FOVar n) sp
+  Closure r n body -> FOClosure r n (quote (body (map vvar n)))
+  Unit             -> FOUnit
+  Bool b           -> FOBool b
+  Int i            -> FOInt i
+  String s         -> FOString s
+  Neutral n sp     -> foldl' (\ f (EApp a) -> FOApp f (map quote a)) (FOVar n) sp
 
 
 type Eval term m value = (term -> m value) -> (term -> m value)
@@ -160,9 +158,10 @@ instance ( Has (A.Env A.PAddr) sig m
   alg hdl sig ctx = case sig of
     L (DVar n)    -> pure (vvar n <$ ctx)
     L (DAbs n b)  -> do
-      b' <- hdl (b (vvar n) <$ ctx)
+      b' <- hdl (b (map vvar n) <$ ctx)
       ref <- ask
-      pure $ Closure (refPath ref) (refSpan ref) . named n . flip (vsubst n) <$> b'
+      let closure body = Closure ref n (\ args -> let substs = zipWith vsubst n args in foldl' (.) id substs body)
+      pure $ closure <$> b'
     L (DApp f a)  -> pure $ velim f (EApp a) <$ ctx
     L (DInt i)    -> pure (Int i <$ ctx)
     L DUnit       -> pure (Unit <$ ctx)

semantic-analysis/src/Analysis/Analysis/Exception.hs

@@ -14,6 +14,7 @@ module Analysis.Analysis.Exception
 , fromExceptions
 , var
 , exc
+, subst
   -- * Exception tracing analysis
 , ExcC(..)
 ) where
@@ -33,6 +34,7 @@ import           Control.Effect.Labelled
 import           Control.Effect.State
 import qualified Data.Foldable as Foldable
 import           Data.Function (fix)
+import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.Text as Text
 
@@ -61,6 +63,9 @@ var v = ExcSet (Set.singleton v) mempty
 exc :: Exception -> ExcSet
 exc e = ExcSet mempty (Set.singleton e)
 
+subst  :: Name -> ExcSet -> ExcSet -> ExcSet
+subst name (ExcSet fvs' es') (ExcSet fvs es) = ExcSet (Set.delete name fvs <> fvs') (es <> es')
+
 
 exceptionTracing
   :: Ord term
@@ -87,9 +92,11 @@ runFile eval = traverse run where
     . A.runEnv @ExcSet
     . convergeTerm (A.runStore @ExcSet . runExcC . fix (cacheTerm . eval))
   result msgs sets = do
+    exports <- gets @(A.MStore ExcSet) (fmap Foldable.fold . Map.mapKeys A.getMAddr . A.getMStore)
     let set = Foldable.fold sets
-        imports = Set.fromList (map (\ (A.Import components) -> name (Text.intercalate (Text.pack ".") (Foldable.toList components))) msgs)
-    pure (Module (const set) imports mempty (freeVariables set))
+        imports = Set.fromList (map extractImport msgs)
+    pure (Module (Foldable.foldl' (flip (uncurry subst)) set . Map.toList) imports exports (freeVariables set))
+  extractImport (A.Import components) = name (Text.intercalate (Text.pack ".") (Foldable.toList components))
 
 newtype ExcC m a = ExcC { runExcC :: m a }
   deriving (Alternative, Applicative, Functor, Monad)
@@ -99,7 +106,7 @@ instance (Algebra sig m, Alternative m) => Algebra (Dom ExcSet :+: sig) (ExcC m)
     L dom   -> case dom of
       DVar n    -> pure $ var n <$ ctx
       DAbs _ b  -> runExcC (hdl (b mempty <$ ctx))
-      DApp f a  -> pure $ f <> a <$ ctx
+      DApp f a  -> pure $ f <> Foldable.fold a <$ ctx
       DInt _    -> pure nil
       DUnit     -> pure nil
       DBool _   -> pure nil

semantic-analysis/src/Analysis/Analysis/Typecheck.hs

@@ -30,19 +30,19 @@ import           Analysis.FlowInsensitive
 import           Analysis.Functor.Named
 import           Analysis.Reference
 import           Control.Algebra
-import           Control.Applicative (Alternative(..))
+import           Control.Applicative (Alternative (..))
 import           Control.Carrier.Fresh.Strict as Fresh
 import           Control.Carrier.Reader hiding (Local)
 import           Control.Carrier.State.Strict
 import           Control.Effect.Labelled
 import           Control.Monad (ap, guard, unless)
 import           Control.Monad.Trans.Class
-import           Data.Foldable (for_)
+import           Data.Foldable (for_, sequenceA_)
 import           Data.Function (fix)
 import qualified Data.IntMap as IM
 import qualified Data.IntSet as IS
 import           Data.Maybe (fromJust, fromMaybe)
-import           Data.Semigroup (Last(..))
+import           Data.Semigroup (Last (..))
 import qualified Data.Set as Set
 import           Data.Void
 import           GHC.Generics (Generic1)
@@ -54,7 +54,7 @@ data Monotype a
   | Bool
   | Int
   | String
-  | Monotype a :-> Monotype a
+  | [Monotype a] :-> Monotype a
   -- | (Locally) undefined names whose types are unknown. May not be eliminated by unification.
   | TypeOf Name
   deriving (Eq, Foldable, Functor, Generic1, Ord, Show, Traversable)
@@ -78,7 +78,7 @@ instance Monad Monotype where
     Int      -> Int
     String   -> String
     TypeOf n -> TypeOf n
-    a :-> b  -> (a >>= f) :-> (b >>= f)
+    a :-> b  -> (map (>>= f) a) :-> (b >>= f)
 
 
 type Type = Monotype Meta
@@ -180,7 +180,7 @@ type Substitution = IM.IntMap Type
 solve :: (Has (State Substitution) sig m, MonadFail m) => Set.Set (Type, Type) -> m ()
 solve cs = for_ cs (uncurry solve)
   where solve = curry $ \case
-          (a1 :-> b1, a2 :-> b2)            -> solve a1 a2 *> solve b1 b2
+          (a1 :-> b1, a2 :-> b2)            -> sequenceA_ (zipWith solve a1 a2) *> solve b1 b2
           (Var m1   , Var m2)    | m1 == m2 -> pure ()
           (Var m1   , t2)                   -> do
             sol <- solution m1
@@ -230,16 +230,16 @@ instance ( Alternative m
     L (DString _) -> pure (String <$ ctx)
 
     L (DAbs n b) -> do
-      addr <- A.alloc n
-      arg <- meta
-      addr A..= arg
-      ty <- hdl (b arg <$ ctx)
-      pure ((arg :->) <$> ty)
+      addrs <- traverse A.alloc n
+      args <- traverse (const meta) n
+      sequenceA_ (zipWith (A..=) addrs args)
+      ty <- hdl (b args <$ ctx)
+      pure ((args :->) <$> ty)
     L (DApp f a) -> do
-      arg <- meta
+      args <- traverse (const meta) a
       ret <- meta
-      unify f (arg :-> ret)
-      unify a arg
+      unify f (args :-> ret)
+      sequenceA_ (zipWith unify a args)
       pure (ret <$ ctx)
 
     L (DDie msg) -> fail (show msg)

semantic-analysis/src/Analysis/Carrier/Store/Monovariant.hs

@@ -36,7 +36,7 @@ import Control.Monad.Fail as Fail
 import Data.Map as Map
 import Data.Set as Set
 
-newtype MAddr = MAddr Name
+newtype MAddr = MAddr { getMAddr :: Name }
   deriving (Eq, Ord, Show)
 
 newtype MStore value = MStore { getMStore :: Map.Map MAddr (Set.Set value) }

semantic-analysis/src/Analysis/Effect/Domain.hs

@@ -39,10 +39,10 @@ dvar = send . DVar
 
 -- Functions
 
-dabs :: Has (Dom val) sig m => Name -> (val -> m val) -> m val
+dabs :: Has (Dom val) sig m => [Name] -> ([val] -> m val) -> m val
 dabs n = send . DAbs n
 
-dapp :: Has (Dom val) sig m => val -> val -> m val
+dapp :: Has (Dom val) sig m => val -> [val] -> m val
 dapp f a = send $ DApp f a
 
 
@@ -89,8 +89,8 @@ ddie = send . DDie
 
 data Dom val m k where
   DVar :: Name -> Dom val m val
-  DAbs :: Name -> (val -> m val) -> Dom val m val
-  DApp :: val -> val -> Dom val m val
+  DAbs :: [Name] -> ([val] -> m val) -> Dom val m val
+  DApp :: val -> [val] -> Dom val m val
   DInt :: Int -> Dom val m val
   DUnit :: Dom val m val
   DBool :: Bool -> Dom val m val

semantic-analysis/src/Analysis/Syntax.hs

@@ -12,6 +12,7 @@ module Analysis.Syntax
 , eval
   -- * Macro-expressible syntax
 , let'
+, letrec
   -- * Parsing
 , parseFile
 , parseGraph
@@ -35,6 +36,7 @@ import qualified Data.Aeson.Internal as A
 import qualified Data.Aeson.Parser as A
 import qualified Data.Aeson.Types as A
 import qualified Data.ByteString.Lazy as B
+import           Data.Foldable (fold)
 import           Data.Function (fix)
 import qualified Data.IntMap as IntMap
 import           Data.List (sortOn)
@@ -54,6 +56,7 @@ data Term
   | Throw Term
   | Let Name Term Term
   | Import (NonEmpty Text)
+  | Function Name [Name] Term
   deriving (Eq, Ord, Show)
 
 
@@ -79,6 +82,8 @@ eval eval = \case
     v' <- eval v
     let' n v' (eval b)
   Import ns -> S.simport ns >> dunit
+  Function n ps b -> letrec n (dabs ps (\ as ->
+    foldr (\ (p, a) m -> let' p a m) (eval b) (zip ps as)))
 
 
 -- Macro-expressible syntax
@@ -89,6 +94,13 @@ let' n v m = do
   addr .= v
   bind n addr m
 
+letrec :: (Has (Env addr) sig m, HasLabelled Store (Store addr val) sig m) => Name -> m val -> m val
+letrec n m = do
+  addr <- alloc n
+  v <- bind n addr m
+  addr .= v
+  pure v
+
 
 -- Parsing
 
@@ -102,26 +114,32 @@ parseFile path = do
     -- FIXME: this should use the span of the source file, not an empty span.
     Right (_, Just root) -> pure (File (Ref.fromPath (Path.absRel path)) root)
 
-parseGraph :: A.Value -> A.Parser (IntMap.IntMap Term, Maybe Term)
+newtype Graph = Graph { terms :: IntMap.IntMap Term }
+
+-- | Parse a @Value@ into an entire graph of terms, as well as a root node, if any exists.
+parseGraph :: A.Value -> A.Parser (Graph, Maybe Term)
 parseGraph = A.withArray "nodes" $ \ nodes -> do
-  (untied, First root) <- foldMap (\ (k, v, r) -> ([(k, v)], First r)) <$> traverse (A.withObject "node" parseNode) (V.toList nodes)
-  -- @untied@ is a list of key/value pairs, where the keys are graph node IDs and the values are functions from the final graph to the representations of said graph nodes. Likewise, @root@ is a function of the same variety, wrapped in a @Maybe@.
+  (untied, First root) <- fold <$> traverse parseNode (V.toList nodes)
+  -- @untied@ is an intmap, where the keys are graph node IDs and the values are functions from the final graph to the representations of said graph nodes. Likewise, @root@ is a function of the same variety, wrapped in a @Maybe@.
   --
-  -- We define @tied@ as the fixpoint of the former to yield the former as a graph of type @IntMap.IntMap Term@, and apply the latter to said graph to yield the entry point, if any, from which to evaluate.
-  let tied = fix (\ tied -> ($ tied) <$> IntMap.fromList untied)
-  pure (tied, ($ tied) <$> root)
-
-parseNode :: A.Object -> A.Parser (IntMap.Key, IntMap.IntMap Term -> Term, Maybe (IntMap.IntMap Term -> Term))
-parseNode o = do
+  -- We define @tied@ as the fixpoint of the former to yield the former as a graph of type @Graph@, and apply the latter to said graph to yield the entry point, if any, from which to evaluate.
+  let tied = fix (\ tied -> ($ Graph tied) <$> untied)
+  pure (Graph tied, ($ Graph tied) <$> root)
+
+-- | Parse a node from a JSON @Value@ into a pair of a partial graph of unfixed terms and optionally an unfixed term representing the root node.
+--
+-- The partial graph is represented as an adjacency map relating node IDs to unfixed terms—terms which may make reference to a completed graph to find edges, and which therefore can't be inspected until the full graph is known.
+parseNode :: A.Value -> A.Parser (IntMap.IntMap (Graph -> Term), First (Graph -> Term))
+parseNode = A.withObject "node" $ \ o -> do
   edges <- o A..: fromString "edges"
   index <- o A..: fromString "id"
   o A..: fromString "attrs" >>= A.withObject "attrs" (\ attrs -> do
     ty <- attrs A..: fromString "type"
-    node <- parseType attrs edges ty
-    pure (index, node, node <$ guard (ty == "module")))
+    node <- parseTerm attrs edges ty
+    pure (IntMap.singleton index node, node <$ First (guard (ty == "module"))))
 
-parseType :: A.Object -> [A.Value] -> String -> A.Parser (IntMap.IntMap Term -> Term)
-parseType attrs edges = \case
+parseTerm :: A.Object -> [A.Value] -> String -> A.Parser (Graph -> Term)
+parseTerm attrs edges = \case
   "string"     -> const . String <$> attrs A..: fromString "text"
   "true"       -> pure (const (Bool True))
   "false"      -> pure (const (Bool False))
@@ -131,13 +149,14 @@ parseType attrs edges = \case
   "module"     -> children edges
   "identifier" -> const . Var . name <$> attrs A..: fromString "text"
   "import"     -> const . Import . fromList . map snd . sortOn fst <$> traverse (resolveWith (const moduleNameComponent)) edges
+  "function"   -> liftA3 Function . pure . name <$> attrs A..: fromString "name" <*> pure (pure []) <*> findEdgeNamed edges "body"
   t            -> A.parseFail ("unrecognized type: " <> t <> " attrs: " <> show attrs <> " edges: " <> show edges)
 
-findEdgeNamed :: (Foldable t, A.FromJSON a, Eq a) => t A.Value -> a -> A.Parser (IntMap.IntMap rep -> rep)
+findEdgeNamed :: (Foldable t, A.FromJSON a, Eq a) => t A.Value -> a -> A.Parser (Graph -> Term)
 findEdgeNamed edges name = foldMap (resolveWith (\ rep attrs -> attrs A..: fromString "type" >>= (rep <$) . guard . (== name))) edges
 
 -- | Map a list of edges to a list of child nodes.
-children :: [A.Value] -> A.Parser (IntMap.IntMap Term -> Term)
+children :: [A.Value] -> A.Parser (Graph -> Term)
 children edges = fmap (foldr chain Noop . zip [0..]) . sequenceA <$> traverse resolve edges
 
 moduleNameComponent :: A.Object -> A.Parser (Int, Text)
@@ -147,11 +166,14 @@ moduleNameComponent attrs = (,) <$> attrs A..: fromString "index" <*> attrs A..:
 chain :: (Int, Term) -> Term -> Term
 chain = uncurry (Let . nameI)
 
-resolve :: A.Value -> A.Parser (IntMap.IntMap rep -> rep)
+resolve :: A.Value -> A.Parser (Graph -> Term)
 resolve = resolveWith (const . pure)
 
-resolveWith :: ((IntMap.IntMap rep -> rep) -> A.Object -> A.Parser a) -> A.Value -> A.Parser a
-resolveWith f = A.withObject "edge" (\ edge -> do
+resolveWith :: ((Graph -> Term) -> A.Object -> A.Parser a) -> A.Value -> A.Parser a
+resolveWith f = resolveWith' (f . flip ((IntMap.!) . terms))
+
+resolveWith' :: (IntMap.Key -> A.Object -> A.Parser a) -> A.Value -> A.Parser a
+resolveWith' f = A.withObject "edge" (\ edge -> do
   sink <- edge A..: fromString "sink"
   attrs <- edge A..: fromString "attrs"
-  f (IntMap.! sink) attrs)
+  f sink attrs)