Merge branch 'generalize-analyses-over-the-term-type' into scope-graphs

Author: robrix

semantic-core/semantic-core.cabal

@@ -84,6 +84,7 @@ test-suite spec
   other-modules:       Generators
   build-depends:       base
                      , semantic-core
+                     , fused-effects
                      , hedgehog ^>= 1
                      , tasty >= 1.2 && <2
                      , tasty-hedgehog ^>= 1.0.0.1

semantic-core/src/Analysis/Concrete.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DerivingVia, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, NamedFieldPuns, OverloadedStrings, RecordWildCards, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DerivingVia, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, NamedFieldPuns, OverloadedStrings, RankNTypes, RecordWildCards, TypeOperators, UndecidableInstances #-}
 module Analysis.Concrete
 ( Concrete(..)
 , concrete
@@ -20,7 +20,6 @@ import           Control.Effect.NonDet
 import           Control.Effect.Reader hiding (Local)
 import           Control.Effect.State
 import           Control.Monad ((<=<), guard)
-import qualified Data.Core as Core
 import           Data.File
 import           Data.Function (fix)
 import qualified Data.IntMap as IntMap
@@ -30,7 +29,6 @@ import qualified Data.Map as Map
 import           Data.Name
 import           Data.Semigroup (Last (..))
 import qualified Data.Set as Set
-import           Data.Term
 import           Data.Text (Text, pack)
 import           Data.Traversable (for)
 import           Prelude hiding (fail)
@@ -41,16 +39,16 @@ type Env = Map.Map User Precise
 newtype FrameId = FrameId { unFrameId :: Precise }
   deriving (Eq, Ord, Show)
 
-data Concrete
-  = Closure Loc User (Term Core.Core User) Env
+data Concrete term
+  = Closure Loc User term Env
   | Unit
   | Bool Bool
   | String Text
   | Record Env
   deriving (Eq, Ord, Show)
-  deriving Semigroup via Last Concrete
+  deriving Semigroup via Last (Concrete term)
 
-recordFrame :: Concrete -> Maybe Env
+recordFrame :: Concrete term -> Maybe Env
 recordFrame (Record frame) = Just frame
 recordFrame _              = Nothing
 
@@ -59,44 +57,64 @@ newtype Frame = Frame
   }
   deriving (Eq, Ord, Show)
 
-type Heap = IntMap.IntMap Concrete
+type Heap term = IntMap.IntMap (Concrete term)
 
 data Edge = Lexical | Import
   deriving (Eq, Ord, Show)
 
 
 -- | Concrete evaluation of a term to a value.
 --
---   >>> map fileBody (snd (concrete [File (Loc "bool" emptySpan) (Core.bool True)]))
+--   >>> map fileBody (snd (concrete eval [File (Loc "bool" emptySpan) (Core.bool True)]))
 --   [Right (Bool True)]
-concrete :: [File (Term Core.Core User)] -> (Heap, [File (Either (Loc, String) Concrete)])
 concrete
