Merge pull request #35 from github/semantic-core

Core intermediate language

cabal.project

@@ -1,3 +1,3 @@
-packages: vendor/* vendor/proto3-suite vendor/haskell-tree-sitter/languages/* semantic.cabal
+packages: vendor/* vendor/proto3-suite vendor/haskell-tree-sitter/languages/* semantic.cabal semantic-core/semantic-core.cabal
 
 package proto3-suite

semantic-core/LICENSE

@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2019 GitHub
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

semantic-core/README.md

@@ -0,0 +1,18 @@
+# semantic-core
+
+Semantic core intermediate language (experimental)
+
+
+## Development
+
+This project consists of a Haskell package named `semantic-core`. The library’s sources are in [`src`][].
+
+Development of `semantic-core` is typically done using `cabal new-build`:
+
+```shell
+cabal new-build # build the library
+cabal new-repl  # load the package into ghci
+cabal new-test  # build and run the doctests
+```
+
+[`src`]: https://github.com/github/semantic/tree/master/semantic-core/src

semantic-core/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

semantic-core/semantic-core.cabal

@@ -0,0 +1,59 @@
+cabal-version:       2.2
+
+name:                semantic-core
+version:             0.0.0.0
+synopsis:            Semantic core intermediate language
+-- description:
+homepage:            https://github.com/github/semantic-core
+-- bug-reports:
+license:             MIT
+license-file:        LICENSE
+author:              Rob Rix
+maintainer:          robrix@github.com
+-- copyright:
+category:            Language
+build-type:          Simple
+extra-source-files:  README.md
+
+tested-with:         GHC == 8.6.4
+
+library
+  exposed-modules:     Analysis.Concrete
+                     , Analysis.Eval
+                     , Analysis.FlowInsensitive
+                     , Analysis.ImportGraph
+                     , Analysis.ScopeGraph
+                     , Analysis.Typecheck
+                     , Control.Effect.Readline
+                     , Data.Core
+                     , Data.File
+                     , Data.Loc
+                     , Data.Name
+                     , Data.Stack
+  -- other-modules:
+  -- other-extensions:
+  build-depends:       algebraic-graphs ^>= 0.3
+                     , base             >= 4.11 && < 5
+                     , containers       ^>= 0.6
+                     , directory        ^>= 1.3
+                     , filepath         ^>= 1.4
+                     , fused-effects    ^>= 0.4
+                     , haskeline        ^>= 0.7.5
+                     , prettyprinter    ^>= 1.2.1
+                     , semigroupoids    ^>= 5.3
+                     , transformers     ^>= 0.5.6
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  ghc-options:         -Weverything -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wno-name-shadowing -Wno-monomorphism-restriction -Wno-missed-specialisations -Wno-all-missed-specialisations
+  if (impl(ghc >= 8.6))
+    ghc-options:       -Wno-star-is-type
+
+test-suite doctest
+  type:                exitcode-stdio-1.0
+  main-is:             Doctest.hs
+  build-depends:       base >=4.9 && <4.13
+                     , doctest >=0.7 && <1.0
+                     , QuickCheck
+                     , semantic-core
+  hs-source-dirs:      test
+  default-language:    Haskell2010

semantic-core/src/Analysis/Concrete.hs

@@ -0,0 +1,211 @@
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, LambdaCase, MultiParamTypeClasses, NamedFieldPuns, RecordWildCards, TypeApplications, TypeOperators, UndecidableInstances #-}
+module Analysis.Concrete
+( Concrete(..)
+, concrete
+, concreteAnalysis
+, heapGraph
+, heapValueGraph
+, heapAddressGraph
+, addressStyle
+) where
+
+import qualified Algebra.Graph as G
+import qualified Algebra.Graph.Export.Dot as G
+import           Analysis.Eval
+import           Control.Applicative (Alternative (..))
+import           Control.Effect
+import           Control.Effect.Fail
+import           Control.Effect.Fresh
+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
+import qualified Data.IntSet as IntSet
+import           Data.Loc
+import qualified Data.Map as Map
+import           Data.Monoid (Alt(..))
+import           Data.Name
+import           Prelude hiding (fail)
+
+type Precise = Int
+type Env = Map.Map Name Precise
+
+newtype FrameId = FrameId { unFrameId :: Precise }
+  deriving (Eq, Ord, Show)
+
+data Concrete
+  = Closure Loc Name Core.Core Precise
+  | Unit
+  | Bool Bool
+  | String String
+  | Obj Frame
+  deriving (Eq, Ord, Show)
+
+objectFrame :: Concrete -> Maybe Frame
+objectFrame (Obj frame) = Just frame
+objectFrame _           = Nothing
+
+data Frame = Frame
+  { frameEdges :: [(Core.Edge, Precise)]
+  , frameSlots :: Env
+  }
+  deriving (Eq, Ord, Show)
+
+type Heap = IntMap.IntMap Concrete
+
+
+-- | Concrete evaluation of a term to a value.
+--
+--   >>> snd (concrete [File (Loc "bool" emptySpan) (Core.Bool True)])
+--   [Right (Bool True)]
+concrete :: [File Core.Core] -> (Heap, [File (Either (Loc, String) Concrete)])
+concrete
+  = run
+  . runFresh
+  . runHeap
+  . traverse runFile
+
+runFile :: ( Carrier sig m
+           , Effect sig
+           , Member Fresh sig
+           , Member (Reader FrameId) sig
+           , Member (State Heap) sig
+           )
+        => File Core.Core
+        -> m (File (Either (Loc, String) Concrete))
+runFile file = traverse run file
+  where run = runReader (fileLoc file)
+            . runFailWithLoc
+            . fix (eval concreteAnalysis)
+
+concreteAnalysis :: ( Carrier sig m
+                    , Member Fresh sig
+                    , Member (Reader Loc) sig
+                    , Member (Reader FrameId) sig
+                    , Member (State Heap) sig
+                    , MonadFail m
+                    )
+                 => Analysis Precise Concrete m
+concreteAnalysis = Analysis{..}
+  where alloc _ = fresh
+        bind name addr = modifyCurrentFrame (updateFrameSlots (Map.insert name addr))
+        lookupEnv n = do
+          FrameId frameAddr <- ask
+          val <- deref frameAddr
+          heap <- get
+          pure (val >>= lookupConcrete heap n)
+        deref = gets . IntMap.lookup
+        assign addr value = modify (IntMap.insert addr value)
+        abstract _ name body = do
+          loc <- ask
+          FrameId parentAddr <- ask
+          pure (Closure loc name body parentAddr)
+        apply eval (Closure loc name body parentAddr) a = do
+          frameAddr <- fresh
+          assign frameAddr (Obj (Frame [(Core.Lexical, parentAddr)] mempty))
+          local (const loc) . (frameAddr ...) $ do
+            addr <- alloc name
+            assign addr a
+            bind name addr
+            eval body
+        apply _ f _ = fail $ "Cannot coerce " <> show f <> " to function"
+        unit = pure Unit
+        bool b = pure (Bool b)
+        asBool (Bool b) = pure b
+        asBool v        = fail $ "Cannot coerce " <> show v <> " to Bool"
+        string s = pure (String s)
+        asString (String s) = pure s
+        asString v          = fail $ "Cannot coerce " <> show v <> " to String"
+        -- FIXME: differential inheritance (reference fields instead of copying)
+        -- FIXME: copy non-lexical parents deeply?
+        frame = do
+          lexical <- asks unFrameId
+          pure (Obj (Frame [(Core.Lexical, lexical)] mempty))
+        -- FIXME: throw an error
+        -- FIXME: support dynamic imports
+        edge e addr = modifyCurrentFrame (\ (Frame ps fs) -> Frame ((e, addr) : ps) fs)
+        addr ... m = local (const (FrameId addr)) m
+
+        updateFrameSlots f frame = frame { frameSlots = f (frameSlots frame) }
+
+        modifyCurrentFrame f = do
+          addr <- asks unFrameId
+          Just (Obj frame) <- deref addr
+          assign addr (Obj (f frame))
+
+
+lookupConcrete :: Heap -> Name -> Concrete -> Maybe Precise
+lookupConcrete heap name = run . evalState IntSet.empty . runNonDet . inConcrete
+  where -- look up the name in a concrete value
+        inConcrete = inFrame <=< maybeA . objectFrame
+        -- look up the name in a specific 'Frame', with slots taking precedence over parents
+        inFrame (Frame ps fs) = maybeA (Map.lookup name fs) <|> getAlt (foldMap (Alt . inAddress . snd) ps)
+        -- look up the name in the value an address points to, if we haven’t already visited it
+        inAddress addr = do
+          visited <- get
+          guard (addr `IntSet.notMember` visited)
+          -- FIXME: throw an error if we can’t deref @addr@
+          val <- maybeA (IntMap.lookup addr heap)
+          modify (IntSet.insert addr)
+          inConcrete val
+        maybeA = maybe empty pure
+
+
+runHeap :: (Carrier sig m, Member Fresh sig) => ReaderC FrameId (StateC Heap m) a -> m (Heap, a)
+runHeap m = do
+  addr <- fresh
+  runState (IntMap.singleton addr (Obj (Frame [] mempty))) (runReader (FrameId addr) m)
+
+
+-- | 'heapGraph', 'heapValueGraph', and 'heapAddressGraph' allow us to conveniently export SVGs of the heap:
+--
+--   > λ 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 Core.Edge Name -> Precise -> G.Graph a) -> Heap -> 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
+          Unit -> G.empty
+          Bool _ -> G.empty
+          String _ -> G.empty
+          Closure _ _ _ parentAddr -> edge (Left Core.Lexical) parentAddr
+          Obj frame -> fromFrame frame
+        fromFrame (Frame es ss) = foldr (G.overlay . uncurry (edge . Left)) (foldr (G.overlay . uncurry (edge . Right)) G.empty (Map.toList ss)) es
+
+heapValueGraph :: Heap -> G.Graph Concrete
+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 = heapGraph (\ addr v -> (Value v, addr)) (fmap G.vertex . (,) . either Edge Slot)
+
+addressStyle :: Heap -> G.Style (EdgeType, Precise) String
+addressStyle heap = (G.defaultStyle vertex) { G.edgeAttributes }
+  where vertex (_, addr) = maybe (show addr <> " = ?") (((show addr <> " = ") <>) . fromConcrete) (IntMap.lookup addr heap)
+        edgeAttributes _ (Slot name,         _) = ["label" G.:= fromName name]
+        edgeAttributes _ (Edge Core.Import,  _) = ["color" G.:= "blue"]
+        edgeAttributes _ (Edge Core.Lexical, _) = ["color" G.:= "green"]
+        edgeAttributes _ _                      = []
+        fromConcrete = \case
+          Unit ->  "()"
+          Bool b -> show b
+          String s -> show s
+          Closure (Loc p (Span s e)) n _ _ -> "\\\\ " <> fromName n <> " [" <> p <> ":" <> showPos s <> "-" <> showPos e <> "]"
+          Obj _ -> "{}"
+        showPos (Pos l c) = show l <> ":" <> show c
+        fromName (User s)  = s
+        fromName (Gen sym) = fromGensym sym
+        fromName (Path p)  = show p
+        fromGensym (Root s) = s
+        fromGensym (ss :/ (s, i)) = fromGensym ss <> "." <> s <> show i
+
+data EdgeType
+  = Edge Core.Edge
+  | Slot Name
+  | Value Concrete
+  deriving (Eq, Ord, Show)

semantic-core/src/Analysis/Eval.hs

@@ -0,0 +1,215 @@
+{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, LambdaCase, RankNTypes, RecordWildCards #-}
+module Analysis.Eval
+( eval
+, prog1
+, prog2
+, prog3
+, prog4
+, prog5
+, prog6
+, ruby
+, Analysis(..)
+) where
+
+import Control.Effect
+import Control.Effect.Fail
+import Control.Effect.Reader
+import Control.Monad ((>=>))
+import Data.Core as Core
+import Data.File
+import Data.Functor
+import Data.Loc
+import Data.Maybe (fromJust)
+import Data.Name
+import GHC.Stack
+import Prelude hiding (fail)
+
+eval :: (Carrier sig m, Member (Reader Loc) sig, MonadFail m) => Analysis address value m -> (Core -> m value) -> Core -> m value
+eval Analysis{..} eval = \case
+  Var n -> lookupEnv' n >>= deref' n
+  Let n -> alloc n >>= bind n >> unit
+  a :>> b -> eval a >> eval b
+  Lam n b -> abstract eval n b
+  f :$ a -> do
+    f' <- eval f
+    a' <- eval a
+    apply eval f' a'
+  Unit -> unit
+  Bool b -> bool b
+  If c t e -> do
+    c' <- eval c >>= asBool
+    if c' then eval t else eval e
+  String s -> string s
+  Load p -> do
+    path <- eval p >>= asString
+    lookupEnv' (Path path) >>= deref' (Path path)
+  Edge e a -> ref a >>= edge e >> unit
+  Frame -> frame
+  a :. b -> do
+    a' <- ref a
+    a' ... eval b
+  a := b -> do
+    b' <- eval b
+    addr <- ref a
+    b' <$ assign addr b'
+  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)
+
+        lookupEnv' n = lookupEnv n >>= maybe (freeVariable (show n)) pure
+        deref' n = deref >=> maybe (uninitialized (show n)) pure
+
+        ref = \case
+          Var n -> lookupEnv' n
+          Let n -> do
+            addr <- alloc n
+            addr <$ bind n addr
+          If c t e -> do
+            c' <- eval c >>= asBool
+            if c' then ref t else ref e
+          a :. b -> do
+            a' <- ref a
+            a' ... ref b
+          Ann loc c -> local (const loc) (ref c)
+          c -> invalidRef (show c)
+
+
+prog1 :: File Core
+prog1 = fromBody $ Lam foo
+  (   Let bar := Var foo
+  :>> If (Var bar)
+    (Bool False)
+    (Bool True))
+  where (foo, bar) = (User "foo", User "bar")
+
+prog2 :: File Core
+prog2 = fromBody $ fileBody prog1 :$ Bool True
+
+prog3 :: File Core
+prog3 = fromBody $ lams [foo, bar, quux]
+  (If (Var quux)
+    (Var bar)
+    (Var foo))
+  where (foo, bar, quux) = (User "foo", User "bar", User "quux")
+
+prog4 :: File Core
+prog4 = fromBody
+  $   Let foo := Bool True
+  :>> If (Var foo)
+    (Bool True)
+    (Bool False)
+  where foo = User "foo"
+
+prog5 :: File Core
+prog5 = fromBody
+  $   Let (User "mkPoint") := Lam (User "_x") (Lam (User "_y")
+    (   Let (User "x") := Var (User "_x")
+    :>> Let (User "y") := Var (User "_y")))
+  :>> Let (User "point") := Var (User "mkPoint") :$ Bool True :$ Bool False
+  :>> Var (User "point") :. Var (User "x")
+  :>> Var (User "point") :. Var (User "y") := Var (User "point") :. Var (User "x")
+
+prog6 :: [File Core]
+prog6 =
+  [ File (Loc "dep"  (locSpan (fromJust here))) $ block
+    [ Let (Path "dep") := Frame
+    , Var (Path "dep") :. block
+      [ Let (User "var") := Bool True
+      ]
+    ]
+  , File (Loc "main" (locSpan (fromJust here))) $ block
+    [ Load (String "dep")
+    , Let (User "thing") := Var (Path "dep") :. Var (User "var")
+    ]
+  ]
+
+ruby :: File Core
+ruby = fromBody . ann . block $
+  [ ann (Let (User "Class") := Frame)
+  , ann (Var (User "Class") :.
+    (ann (Let (User "new") := Lam (User "self") (block
+      [ ann (Let (User "instance") := Frame)
+      , ann (Var (User "instance") :. Edge Import (Var (User "self")))
+      , ann (Var (User "instance") $$ "initialize")
+      ]))))
+
+  , ann (Let (User "(Object)") := Frame)
+  , ann (Var (User "(Object)") :. ann (Edge Import (Var (User "Class"))))
+  , ann (Let (User "Object") := Frame)
+  , ann (Var (User "Object") :. block
+    [ ann (Edge Import (Var (User "(Object)")))
+    , ann (Let (User "nil?") := Lam (User "_") false)
+    , ann (Let (User "initialize") := Lam (User "self") (Var (User "self")))
+    , ann (Let __semantic_truthy := Lam (User "_") (Bool True))
+    ])
+
+  , ann (Var (User "Class") :. Edge Import (Var (User "Object")))
+
+  , ann (Let (User "(NilClass)") := Frame)
+  , ann (Var (User "(NilClass)") :. block
+    [ ann (Edge Import (Var (User "Class")))
+    , ann (Edge Import (Var (User "(Object)")))
+    ])
+  , ann (Let (User "NilClass") := Frame)
+  , ann (Var (User "NilClass") :. block
+    [ ann (Edge Import (Var (User "(NilClass)")))
+    , ann (Edge Import (Var (User "Object")))
+    , ann (Let (User "nil?") := Lam (User "_") true)
+    , ann (Let __semantic_truthy := Lam (User "_") (Bool False))
+    ])
+
+  , ann (Let (User "(TrueClass)") := Frame)
+  , ann (Var (User "(TrueClass)") :. block
+    [ ann (Edge Import (Var (User "Class")))
+    , ann (Edge Import (Var (User "(Object)")))
+    ])
+  , ann (Let (User "TrueClass") := Frame)
+  , ann (Var (User "TrueClass") :. block
+    [ ann (Edge Import (Var (User "(TrueClass)")))
+    , ann (Edge Import (Var (User "Object")))
+    ])
+
+  , ann (Let (User "(FalseClass)") := Frame)
+  , ann (Var (User "(FalseClass)") :. block
+    [ ann (Edge Import (Var (User "Class")))
+    , ann (Edge Import (Var (User "(Object)")))
+    ])
+  , ann (Let (User "FalseClass") := Frame)
+  , ann (Var (User "FalseClass") :. block
+    [ ann (Edge Import (Var (User "(FalseClass)")))
+    , ann (Edge Import (Var (User "Object")))
+    , ann (Let __semantic_truthy := Lam (User "_") (Bool False))
+    ])
+
+  , ann (Let (User "nil")   := Var (User "NilClass")   $$ "new")
+  , ann (Let (User "true")  := Var (User "TrueClass")  $$ "new")
+  , ann (Let (User "false") := Var (User "FalseClass") $$ "new")
+
+  , ann (Let (User "require") := Lam (User "path") (Load (Var (User "path"))))
+  ]
+  where _nil  = Var (User "nil")
+        true  = Var (User "true")
+        false = Var (User "false")
+        self $$ method = annWith callStack $ Lam (User "_x") (Var (User "_x") :. Var (User method) :$ Var (User "_x")) :$ self
+
+        __semantic_truthy = User "__semantic_truthy"
+
+
+data Analysis address value m = Analysis
+  { alloc       :: Name -> m address
+  , bind        :: Name -> address -> m ()
+  , lookupEnv   :: Name -> m (Maybe address)
+  , deref       :: address -> m (Maybe value)
+  , assign      :: address -> value -> m ()
+  , abstract    :: (Core -> m value) -> Name -> Core -> m value
+  , apply       :: (Core -> m value) -> value -> value -> m value
+  , unit        :: m value
+  , bool        :: Bool -> m value
+  , asBool      :: value -> m Bool
+  , string      :: String -> m value -- FIXME: Text
+  , asString    :: value -> m String
+  , frame       :: m value
+  , edge        :: Edge -> address -> m ()
+  , (...)       :: forall a . address -> m a -> m a
+  }

semantic-core/src/Analysis/FlowInsensitive.hs

@@ -0,0 +1,91 @@
+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
+module Analysis.FlowInsensitive
+( Heap
+, FrameId(..)
+, convergeTerm
+, cacheTerm
+, runHeap
+, foldMapA
+) where
+
+import           Control.Effect
+import           Control.Effect.Fresh
+import           Control.Effect.NonDet
+import           Control.Effect.Reader
+import           Control.Effect.State
+import qualified Data.Core as Core
+import qualified Data.Map as Map
+import           Data.Maybe (fromMaybe)
+import           Data.Monoid (Alt(..))
+import           Data.Name
+import qualified Data.Set as Set
+
+type Cache a = Map.Map Core.Core (Set.Set a)
+type Heap a = Map.Map Name (Set.Set a)
+
+newtype FrameId = FrameId { unFrameId :: Name }
+  deriving (Eq, Ord, Show)
+
+
+convergeTerm :: forall m sig a
+             .  ( Carrier sig m
+                , Effect sig
+                , Member Fresh sig
+                , Member (State (Heap a)) sig
+                , Ord a
+                )
+             => (Core.Core -> NonDetC (ReaderC (Cache a) (StateC (Cache a) m)) a)
+             -> Core.Core
+             -> m (Set.Set a)
+convergeTerm eval body = do
+  heap <- get
+  (cache, _) <- converge (Map.empty :: Cache a, heap :: Heap a) $ \ (prevCache, _) -> runState Map.empty . runReader prevCache $ do
+    _ <- resetFresh . runNonDetM Set.singleton $ eval body
+    get
+  pure (fromMaybe mempty (Map.lookup body cache))
+
+cacheTerm :: forall m sig a
+          .  ( Alternative m
+             , Carrier sig m
+             , Member (Reader (Cache a)) sig
+             , Member (State  (Cache a)) sig
+             , Ord a
+             )
+          => (Core.Core -> m a)
+          -> (Core.Core -> m a)
+cacheTerm eval term = do
+  cached <- gets (Map.lookup term)
+  case cached :: Maybe (Set.Set a) of
+    Just results -> foldMapA pure results
+    Nothing -> do
+      results <- asks (fromMaybe mempty . Map.lookup term)
+      modify (Map.insert term (results :: Set.Set a))
+      result <- eval term
+      result <$ modify (Map.insertWith (<>) term (Set.singleton (result :: a)))
+
+runHeap :: (Carrier sig m, Member Naming sig) => ReaderC FrameId (StateC (Heap a) m) b -> m (Heap a, b)
+runHeap m = do
+  addr <- Gen <$> gensym "root"
+  runState (Map.singleton addr Set.empty) (runReader (FrameId addr) m)
+
+-- | Fold a collection by mapping each element onto an 'Alternative' action.
+foldMapA :: (Alternative m, Foldable t) => (b -> m a) -> t b -> m a
+foldMapA f = getAlt . foldMap (Alt . f)
+
+runNonDetM :: (Monoid b, Applicative m) => (a -> b) -> NonDetC m a -> m b
+runNonDetM f (NonDetC m) = m (fmap . (<>) . f) (pure mempty)
+
+-- | Iterate a monadic action starting from some initial seed until the results converge.
+--
+--   This applies the Kleene fixed-point theorem to finitize a monotone action. cf https://en.wikipedia.org/wiki/Kleene_fixed-point_theorem
+converge :: (Eq a, Monad m)
+         => a          -- ^ An initial seed value to iterate from.
+         -> (a -> m a) -- ^ A monadic action to perform at each iteration, starting from the result of the previous iteration or from the seed value for the first iteration.
+         -> m a        -- ^ A computation producing the least fixed point (the first value at which the actions converge).
+converge seed f = loop seed
+  where loop x = do
+          x' <- f x
+          if x' == x then
+            pure x
+          else
+            loop x'

semantic-core/src/Analysis/ImportGraph.hs

@@ -0,0 +1,107 @@
+{-# LANGUAGE FlexibleContexts, RecordWildCards #-}
+module Analysis.ImportGraph
+( ImportGraph
+, importGraph
+, importGraphAnalysis
+) where
+
+import           Analysis.Eval
+import           Analysis.FlowInsensitive
+import           Control.Applicative (Alternative(..))
+import           Control.Effect
+import           Control.Effect.Fail
+import           Control.Effect.Fresh
+import           Control.Effect.Reader
+import           Control.Effect.State
+import qualified Data.Core as Core
+import           Data.File
+import           Data.Foldable (fold)
+import           Data.Function (fix)
+import           Data.List.NonEmpty (nonEmpty)
+import           Data.Loc
+import qualified Data.Map as Map
+import           Data.Name
+import qualified Data.Set as Set
+import           Prelude hiding (fail)
+
+type ImportGraph = Map.Map FilePath (Set.Set FilePath)
+
+data Value = Value
+  { valueSemi  :: Semi
+  , valueGraph :: ImportGraph
+  }
+  deriving (Eq, Ord, Show)
+
+instance Semigroup Value where
+  Value _ g1 <> Value _ g2 = Value Abstract (Map.unionWith (<>) g1 g2)
+
+instance Monoid Value where
+  mempty = Value Abstract mempty
+
+data Semi
+  = Closure Loc Name Core.Core Name
+  -- FIXME: Bound String values.
+  | String String
+  | Abstract
+  deriving (Eq, Ord, Show)
+
+
+importGraph :: [File Core.Core] -> (Heap Value, [File (Either (Loc, String) Value)])
+importGraph
+  = run
+  . runFresh
+  . runNaming (Root "import-graph")
+  . runHeap
+  . traverse runFile
+
+runFile :: ( Carrier sig m
+           , Effect sig
+           , Member Fresh sig
+           , Member (Reader FrameId) sig
+           , Member (State (Heap Value)) sig
+           )
+        => File Core.Core
+        -> m (File (Either (Loc, String) Value))
+runFile file = traverse run file
+  where run = runReader (fileLoc file)
+            . runFailWithLoc
+            . fmap fold
+            . convergeTerm (fix (cacheTerm . eval importGraphAnalysis))
+
+-- FIXME: decompose into a product domain and two atomic domains
+importGraphAnalysis :: ( Alternative m
+                       , Carrier sig m
+                       , Member (Reader FrameId) sig
+                       , Member (Reader Loc) sig
+                       , Member (State (Heap Value)) sig
+                       , MonadFail m
+                       )
+                    => Analysis Name Value m
+importGraphAnalysis = Analysis{..}
+  where alloc = pure
+        bind _ _ = pure ()
+        lookupEnv = pure . Just
+        deref addr = gets (Map.lookup addr) >>= maybe (pure Nothing) (foldMapA (pure . Just)) . nonEmpty . maybe [] Set.toList
+        assign addr ty = modify (Map.insertWith (<>) addr (Set.singleton ty))
+        abstract _ name body = do
+          loc <- ask
+          FrameId parentAddr <- ask
+          pure (Value (Closure loc name body parentAddr) mempty)
+        apply eval (Value (Closure loc name body _) _) a = local (const loc) $ do
+          addr <- alloc name
+          assign addr a
+          bind name addr
+          eval body
+        apply _ f _ = fail $ "Cannot coerce " <> show f <> " to function"
+        unit = pure mempty
+        bool _ = pure mempty
+        asBool _ = pure True <|> pure False
+        string s = pure (Value (String s) mempty)
+        asString (Value (String s) _) = pure s
+        asString _ = pure ""
+        frame = pure mempty
+        edge Core.Import (Path to) = do
+          Loc{locPath=from} <- ask
+          () <$ pure (Value Abstract (Map.singleton from (Set.singleton to)))
+        edge _ _ = pure ()
+        _ ... m = m

semantic-core/src/Analysis/ScopeGraph.hs

@@ -0,0 +1,15 @@
+module Analysis.ScopeGraph
+( ScopeGraph
+, Entry(..)
+) where
+
+import           Data.Loc
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+data Entry = Entry
+  { entrySymbol :: String -- FIXME: Text
+  , entryLoc    :: Loc
+  }
+
+type ScopeGraph = Map.Map Entry (Set.Set Entry)

semantic-core/src/Analysis/Typecheck.hs

@@ -0,0 +1,256 @@
+{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, LambdaCase, RecordWildCards, ScopedTypeVariables, TypeApplications #-}
+module Analysis.Typecheck
+( Monotype (..)
+, Meta
+, Polytype (PForAll, PBool, PFree, PArr)
+, Scope
+, Analysis.Typecheck.bind
+, Analysis.Typecheck.instantiate
+, typecheckingFlowInsensitive
+, typecheckingAnalysis
+) where
+
+import           Analysis.Eval
+import           Analysis.FlowInsensitive
+import           Control.Applicative (Alternative (..))
+import           Control.Effect
+import           Control.Effect.Fail
+import           Control.Effect.Fresh
+import           Control.Effect.Reader hiding (Local)
+import           Control.Effect.State
+import           Control.Monad (unless)
+import qualified Data.Core as Core
+import           Data.File
+import           Data.Foldable (foldl', for_)
+import           Data.Function (fix)
+import           Data.Functor (($>))
+import qualified Data.IntMap as IntMap
+import qualified Data.IntSet as IntSet
+import           Data.List.NonEmpty (nonEmpty)
+import           Data.Loc
+import qualified Data.Map as Map
+import           Data.Name
+import qualified Data.Set as Set
+import           Prelude hiding (fail)
+
+data Monotype a
+  = MBool
+  | MUnit
+  | MString
+  | MMeta a
+  | MFree Gensym
+  | MArr (Monotype a) (Monotype a)
+  | MRecord (Map.Map User (Monotype a))
+  deriving (Eq, Functor, Ord, Show)
+
+type Meta = Int
+
+data Polytype
+  = PForAll Scope
+  | PUnit
+  | PBool
+  | PString
+  | PBound Int
+  | PFree Gensym
+  | PArr Polytype Polytype
+  | PRecord (Map.Map User Polytype)
+  deriving (Eq, Ord, Show)
+
+newtype Scope = Scope Polytype
+  deriving (Eq, Ord, Show)
+
+forAll :: Gensym -> Polytype -> Polytype
+forAll n body = PForAll (Analysis.Typecheck.bind n body)
+
+forAlls :: Foldable t => t Gensym -> Polytype -> Polytype
+forAlls ns body = foldr forAll body ns
+
+generalize :: (Carrier sig m, Member Naming sig) => Monotype Meta -> m Polytype
+generalize ty = namespace "generalize" $ do
+  root <- gensym ""
+  pure (forAlls (map ((root :/) . (,) "") (IntSet.toList (mvs ty))) (fold root ty))
+  where fold root = \case
+          MUnit      -> PUnit
+          MBool      -> PBool
+          MString    -> PString
+          MMeta i    -> PFree (root :/ ("", i))
+          MFree n    -> PFree n
+          MArr a b   -> PArr (fold root a) (fold root b)
+          MRecord fs -> PRecord (fold root <$> fs)
+
+-- | Bind occurrences of a 'Gensym' in a 'Polytype' term, producing a 'Scope' in which the 'Gensym' is bound.
+bind :: Gensym -> Polytype -> Scope
+bind name = Scope . substIn (\ i n -> if name == n then PBound i else PFree n) (const PBound)
+
+-- | Substitute a 'Polytype' term for the free variable in a given 'Scope', producing a closed 'Polytype' term.
+instantiate :: Polytype -> Scope -> Polytype
+instantiate image (Scope body) = substIn (const PFree) (\ i j -> if i == j then image else PBound j) body
+
+substIn :: (Int -> Gensym -> Polytype)
+        -> (Int -> Int -> Polytype)
+        -> Polytype
+        -> Polytype
+substIn free bound = go 0
+  where go i (PFree name)           = free i name
+        go i (PBound j)             = bound i j
+        go i (PForAll (Scope body)) = PForAll (Scope (go (succ i) body))
+        go _ PUnit                  = PUnit
+        go _ PBool                  = PBool
+        go _ PString                = PString
+        go i (PArr a b)             = PArr (go i a) (go i b)
+        go i (PRecord fs)           = PRecord (go i <$> fs)
+
+
+typecheckingFlowInsensitive :: [File Core.Core] -> (Heap (Monotype Meta), [File (Either (Loc, String) Polytype)])
+typecheckingFlowInsensitive
+  = run
+  . runFresh
+  . runNaming (Root "typechecking-flow-insensitive")
+  . runHeap
+  . (>>= traverse (traverse (traverse generalize)))
+  . traverse runFile
+
+runFile :: ( Carrier sig m
+           , Effect sig
+           , Member Fresh sig
+           , Member (State (Heap (Monotype Meta))) sig
+           )
+        => File Core.Core
+        -> m (File (Either (Loc, String) (Monotype Meta)))
+runFile file = traverse run file
+  where run
+          = (\ m -> do
+              (subst, t) <- m
+              modify @(Heap (Monotype Meta)) (substAll subst)
+              pure (substAll subst <$> t))
+          . runState (mempty :: Substitution)
+          . runReader (fileLoc file)
+          . runFailWithLoc
+          . (\ m -> do
+            (cs, t) <- m
+            t <$ solve cs)
+          . runState (Set.empty :: Set.Set Constraint)
+          . (\ m -> do
+              v <- meta
+              bs <- m
+              v <$ for_ bs (unify v))
+          . convergeTerm (fix (cacheTerm . eval typecheckingAnalysis))
+
+typecheckingAnalysis :: (Alternative m, Carrier sig m, Member Fresh sig, Member (State (Set.Set Constraint)) sig, Member (State (Heap (Monotype Meta))) sig, MonadFail m) => Analysis Name (Monotype Meta) m
+typecheckingAnalysis = Analysis{..}
+  where alloc = pure
+        bind _ _ = pure ()
+        lookupEnv = pure . Just
+        deref addr = gets (Map.lookup addr) >>= maybe (pure Nothing) (foldMapA (pure . Just)) . nonEmpty . maybe [] Set.toList
+        assign addr ty = modify (Map.insertWith (<>) addr (Set.singleton ty))
+        abstract eval name body = do
+          -- FIXME: construct the associated scope
+          addr <- alloc name
+          arg <- meta
+          assign addr arg
+          ty <- eval body
+          pure (MArr arg ty)
+        apply _ f a = do
+          _A <- meta
+          _B <- meta
+          unify (MArr _A _B) f
+          unify _A a
+          pure _B
+        unit = pure MUnit
+        bool _ = pure MBool
+        asBool b = unify MBool b >> pure True <|> pure False
+        string _ = pure MString
+        asString s = unify MString s *> pure ""
+        frame = fail "unimplemented"
+        edge _ _ = pure ()
+        _ ... m = m
+
+
+data Constraint = Monotype Meta :===: Monotype Meta
+  deriving (Eq, Ord, Show)
+
+infix 4 :===:
+
+data Solution
+  = Int := Monotype Meta
+  deriving (Eq, Ord, Show)
+
+infix 5 :=
+
+meta :: (Carrier sig m, Member Fresh sig) => m (Monotype Meta)
+meta = MMeta <$> fresh
+
+unify :: (Carrier sig m, Member (State (Set.Set Constraint)) sig) => Monotype Meta -> Monotype Meta -> m ()
+unify t1 t2
+  | t1 == t2  = pure ()
+  | otherwise = modify (<> Set.singleton (t1 :===: t2))
+
+type Substitution = IntMap.IntMap (Monotype Meta)
+
+solve :: (Carrier sig m, Member (State Substitution) sig, MonadFail m) => Set.Set Constraint -> m ()
+solve cs = for_ cs solve
+  where solve = \case
+          -- FIXME: how do we enforce proper subtyping? row polymorphism or something?
+          MRecord f1 :===: MRecord f2 -> traverse solve (Map.intersectionWith (:===:) f1 f2) $> ()
+          MArr a1 b1 :===: MArr a2 b2 -> solve (a1 :===: a2) *> solve (b1 :===: b2)
+          MMeta m1   :===: MMeta m2   | m1 == m2 -> pure ()
+          MMeta m1   :===: t2         -> do
+            sol <- solution m1
+            case sol of
+              Just (_ := t1) -> solve (t1 :===: t2)
+              Nothing | m1 `IntSet.member` mvs t2 -> fail ("Occurs check failure: " <> show m1 <> " :===: " <> show t2)
+                      | otherwise                 -> modify (IntMap.insert m1 t2 . subst (m1 := t2))
+          t1         :===: MMeta m2   -> solve (MMeta m2 :===: t1)
+          t1         :===: t2         -> unless (t1 == t2) $ fail ("Type mismatch:\nexpected: " <> show t1 <> "\n  actual: " <> show t2)
+
+        solution m = fmap (m :=) <$> gets (IntMap.lookup m)
+
+substAll :: Substitutable t => Substitution -> t -> t
+substAll s a = foldl' (flip subst) a (map (uncurry (:=)) (IntMap.toList s))
+
+
+class FreeVariables t where
+  mvs :: t -> IntSet.IntSet
+
+instance FreeVariables (Monotype Meta) where
+  mvs MUnit        = mempty
+  mvs MBool        = mempty
+  mvs MString      = mempty
+  mvs (MArr a b)   = mvs a <> mvs b
+  mvs (MMeta m)    = IntSet.singleton m
+  mvs (MFree _)    = mempty
+  mvs (MRecord fs) = foldMap mvs fs
+
+instance FreeVariables Constraint where
+  mvs (t1 :===: t2) = mvs t1 <> mvs t2
+
+class Substitutable t where
+  subst :: Solution -> t -> t
+
+instance Substitutable (Monotype Meta) where
+  subst s con = case con of
+    MUnit         -> MUnit
+    MBool         -> MBool
+    MString       -> MString
+    MArr a b      -> MArr (subst s a) (subst s b)
+    MMeta m'
+      | m := t <- s
+      , m == m'   -> t
+      | otherwise -> MMeta m'
+    MFree n       -> MFree n
+    MRecord fs    -> MRecord (subst s <$> fs)
+
+instance Substitutable Constraint where
+  subst s (t1 :===: t2) = subst s t1 :===: subst s t2
+
+instance Substitutable Solution where
+  subst s (m := t) = m := subst s t
+
+instance Substitutable a => Substitutable (IntMap.IntMap a) where
+  subst s = IntMap.map (subst s)
+
+instance (Ord a, Substitutable a) => Substitutable (Set.Set a) where
+  subst s = Set.map (subst s)
+
+instance Substitutable v => Substitutable (Map.Map k v) where
+  subst s = fmap (subst s)

semantic-core/src/Control/Effect/Readline.hs

@@ -0,0 +1,121 @@
+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, OverloadedStrings, RankNTypes, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-}
+
+module Control.Effect.Readline
+( Readline (..)
+, prompt
+, print
+, println
+, askLine
+, Line (..)
+, increment
+, ReadlineC (..)
+, runReadline
+, runReadlineWithHistory
+, TransC (..)
+, ControlIOC (..)
+, runControlIO
+) where
+
+import Prelude hiding (print)
+
+import Control.Effect.Carrier
+import Control.Effect.Reader
+import Control.Effect.Sum
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Data.Coerce
+import Data.Int
+import Data.String
+import Data.Text.Prettyprint.Doc
+import Data.Text.Prettyprint.Doc.Render.Text
+import System.Console.Haskeline hiding (Handler, handle)
+import System.Directory
+import System.FilePath
+
+data Readline (m :: * -> *) k
+  = Prompt String (Maybe String -> k)
+  | forall a . Print (Doc a) k
+  | AskLine (Line -> k)
+
+deriving instance Functor (Readline m)
+
+instance HFunctor Readline where
+  hmap _ = coerce
+
+instance Effect Readline where
+  handle state handler = coerce . fmap (handler . (<$ state))
+
+prompt :: (IsString str, Member Readline sig, Carrier sig m) => String -> m (Maybe str)
+prompt p = fmap fromString <$> send (Prompt p pure)
+
+print :: (Pretty a, Carrier sig m, Member Readline sig) => a -> m ()
+print s = send (Print (pretty s) (pure ()))
+
+println :: (Pretty a, Carrier sig m, Member Readline sig) => a -> m ()
+println s = print s >> print @String "\n"
+
+askLine :: (Carrier sig m, Member Readline sig) => m Line
+askLine = send (AskLine pure)
+
+newtype Line = Line Int64
+
+increment :: Line -> Line
+increment (Line n) = Line (n + 1)
+
+newtype ReadlineC m a = ReadlineC { runReadlineC :: ReaderC Line (TransC InputT m) a }
+  deriving (Applicative, Functor, Monad, MonadIO)
+
+runReadline :: MonadException m => Prefs -> Settings m -> ReadlineC m a -> m a
+runReadline prefs settings = runInputTWithPrefs prefs settings . runTransC . runReader (Line 0) . runReadlineC
+
+instance (Carrier sig m, Effect sig, MonadException m, MonadIO m) => Carrier (Readline :+: sig) (ReadlineC m) where
+  eff (L (Prompt prompt k)) = ReadlineC $ do
+    str <- lift (TransC (getInputLine (cyan <> prompt <> plain)))
+    local increment (runReadlineC (k str))
+    where cyan = "\ESC[1;36m\STX"
+          plain = "\ESC[0m\STX"
+  eff (L (Print text k)) = liftIO (putDoc text) *> k
+  eff (L (AskLine k)) = ReadlineC ask >>= k
+  eff (R other) = ReadlineC (eff (R (handleCoercible other)))
+
+runReadlineWithHistory :: MonadException m => ReadlineC m a -> m a
+runReadlineWithHistory block = do
+  homeDir <- liftIO $ getHomeDirectory
+  prefs <- liftIO $ readPrefs (homeDir </> ".haskeline")
+  let settingsDir = homeDir </> ".local/semantic-core"
+      settings = Settings
+        { complete = noCompletion
+        , historyFile = Just (settingsDir <> "/repl_history")
+        , autoAddHistory = True
+        }
+  liftIO $ createDirectoryIfMissing True settingsDir
+
+  runReadline prefs settings block
+
+-- | Promote a monad transformer into an effect.
+newtype TransC t (m :: * -> *) a = TransC { runTransC :: t m a }
+  deriving (Applicative, Functor, Monad, MonadIO, MonadTrans)
+
+instance (Carrier sig m, Effect sig, Monad (t m), MonadTrans t) => Carrier sig (TransC t m) where
+  eff = TransC . join . lift . eff . handle (pure ()) (pure . (runTransC =<<))
+
+runControlIO :: (forall x . m x -> IO x) -> ControlIOC m a -> m a
+runControlIO handler = runReader (Handler handler) . runControlIOC
+
+-- | This exists to work around the 'MonadException' constraint that haskeline entails.
+newtype ControlIOC m a = ControlIOC { runControlIOC :: ReaderC (Handler m) m a }
+  deriving (Applicative, Functor, Monad, MonadIO)
+
+newtype Handler m = Handler (forall x . m x -> IO x)
+
+runHandler :: Handler m -> ControlIOC m a -> IO a
+runHandler h@(Handler handler) = handler . runReader h . runControlIOC
+
+instance Carrier sig m => Carrier sig (ControlIOC m) where
+  eff op = ControlIOC (eff (R (handleCoercible op)))
+
+instance (Carrier sig m, MonadIO m) => MonadException (ControlIOC m) where
+  controlIO f = ControlIOC $ do
+    handler <- ask
+    liftIO (f (RunIO (fmap pure . runHandler handler)) >>= runHandler handler)

semantic-core/src/Data/Core.hs

@@ -0,0 +1,126 @@
+{-# LANGUAGE DeriveTraversable, FlexibleContexts, LambdaCase, OverloadedStrings, RecordWildCards #-}
+module Data.Core
+( Core(..)
+, Edge(..)
+, showCore
+, lams
+, ($$*)
+, unapply
+, unapplies
+, block
+, ann
+, annWith
+) where
+
+import           Control.Applicative (Alternative (..))
+import           Data.Foldable (foldl')
+import           Data.Loc
+import           Data.Name
+import           Data.Stack
+import           Data.Text.Prettyprint.Doc (Pretty (..), (<+>), vsep)
+import qualified Data.Text.Prettyprint.Doc as Pretty
+import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty
+import           GHC.Stack
+
+data Core
+  = Var Name
+  | Let Name
+  -- | Sequencing without binding; analogous to '>>' or '*>'.
+  | Core :>> Core
+  | Lam Name Core
+  -- | Function application; analogous to '$'.
+  | Core :$ Core
+  | Unit
+  | Bool Bool
+  | If Core Core Core
+  | String String -- FIXME: Text
+  -- | Load the specified file (by path).
+  | Load Core
+  | Edge Edge Core
+  -- | Allocation of a new frame.
+  | Frame
+  | Core :. Core
+  -- | Assignment of a value to the reference returned by the lhs.
+  | Core := Core
+  | Ann Loc Core
+  deriving (Eq, Ord, Show)
+
+infixl 2 :$
+infixr 1 :>>
+infix  3 :=
+infixl 4 :.
+
+data Edge = Lexical | Import
+  deriving (Eq, Ord, Show)
+
+instance Pretty Edge where
+  pretty = pretty . show
+
+instance Semigroup Core where
+  (<>) = (:>>)
+
+softsemi :: Pretty.Doc a
+softsemi = Pretty.flatAlt mempty ";"
+
+showCore :: Core -> String
+showCore = Pretty.renderString . Pretty.layoutPretty Pretty.defaultLayoutOptions . pretty
+
+instance Pretty Core where
+  pretty = \case
+    Var a    -> pretty a
+    Let a    -> "let" <+> pretty a
+    a :>>  b -> vsep [pretty a <> softsemi, pretty b]
+
+    Lam x f  -> vsep [ Pretty.nest 2 $ vsep [ "λ" <> pretty x <+> "-> {"
+                                            , pretty f
+                                            ]
+                     , "}"
+                     ]
+
+    f :$ x   -> pretty f <> "." <> pretty x
+    Unit     -> Pretty.parens mempty
+    Bool b   -> pretty b
+    If c x y -> Pretty.sep [ "if" <+> pretty c
+                           , "then" <+> pretty x
+                           , "else" <+> pretty y
+                           ]
+
+    String s -> pretty (show s)
+
+    Frame    -> Pretty.braces mempty
+
+    Load p   -> "load" <+> pretty p
+    Edge e n -> pretty e <+> pretty n
+    a :. b   -> "push" <+> Pretty.parens (pretty a) <+> Pretty.brackets (pretty b)
+    var := x -> pretty var <+> "=" <+> pretty x
+    Ann (Loc p s) c  -> pretty c <> Pretty.brackets (pretty p <> ":" <> pretty s)
+
+
+lams :: Foldable t => t Name -> Core -> Core
+lams names body = foldr Lam body names
+
+-- | Application of a function to a sequence of arguments.
+($$*) :: Foldable t => Core -> t Core -> Core
+($$*) = foldl' (:$)
+
+infixl 9 $$*
+
+unapply :: Alternative m => Core -> m (Core, Core)
+unapply (f :$ a) = pure (f, a)
+unapply _        = empty
+
+unapplies :: Core -> (Core, Stack Core)
+unapplies core = case unapply core of
+  Just (f, a) -> (:> a) <$> unapplies f
+  Nothing     -> (core, Nil)
+
+block :: Foldable t => t Core -> Core
+block cs
+  | null cs   = Unit
+  | otherwise = foldr1 (:>>) cs
+
+ann :: HasCallStack => Core -> Core
+ann = annWith callStack
+
+annWith :: CallStack -> Core -> Core
+annWith callStack c = maybe c (flip Ann c) (stackLoc callStack)

semantic-core/src/Data/File.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE DeriveTraversable #-}
+module Data.File
+( File(..)
+, fromBody
+) where
+
+import Data.Loc
+import Data.Maybe (fromJust)
+import GHC.Stack
+
+data File a = File
+  { fileLoc  :: !Loc
+  , fileBody :: !a
+  }
+  deriving (Eq, Foldable, Functor, Ord, Show, Traversable)
+
+fromBody :: HasCallStack => a -> File a
+fromBody body = File (fromJust (stackLoc callStack)) body

semantic-core/src/Data/Loc.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, TypeOperators, UndecidableInstances #-}
+module Data.Loc
+( Loc(..)
+, Span(..)
+, emptySpan
+, Pos(..)
+, here
+, stackLoc
+, FailWithLocC(..)
+, runFailWithLoc
+) where
+
+import Control.Applicative
+import Control.Effect.Carrier
+import Control.Effect.Error
+import Control.Effect.Fail
+import Control.Effect.Reader
+import Control.Effect.Sum
+import Data.Text.Prettyprint.Doc (Pretty (..))
+import GHC.Stack
+import Prelude hiding (fail)
+
+data Loc = Loc
+  { locPath :: !FilePath
+  , locSpan :: {-# UNPACK #-} !Span
+  }
+  deriving (Eq, Ord, Show)
+
+
+data Span = Span
+  { spanStart :: {-# UNPACK #-} !Pos
+  , spanEnd   :: {-# UNPACK #-} !Pos
+  }
+  deriving (Eq, Ord, Show)
+
+instance Pretty Span where
+  pretty (Span s e) = pretty s <> "-" <> pretty e
+
+emptySpan :: Span
+emptySpan = Span (Pos 1 1) (Pos 1 1)
+
+data Pos = Pos
+  { posLine :: {-# UNPACK #-} !Int
+  , posCol  :: {-# UNPACK #-} !Int
+  }
+  deriving (Eq, Ord, Show)
+
+instance Pretty Pos where
+  pretty (Pos l c) = pretty l <> ":" <> pretty c
+
+
+here :: HasCallStack => Maybe Loc
+here = stackLoc callStack
+
+stackLoc :: CallStack -> Maybe Loc
+stackLoc cs = case getCallStack cs of
+  (_, srcLoc):_ -> Just (fromGHCSrcLoc srcLoc)
+  _             -> Nothing
+
+fromGHCSrcLoc :: SrcLoc -> Loc
+fromGHCSrcLoc SrcLoc{..} = Loc srcLocFile (Span (Pos srcLocStartLine srcLocStartCol) (Pos srcLocEndLine srcLocEndCol))
+
+
+runFailWithLoc :: FailWithLocC m a -> m (Either (Loc, String) a)
+runFailWithLoc = runError . runFailWithLocC
+
+newtype FailWithLocC m a = FailWithLocC { runFailWithLocC :: ErrorC (Loc, String) m a }
+  deriving (Alternative, Applicative, Functor, Monad)
+
+instance (Carrier sig m, Effect sig, Member (Reader Loc) sig) => MonadFail (FailWithLocC m) where
+  fail s = do
+    loc <- ask
+    FailWithLocC (throwError (loc :: Loc, s))
+
+instance (Carrier sig m, Effect sig, Member (Reader Loc) sig) => Carrier (Fail :+: sig) (FailWithLocC m) where
+  eff (L (Fail s)) = fail s
+  eff (R other)    = FailWithLocC (eff (R (handleCoercible other)))

semantic-core/src/Data/Name.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, LambdaCase, MultiParamTypeClasses, OverloadedStrings, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
+module Data.Name
+( User
+, Namespaced
+, Name(..)
+, Gensym(..)
+, (//)
+, gensym
+, namespace
+, Naming(..)
+, runNaming
+, NamingC(..)
+) where
+
+import           Control.Applicative
+import           Control.Effect
+import           Control.Effect.Carrier
+import           Control.Effect.Reader
+import           Control.Effect.State
+import           Control.Effect.Sum
+import           Control.Monad.Fail
+import           Control.Monad.IO.Class
+import           Data.Text.Prettyprint.Doc (Pretty (..))
+import qualified Data.Text.Prettyprint.Doc as Pretty
+
+-- | User-specified and -relevant names.
+type User = String
+
+-- | The type of namespaced actions, i.e. actions occurring within some outer name.
+--
+--   This corresponds to the @Agent@ type synonym described in /I Am Not a Number—I Am a Free Variable/.
+type Namespaced a = Gensym -> a
+
+data Name
+  -- | A locally-bound, machine-generatable name.
+  --
+  --   This should be used for locals, function parameters, and similar names which can’t escape their defining scope.
+  = Gen Gensym
+  -- | A name provided by a user.
+  --
+  --   This should be used for names which the user provided and which other code (other functions, other modules, other packages) could call, e.g. declaration names.
+  | User User
+  -- | A variable name represented as the path to a source file. Used for loading modules at a specific name.
+  | Path FilePath
+  deriving (Eq, Ord, Show)
+
+instance Pretty Name where
+  pretty = \case
+    Gen p  -> pretty p
+    User n -> pretty n
+    Path p -> pretty (show p)
+
+data Gensym
+  = Root String
+  | Gensym :/ (String, Int)
+  deriving (Eq, Ord, Show)
+
+instance Pretty Gensym where
+  pretty = \case
+    Root s      -> pretty s
+    p :/ (n, x) -> Pretty.hcat [pretty p, "/", pretty n, "^", pretty x]
+
+(//) :: Gensym -> String -> Gensym
+root // s = root :/ (s, 0)
+
+infixl 6 //
+
+gensym :: (Carrier sig m, Member Naming sig) => String -> m Gensym
+gensym s = send (Gensym s pure)
+
+namespace :: (Carrier sig m, Member Naming sig) => String -> m a -> m a
+namespace s m = send (Namespace s m pure)
+
+
+data Naming m k
+  = Gensym String (Gensym -> k)
+  | forall a . Namespace String (m a) (a -> k)
+
+deriving instance Functor (Naming m)
+
+instance HFunctor Naming where
+  hmap _ (Gensym    s   k) = Gensym    s       k
+  hmap f (Namespace s m k) = Namespace s (f m) k
+
+instance Effect Naming where
+  handle state handler (Gensym    s   k) = Gensym    s                        (handler . (<$ state) . k)
+  handle state handler (Namespace s m k) = Namespace s (handler (m <$ state)) (handler . fmap k)
+
+
+runNaming :: Functor m => Gensym -> NamingC m a -> m a
+runNaming root = runReader root . evalState 0 . runNamingC
+
+newtype NamingC m a = NamingC { runNamingC :: StateC Int (ReaderC Gensym m) a }
+  deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO)
+
+instance (Carrier sig m, Effect sig) => Carrier (Naming :+: sig) (NamingC m) where
+  eff (L (Gensym    s   k)) = NamingC (StateC (\ i -> (:/ (s, i)) <$> ask >>= runState (succ i) . runNamingC . k))
+  eff (L (Namespace s m k)) = NamingC (StateC (\ i -> local (// s) (evalState 0 (runNamingC m)) >>= runState i . runNamingC . k))
+  eff (R other)             = NamingC (eff (R (R (handleCoercible other))))

semantic-core/src/Data/Stack.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE DeriveTraversable #-}
+module Data.Stack
+( Stack(..)
+) where
+
+data Stack a
+  = Nil
+  | Stack a :> a
+  deriving (Eq, Foldable, Functor, Ord, Show, Traversable)
+
+infixl 4 :>
+
+instance Semigroup (Stack a) where
+  xs <> Nil       = xs
+  xs <> (ys :> y) = (xs <> ys) :> y
+
+instance Monoid (Stack a) where
+  mempty = Nil

semantic-core/test/Doctest.hs

@@ -0,0 +1,12 @@
+module Main
+( main
+) where
+
+import System.Environment
+import Test.DocTest
+
+main :: IO ()
+main = do
+  args <- getArgs
+  autogen <- fmap (<> "/build/doctest/autogen") <$> lookupEnv "HASKELL_DIST_DIR"
+  doctest (maybe id ((:) . ("-i" <>)) autogen ("-isrc" : "--fast" : if null args then ["src"] else args))