Factor annotations out of Core

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

@@ -42,7 +42,7 @@ newtype FrameId = FrameId { unFrameId :: Precise }
   deriving (Eq, Ord, Show)
 
 data Concrete
-  = Closure Loc User (Term Core.Core User) Env
+  = Closure Loc User (Term (Core.Ann :+: Core.Core) User) Env
   | Unit
   | Bool Bool
   | String Text
@@ -70,7 +70,7 @@ data Edge = Lexical | Import
 --
 --   >>> map fileBody (snd (concrete [File (Loc "bool" emptySpan) (Core.bool True)]))
 --   [Right (Bool True)]
-concrete :: [File (Term Core.Core User)] -> (Heap, [File (Either (Loc, String) Concrete)])
+concrete :: [File (Term (Core.Ann :+: Core.Core) User)] -> (Heap, [File (Either (Loc, String) Concrete)])
 concrete
   = run
   . runFresh
@@ -82,7 +82,7 @@ runFile :: ( Carrier sig m
            , Member Fresh sig
            , Member (State Heap) sig
            )
-        => File (Term Core.Core User)
+        => File (Term (Core.Ann :+: Core.Core) User)
         -> m (File (Either (Loc, String) Concrete))
 runFile file = traverse run file
   where run = runReader (fileLoc file)

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 ((>=>))
@@ -33,11 +34,11 @@ eval :: ( Carrier sig m
         , Semigroup value
         )
      => Analysis address value m
-     -> (Term Core User -> m value)
-     -> (Term Core User -> m value)
+     -> (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))
@@ -71,7 +72,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)
@@ -81,41 +82,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"))
@@ -126,7 +127,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) ]) ]
@@ -136,7 +137,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
@@ -219,8 +220,8 @@ data Analysis address value m = Analysis
   , 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 (Ann :+: Core) User -> m value) -> User -> Term (Ann :+: Core) User -> m value
+  , apply     :: (Term (Ann :+: Core) User -> m value) -> value -> value -> m value
   , unit      :: m value
   , bool      :: Bool -> m value
   , asBool    :: value -> m Bool

semantic-core/src/Analysis/FlowInsensitive.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts, OverloadedStrings, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts, OverloadedStrings, ScopedTypeVariables, TypeOperators #-}
 module Analysis.FlowInsensitive
 ( Heap
 , FrameId(..)
@@ -20,7 +20,7 @@ import           Data.Monoid (Alt(..))
 import qualified Data.Set as Set
 import           Data.Term (Term)
 
-type Cache name a = Map.Map (Term Core.Core name) (Set.Set a)
+type Cache name a = Map.Map (Term (Core.Ann :+: Core.Core) name) (Set.Set a)
 type Heap name a = Map.Map name (Set.Set a)
 
 newtype FrameId name = FrameId { unFrameId :: name }
@@ -35,8 +35,8 @@ convergeTerm :: forall m sig a name
                 , Ord a
                 , Ord name
                 )
-             => (Term Core.Core name -> NonDetC (ReaderC (Cache name a) (StateC (Cache name a) m)) a)
-             -> Term Core.Core name
+             => (Term (Core.Ann :+: Core.Core) name -> NonDetC (ReaderC (Cache name a) (StateC (Cache name a) m)) a)
+             -> Term (Core.Ann :+: Core.Core) name
              -> m (Set.Set a)
 convergeTerm eval body = do
   heap <- get
@@ -53,8 +53,8 @@ cacheTerm :: forall m sig a name
              , Ord a
              , Ord name
              )
-          => (Term Core.Core name -> m a)
-          -> (Term Core.Core name -> m a)
+          => (Term (Core.Ann :+: Core.Core) name -> m a)
+          -> (Term (Core.Ann :+: Core.Core) name -> m a)
 cacheTerm eval term = do
   cached <- gets (Map.lookup term)
   case cached :: Maybe (Set.Set a) of