+  :: (Foldable term, Show (term User))
+  => (forall sig m
+     .  (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
+     => Analysis (term User) Precise (Concrete (term User)) m
+     -> (term User -> m (Concrete (term User)))
+     -> (term User -> m (Concrete (term User)))
+     )
+  -> [File (term User)]
+  -> (Heap (term User), [File (Either (Loc, String) (Concrete (term User)))])
+concrete eval
   = run
   . runFresh
   . runHeap
-  . traverse runFile
-
-runFile :: ( Carrier sig m
-           , Effect sig
-           , Member Fresh sig
-           , Member (State Heap) sig
-           )
-        => File (Term Core.Core User)
-        -> m (File (Either (Loc, String) Concrete))
-runFile file = traverse run file
+  . traverse (runFile eval)
+
+runFile
+  :: ( Carrier sig m
+     , Effect sig
+     , Foldable term
+     , Member Fresh sig
+     , Member (State (Heap (term User))) sig
+     , Show (term User)
+     )
+  => (forall sig m
+     .  (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
+     => Analysis (term User) Precise (Concrete (term User)) m
+     -> (term User -> m (Concrete (term User)))
+     -> (term User -> m (Concrete (term User)))
+     )
+  -> File (term User)
+  -> m (File (Either (Loc, String) (Concrete (term User))))
+runFile eval file = traverse run file
   where run = runReader (fileLoc file)
             . runFailWithLoc
             . runReader (mempty :: Env)
             . fix (eval concreteAnalysis)
 
 concreteAnalysis :: ( Carrier sig m
+                    , Foldable term
                     , Member Fresh sig
                     , Member (Reader Env) sig
                     , Member (Reader Loc) sig
-                    , Member (State Heap) sig
+                    , Member (State (Heap (term User))) sig
                     , MonadFail m
+                    , Show (term User)
                     )
-                 => Analysis Precise Concrete m
+                 => Analysis (term User) Precise (Concrete (term User)) m
 concreteAnalysis = Analysis{..}
   where alloc _ = fresh
         bind name addr m = local (Map.insert name addr) m
@@ -132,7 +150,7 @@ concreteAnalysis = Analysis{..}
           pure (val >>= lookupConcrete heap n)
 
 
-lookupConcrete :: Heap -> User -> Concrete -> Maybe Precise
+lookupConcrete :: Heap term -> User -> Concrete term -> Maybe Precise
 lookupConcrete heap name = run . evalState IntSet.empty . runNonDet . inConcrete
   where -- look up the name in a concrete value
         inConcrete = inFrame <=< maybeA . recordFrame
@@ -149,7 +167,7 @@ lookupConcrete heap name = run . evalState IntSet.empty . runNonDet . inConcrete
         maybeA = maybe empty pure
 
 
-runHeap :: StateC Heap m a -> m (Heap, a)
+runHeap :: StateC (Heap term) m a -> m (Heap term, a)
 runHeap = runState mempty
 
 
@@ -158,7 +176,7 @@ runHeap = runState mempty
 --   > λ let (heap, res) = concrete [ruby]
 --   > λ writeFile "/Users/rob/Desktop/heap.dot" (export (addressStyle heap) (heapAddressGraph heap))
 --   > λ :!dot -Tsvg < ~/Desktop/heap.dot > ~/Desktop/heap.svg
-heapGraph :: (Precise -> Concrete -> a) -> (Either Edge User -> Precise -> G.Graph a) -> Heap -> G.Graph a
+heapGraph :: (Precise -> Concrete term -> a) -> (Either Edge User -> Precise -> G.Graph a) -> Heap term -> G.Graph a
 heapGraph vertex edge h = foldr (uncurry graph) G.empty (IntMap.toList h)
   where graph k v rest = (G.vertex (vertex k v) `G.connect` outgoing v) `G.overlay` rest
         outgoing = \case
@@ -168,14 +186,14 @@ heapGraph vertex edge h = foldr (uncurry graph) G.empty (IntMap.toList h)
           Closure _ _ _ env -> foldr (G.overlay . edge (Left Lexical)) G.empty env
           Record frame -> foldr (G.overlay . uncurry (edge . Right)) G.empty (Map.toList frame)
 
-heapValueGraph :: Heap -> G.Graph Concrete
+heapValueGraph :: Heap term -> G.Graph (Concrete term)
 heapValueGraph h = heapGraph (const id) (const fromAddr) h
   where fromAddr addr = maybe G.empty G.vertex (IntMap.lookup addr h)
 
-heapAddressGraph :: Heap -> G.Graph (EdgeType, Precise)
+heapAddressGraph :: Heap term -> G.Graph (EdgeType term, Precise)
 heapAddressGraph = heapGraph (\ addr v -> (Value v, addr)) (fmap G.vertex . (,) . either Edge Slot)
 
-addressStyle :: Heap -> G.Style (EdgeType, Precise) Text
+addressStyle :: Heap term -> G.Style (EdgeType term, Precise) Text
 addressStyle heap = (G.defaultStyle vertex) { G.edgeAttributes }
   where vertex (_, addr) = pack (show addr) <> " = " <> maybe "?" fromConcrete (IntMap.lookup addr heap)
         edgeAttributes _ (Slot name,    _) = ["label" G.:= name]
@@ -190,12 +208,13 @@ addressStyle heap = (G.defaultStyle vertex) { G.edgeAttributes }
           Record _ -> "{}"
         showPos (Pos l c) = pack (show l) <> ":" <> pack (show c)
 
-data EdgeType
+data EdgeType term
   = Edge Edge
   | Slot User
-  | Value Concrete
+  | Value (Concrete term)
   deriving (Eq, Ord, Show)
 
 
 -- $setup
 -- >>> :seti -XOverloadedStrings
+-- >>> import qualified Data.Core as Core

semantic-core/src/Analysis/Eval.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts, LambdaCase, OverloadedStrings, RankNTypes, RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts, LambdaCase, OverloadedStrings, RankNTypes, RecordWildCards, TypeOperators #-}
 module Analysis.Eval
 ( eval
 , prog1
@@ -12,6 +12,7 @@ module Analysis.Eval
 ) where
 
 import Control.Applicative (Alternative (..))
+import Control.Effect.Carrier
 import Control.Effect.Fail
 import Control.Effect.Reader
 import Control.Monad ((>=>))
@@ -32,12 +33,12 @@ eval :: ( Carrier sig m
         , MonadFail m
         , Semigroup value
         )
-     => Analysis address value m
-     -> (Term Core User -> m value)
-     -> (Term Core User -> m value)
+     => Analysis (Term (Ann :+: Core) User) address value m
+     -> (Term (Ann :+: Core) User -> m value)
+     -> (Term (Ann :+: Core) User -> m value)
 eval Analysis{..} eval = \case
   Var n -> lookupEnv' n >>= deref' n
-  Term c -> case c of
+  Term (R c) -> case c of
     Rec (Named (Ignored n) b) -> do
       addr <- alloc n
       v <- bind n addr (eval (instantiate1 (pure n) b))
@@ -68,7 +69,7 @@ eval Analysis{..} eval = \case
       b' <- eval b
       addr <- ref a
       b' <$ assign addr b'
-    Ann loc c -> local (const loc) (eval c)
+  Term (L (Ann loc c)) -> local (const loc) (eval c)
   where freeVariable s = fail ("free variable: " <> s)
         uninitialized s = fail ("uninitialized variable: " <> s)
         invalidRef s = fail ("invalid ref: " <> s)
@@ -78,41 +79,41 @@ eval Analysis{..} eval = \case
 
         ref = \case
           Var n -> lookupEnv' n
-          Term c -> case c of
+          Term (R c) -> case c of
             If c t e -> do
               c' <- eval c >>= asBool
               if c' then ref t else ref e
             a :. b -> do
               a' <- ref a
               a' ... b >>= maybe (freeVariable (show b)) pure
-            Ann loc c -> local (const loc) (ref c)
             c -> invalidRef (show c)
+          Term (L (Ann loc c)) -> local (const loc) (ref c)
 
 
-prog1 :: File (Term Core User)
+prog1 :: (Carrier sig t, Member Core sig) => File (t User)
 prog1 = fromBody $ lam (named' "foo")
   (    named' "bar" :<- pure "foo"
   >>>= Core.if' (pure "bar")
     (Core.bool False)
     (Core.bool True))
 
-prog2 :: File (Term Core User)
+prog2 :: (Carrier sig t, Member Core sig) => File (t User)
 prog2 = fromBody $ fileBody prog1 $$ Core.bool True
 
-prog3 :: File (Term Core User)
+prog3 :: (Carrier sig t, Member Core sig) => File (t User)
 prog3 = fromBody $ lams [named' "foo", named' "bar", named' "quux"]
   (Core.if' (pure "quux")
     (pure "bar")
     (pure "foo"))
 
-prog4 :: File (Term Core User)
+prog4 :: (Carrier sig t, Member Core sig) => File (t User)
 prog4 = fromBody
   (    named' "foo" :<- Core.bool True
   >>>= Core.if' (pure "foo")
     (Core.bool True)
     (Core.bool False))
 
-prog5 :: File (Term Core User)
+prog5 :: (Carrier sig t, Member Ann sig, Member Core sig) => File (t User)
 prog5 = fromBody $ ann (do'
   [ Just (named' "mkPoint") :<- lams [named' "_x", named' "_y"] (ann (Core.record
     [ ("x", ann (pure "_x"))
@@ -123,7 +124,7 @@ prog5 = fromBody $ ann (do'
   , Nothing :<- ann (ann (pure "point") Core.... "y") .= ann (ann (pure "point") Core.... "x")
   ])
 
-prog6 :: [File (Term Core User)]
+prog6 :: (Carrier sig t, Member Core sig) => [File (t User)]
 prog6 =
   [ File (Loc "dep"  (locSpan (fromJust here))) $ Core.record
     [ ("dep", Core.record [ ("var", Core.bool True) ]) ]
@@ -133,7 +134,7 @@ prog6 =
     ])
   ]
 
-ruby :: File (Term Core User)
+ruby :: (Carrier sig t, Member Ann sig, Member Core sig) => File (t User)
 ruby = fromBody $ annWith callStack (rec (named' __semantic_global) (do' statements))
   where statements =
           [ Just "Class" :<- record
@@ -210,14 +211,14 @@ ruby = fromBody $ annWith callStack (rec (named' __semantic_global) (do' stateme
         __semantic_truthy = "__semantic_truthy"
 
 
-data Analysis address value m = Analysis
+data Analysis term address value m = Analysis
   { alloc     :: User -> m address
   , bind      :: forall a . User -> address -> m a -> m a
   , lookupEnv :: User -> m (Maybe address)
   , deref     :: address -> m (Maybe value)
   , assign    :: address -> value -> m ()
-  , abstract  :: (Term Core User -> m value) -> User -> Term Core User -> m value
-  , apply     :: (Term Core User -> m value) -> value -> value -> m value
+  , abstract  :: (term -> m value) -> User -> term -> m value
+  , apply     :: (term -> m value) -> value -> value -> m value
   , unit      :: m value
   , bool      :: Bool -> m value
   , asBool    :: value -> m Bool