Merge branch 'scope-graphs' into re-name

Author: robrix

.ghci

@@ -2,16 +2,9 @@
 :set -package pretty-show -package hscolour
 
 -- See docs/💡ProTip!.md
-:undef pretty
-:def pretty \ _ -> return ":set -interactive-print Semantic.Util.Pretty.prettyShow"
-
--- See docs/💡ProTip!.md
-:undef no-pretty
-:def no-pretty \_ -> return ":set -interactive-print System.IO.print"
-
--- See docs/💡ProTip!.md
-:undef r
-:def r \_ -> return (unlines [":reload", ":pretty"])
+:def! pretty \ _ -> return ":set -interactive-print Semantic.Util.Pretty.prettyShow"
+:def! no-pretty \_ -> return ":set -interactive-print System.IO.print"
+:def! r \_ -> return (unlines [":reload", ":pretty"])
 
 -- See docs/💡ProTip!.md for documentation & examples.
 :{
@@ -29,8 +22,7 @@ assignmentExample lang = case lang of
   _ -> mk "" ""
   where mk fileExtension parser = putStrLn ("example: fmap (() <$) . runTask . parse " ++ parser ++ "Parser =<< Semantic.Util.blob \"example." ++ fileExtension ++ "\"") >> return ("import Parsing.Parser\nimport Semantic.Task\nimport Semantic.Util")
 :}
-:undef assignment
-:def assignment assignmentExample
+:def! assignment assignmentExample
 
 -- Enable breaking on errors for code written in the repl.
 :seti -fbreak-on-error

script/publish

@@ -6,7 +6,7 @@
 set -e
 cd $(dirname "$0")/..
 
-VERSION="0.6.0"
+VERSION="0.7.0.0"
 BUILD_SHA=$(git rev-parse HEAD 2>/dev/null)
 DOCKER_IMAGE=docker.pkg.github.com/github/semantic/semantic
 