semantic-core/src/Analysis/ImportGraph.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts, OverloadedStrings, RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts, OverloadedStrings, RecordWildCards, TypeOperators #-}
 module Analysis.ImportGraph
 ( ImportGraph
 , importGraph
@@ -41,14 +41,14 @@ instance Monoid Value where
   mempty = Value Abstract mempty
 
 data Semi
-  = Closure Loc User (Term Core.Core User) User
+  = Closure Loc User (Term (Core.Ann :+: Core.Core) User) User
   -- FIXME: Bound String values.
   | String Text
   | Abstract
   deriving (Eq, Ord, Show)
 
 
-importGraph :: [File (Term Core.Core User)] -> (Heap User Value, [File (Either (Loc, String) Value)])
+importGraph :: [File (Term (Core.Ann :+: Core.Core) User)] -> (Heap User Value, [File (Either (Loc, String) Value)])
 importGraph
   = run
   . runFresh
@@ -61,7 +61,7 @@ runFile :: ( Carrier sig m
            , Member (Reader (FrameId User)) sig
            , Member (State (Heap User Value)) sig
            )
-        => File (Term Core.Core User)
+        => File (Term (Core.Ann :+: Core.Core) User)
         -> m (File (Either (Loc, String) Value))
 runFile file = traverse run file
   where run = runReader (fileLoc file)

semantic-core/src/Analysis/Typecheck.hs

@@ -88,7 +88,7 @@ generalize :: Term Monotype Meta -> Term (Polytype :+: Monotype) Void
 generalize ty = fromJust (closed (forAlls (IntSet.toList (mvs ty)) (hoistTerm R ty)))
 
 
-typecheckingFlowInsensitive :: [File (Term Core.Core User)] -> (Heap User (Term Monotype Meta), [File (Either (Loc, String) (Term (Polytype :+: Monotype) Void))])
+typecheckingFlowInsensitive :: [File (Term (Core.Ann :+: Core.Core) User)] -> (Heap User (Term Monotype Meta), [File (Either (Loc, String) (Term (Polytype :+: Monotype) Void))])
 typecheckingFlowInsensitive
   = run
   . runFresh
@@ -101,7 +101,7 @@ runFile :: ( Carrier sig m
            , Member Fresh sig
            , Member (State (Heap User (Term Monotype Meta))) sig
            )
-        => File (Term Core.Core User)
+        => File (Term (Core.Ann :+: Core.Core) User)
         -> m (File (Either (Loc, String) (Term Monotype Meta)))
 runFile file = traverse run file
   where run

semantic-core/src/Data/Core.hs

@@ -27,6 +27,7 @@ module Data.Core
 , record
 , (...)
 , (.=)
+, Ann(..)
 , ann
 , annWith
 , instantiate
@@ -75,7 +76,6 @@ data Core f a
   | f a :. User
   -- | Assignment of a value to the reference returned by the lhs.
   | f a := f a
-  | Ann Loc (f a)
   deriving (Foldable, Functor, Generic1, Traversable)
 
 infixr 1 :>>
@@ -105,7 +105,6 @@ instance RightModule Core where
   Record fs  >>=* f = Record (map (fmap (>>= f)) fs)
   (a :. b)   >>=* f = (a >>= f) :. b
   (a := b)   >>=* f = (a >>= f) := (b >>= f)
-  Ann l b    >>=* f = Ann l (b >>= f)
 
 
 rec :: (Eq a, Carrier sig m, Member Core sig) => Named a -> m a -> m a
@@ -212,15 +211,25 @@ a .= b = send (a := b)
 
 infix 3 .=
 
-ann :: (Carrier sig m, Member Core sig) => HasCallStack => m a -> m a
+
+data Ann f a
+  = Ann Loc (f a)
+  deriving (Eq, Foldable, Functor, Generic1, Ord, Show, Traversable)
+
+instance HFunctor Ann
+
+instance RightModule Ann where
+  Ann l b >>=* f = Ann l (b >>= f)
+
+
+ann :: (Carrier sig m, Member Ann sig) => HasCallStack => m a -> m a
 ann = annWith callStack
 
-annWith :: (Carrier sig m, Member Core sig) => CallStack -> m a -> m a
+annWith :: (Carrier sig m, Member Ann sig) => CallStack -> m a -> m a
 annWith callStack = maybe id (fmap send . Ann) (stackLoc callStack)
 
 
-stripAnnotations :: (Member Core sig, HFunctor sig, forall g . Functor g => Functor (sig g)) => Term sig a -> Term sig a
-stripAnnotations (Var v)  = Var v
-stripAnnotations (Term t)
-  | Just c <- prj t, Ann _ b <- c = stripAnnotations b
-  | otherwise                     = Term (hmap stripAnnotations t)
+stripAnnotations :: (HFunctor sig, forall g . Functor g => Functor (sig g)) => Term (Ann :+: sig) a -> Term sig a
+stripAnnotations (Var v)              = Var v
+stripAnnotations (Term (L (Ann _ b))) = stripAnnotations b
+stripAnnotations (Term (R        b))  = Term (hmap stripAnnotations b)