semantic-core/src/Analysis/Concrete.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DerivingVia, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, NamedFieldPuns, OverloadedStrings, RankNTypes, RecordWildCards, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DerivingVia, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, NamedFieldPuns, OverloadedStrings, RankNTypes, RecordWildCards, TypeApplications, TypeOperators, UndecidableInstances #-}
 module Analysis.Concrete
 ( Concrete(..)
 , concrete
@@ -46,6 +46,7 @@ data Concrete term
   | String Text
   | Record Env
   deriving (Eq, Ord, Show)
+  -- NB: We derive the 'Semigroup' instance for 'Concrete' to take the second argument. This is equivalent to stating that the return value of an imperative sequence of statements is the value of its final statement.
   deriving Semigroup via Last (Concrete term)
 
 recordFrame :: Concrete term -> Maybe Env
@@ -102,7 +103,7 @@ runFile
 runFile eval file = traverse run file
   where run = runReader (fileLoc file)
             . runFailWithLoc
-            . runReader (mempty :: Env)
+            . runReader @Env mempty
             . fix (eval concreteAnalysis)
 
 concreteAnalysis :: ( Carrier sig m
@@ -184,7 +185,7 @@ heapGraph vertex edge h = foldr (uncurry graph) G.empty (IntMap.toList h)
           Bool _ -> G.empty
           String _ -> G.empty
           Closure _ _ _ env -> foldr (G.overlay . edge (Left Lexical)) G.empty env
-          Record frame -> foldr (G.overlay . uncurry (edge . Right)) G.empty (Map.toList frame)
+          Record frame -> Map.foldrWithKey (\ k -> G.overlay . edge (Right k)) G.empty frame
 
 heapValueGraph :: Heap term -> G.Graph (Concrete term)
 heapValueGraph h = heapGraph (const id) (const fromAddr) h

semantic-core/src/Analysis/Eval.hs

@@ -43,6 +43,9 @@ eval Analysis{..} eval = \case
       addr <- alloc n
       v <- bind n addr (eval (instantiate1 (pure n) b))
       v <$ assign addr v
+    -- NB: Combining the results of the evaluations allows us to model effects in abstract domains. This in turn means that we can define an abstract domain modelling the types-and-effects of computations by means of a 'Semigroup' instance which takes the type of its second operand and the union of both operands’ effects.
+    --
+    -- It’s also worth noting that we use a semigroup instead of a semilattice because the lattice structure of our abstract domains is instead modelled by nondeterminism effects used by some of them.
     a :>> b -> (<>) <$> eval a <*> eval b
     Named (Ignored n) a :>>= b -> do
       a' <- eval a

semantic-core/src/Analysis/ScopeGraph.hs

@@ -102,7 +102,8 @@ scopeGraphAnalysis = Analysis{..}
           ref <- asks Ref
           bindLoc <- asks (Map.lookup addr)
           cell <- gets (Map.lookup addr >=> nonEmpty . Set.toList)
-          maybe (pure Nothing) (foldMapA (pure . Just . mappend (extendBinding addr ref bindLoc))) cell
+          let extending = mappend (extendBinding addr ref bindLoc)
+          maybe (pure Nothing) (foldMapA (pure . Just . extending)) cell
         assign addr v = do
           ref <- asks Ref
           bindLoc <- asks (Map.lookup addr)

semantic-core/src/Analysis/Typecheck.hs

@@ -49,6 +49,8 @@ data Monotype f a
 type Type = Term Monotype Meta
 
 -- FIXME: Union the effects/annotations on the operands.
+
+-- | We derive the 'Semigroup' instance for types to take the second argument. This is equivalent to stating that the type of an imperative sequence of statements is the type of its final statement.
 deriving via (Last (Term Monotype a)) instance Semigroup (Term Monotype a)
 
 deriving instance (Eq   a, forall a . Eq   a => Eq   (f a), Monad f) => Eq   (Monotype f a)

semantic-core/src/Control/Monad/Module.hs

@@ -8,6 +8,25 @@ module Control.Monad.Module
 
 import Control.Effect.Carrier
 
+-- | Modules over monads allow lifting of a monad’s product (i.e. 'Control.Monad.join') into another structure composed with the monad. A right-module @f m@ over a monad @m@ therefore allows one to extend @m@’s '>>=' operation to values of @f m@ using the '>>=*' operator.
+--
+--   In practical terms, this means that we can describe syntax which cannot itself bind or be substituted for variables, but which can be substituted inside when containing a substitutable expression monad. For example, we might not want to allow variables in a declaration context, but might still want to be able to substitute for e.g. globally-bound variables inside declarations; a 'RightModule' instance expresses this relationship nicely.
+--
+--   Note that we are calling this a right-module following Maciej Piróg, Nicolas Wu, & Jeremy Gibbons in _Modules Over Monads and their Algebras_; confusingly, other sources refer to this as a left-module.
+--
+--   Laws:
+--
+--   Right-identity:
+--
+-- @
+-- m >>=* return = m
+-- @
+--
+--   Associativity:
+--
+-- @
+-- m >>=* (k >=> h) = (m >>=* k) >>=* h
+-- @
 class (forall g . Functor g => Functor (f g), HFunctor f) => RightModule f where
   (>>=*) :: Monad m => f m a -> (a -> m b) -> f m b
   infixl 1 >>=*

semantic-core/src/Data/Core.hs

@@ -142,7 +142,7 @@ do' bindings = fromMaybe unit (foldr bind Nothing bindings)
   where bind (n :<- a) v = maybe (a >>>) ((>>>=) . (:<- a)) n <$> v <|> Just a
 
 unstatements :: (Member Core sig, RightModule sig) => Term sig a -> (Stack (Maybe (Named (Either Int a)) :<- Term sig (Either Int a)), Term sig (Either Int a))
-unstatements = un (unstatement . Left) . fmap Right
+unstatements = unprefix (unstatement . Left) . fmap Right
 
 data a :<- b = a :<- b
   deriving (Eq, Foldable, Functor, Ord, Show, Traversable)

semantic-core/src/Data/Core/Parser.hs

@@ -12,7 +12,7 @@ module Data.Core.Parser
 import           Control.Applicative
 import           Control.Effect.Carrier
 import qualified Data.Char as Char
-import           Data.Core (Core)
+import           Data.Core ((:<-) (..), Core)
 import qualified Data.Core as Core
 import           Data.Foldable (foldl')
 import           Data.Name
@@ -53,7 +53,8 @@ expr :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
 expr = ifthenelse <|> lambda <|> rec <|> load <|> assign
 
 assign :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
-assign = application <**> (flip (Core..=) <$ symbolic '=' <*> application <|> pure id) <?> "assignment"
+assign = application <**> (symbolic '=' *> rhs <|> pure id) <?> "assignment"
+  where rhs = flip (Core..=) <$> application
 
 application :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
 application = projection `chainl1` (pure (Core.$$))
@@ -72,10 +73,10 @@ atom = choice
 comp :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
 comp = braces (Core.do' <$> sepEndByNonEmpty statement semi) <?> "compound statement"
 
-statement :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (Maybe (Named Name) Core.:<- t Name)
+statement :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (Maybe (Named Name) :<- t Name)
 statement
-  =   try ((Core.:<-) . Just <$> name <* symbol "<-" <*> expr)
-  <|> (Nothing Core.:<-) <$> expr
+  =   try ((:<-) . Just <$> name <* symbol "<-" <*> expr)
+  <|> (Nothing :<-) <$> expr
   <?> "statement"
 
 ifthenelse :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
@@ -109,14 +110,8 @@ lit = let x `given` n = x <$ reserved n in choice
   , Core.bool False `given` "#false"
   , Core.unit       `given` "#unit"
   , record
-  , token (between (string "\"") (string "\"") (Core.string . fromString <$> many (escape <|> (noneOf "\"" <?> "non-escaped character"))))
+  , Core.string <$> stringLiteral
   ] <?> "literal"
-  where escape = char '\\' *> choice
-          [ '"'  <$ string "\""
-          , '\n' <$ string "n"
-          , '\r' <$ string "r"
-          , '\t' <$ string "t"
-          ] <?> "escape sequence"
 
 record :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
 record = Core.record <$ reserved "#record" <*> braces (sepEndBy ((,) <$> identifier <* symbolic ':' <*> expr) comma)

semantic-core/src/Data/Scope.hs

@@ -12,8 +12,8 @@ module Data.Scope
 , instantiate1
 , instantiate
 , instantiateEither
-, un
-, unEither
+, unprefix
+, unprefixEither
 ) where
 
 import Control.Applicative (liftA2)
@@ -110,11 +110,23 @@ instantiateEither :: Monad f => (Either a b -> f c) -> Scope a f b -> f c
 instantiateEither f = unScope >=> incr (f . Left) (>>= f . Right)
 
 
-un :: (Int -> t -> Maybe (a, t)) -> t -> (Stack a, t)
-un from = unEither (matchMaybe . from)
-
-unEither :: (Int -> t -> Either (a, t) b) -> t -> (Stack a, b)
-unEither from = go (0 :: Int) Nil
+-- | Unwrap a (possibly-empty) prefix of @a@s wrapping a @t@ using a helper function.
+--
+--   This allows us to peel a prefix of syntax, typically binders, off of a term, returning a stack of prefixing values (e.g. variables) and the outermost subterm rejected by the function.
+unprefix
+  :: (Int -> t -> Maybe (a, t)) -- ^ A function taking the 0-based index into the prefix & the current term, and optionally returning a pair of the prefixing value and the inner subterm.
+  -> t                          -- ^ The initial term.
+  -> (Stack a, t)               -- ^ A stack of prefixing values & the final subterm.
+unprefix from = unprefixEither (matchMaybe . from)
+
+-- | Unwrap a (possibly-empty) prefix of @a@s wrapping a @b@ within a @t@ using a helper function.
+--
+--   Compared to 'unprefix', this allows the helper function to extract inner terms of a different type, for example when @t@ is a right @b@-module.
+unprefixEither
+  :: (Int -> t -> Either (a, t) b) -- ^ A function taking the 0-based index into the prefix & the current term, and returning either a pair of the prefixing value and the next inner subterm of type @t@, or the final inner subterm of type @b@.
+  -> t                             -- ^ The initial term.
+  -> (Stack a, b)                  -- ^ A stack of prefixing values & the final subterm.
+unprefixEither from = go (0 :: Int) Nil
   where go i bs t = case from i t of
           Left (b, t) -> go (succ i) (bs :> b) t
           Right b     -> (bs, b)