Feature: 'include' statement (#207)

repl.sh

@@ -47,5 +47,5 @@ export AMC_LIBRARY_PATH=$PWD/lib/:$AMC_LIBRARY_PATH
 
 exec stack exec -- \
   ghci -O0 -j2 +RTS -A128M -RTS ${WARN[@]} \
-  -i./src/:$out_dir/src/:./bin/ \
+  -i./src/:$out_dir/src/:./bin/:./tests/driver/ \
   ./bin/Amc.hs "$@"

src/Core/Lower.hs

@@ -311,9 +311,15 @@ lowerModule ModLoad{} = asks (,[])
 lowerProg' :: forall m. MonadLower m => [Toplevel Typed] -> m (LowerState, [Stmt])
 
 lowerProg' [] = asks (,[])
+
+lowerProg' (Include m:prg) = do
+  (s, ms) <- lowerModule m
+  (ms++) <$$> local (const s) (lowerProg' prg)
+
 lowerProg' (Open m:prg) = do
   (s, ms) <- lowerModule m
   (ms++) <$$> local (const s) (lowerProg' prg)
+
 lowerProg' (Module _ _ m:prg) = do
   (s, ms) <- lowerModule m
   (ms++) <$$> local (const s) (lowerProg' prg)

src/Parser.y

@@ -114,6 +114,7 @@ import Syntax
   instance { Token TcInstance _ _ }
   when     { Token TcWhen _ _ }
   private  { Token TcPrivate _ _ }
+  include  { Token TcInclude _ _ }
 
   ','      { Token TcComma _ _ }
   '.'      { Token TcDot _ _ }
@@ -197,6 +198,7 @@ Top :: { Toplevel Parsed }
     | module conid '=' ModuleTerm              { Module Public (getName $2) $4 }
     | private module conid '=' ModuleTerm      { Module Private (getName $3) $5 }
     | open ModuleTerm                          { Open $2 }
+    | include ModuleTerm                       { Include $2 }
 
     -- Note, we use fmap rather than <$>, as Happy's parser really doesn't like that.
     | class Type Fundeps Begin(ClassItems)

src/Parser/Lexer.x

@@ -74,33 +74,34 @@ tokens :-
   <0> "~"      { constTok TcTilde }
   <0> \_       { constTok TcUnderscore }
 
-  <0> "let"    { constTok TcLet }
-  <0> "fun"    { constTok TcFun }
-  <0> "and"    { constTok TcAnd }
-  <0> "if"     { constTok TcIf }
-  <0> "then"   { constTok TcThen }
-  <0> "else"   { constTok TcElse }
-  <0> "begin"  { constTok TcBegin }
-  <0> "end"    { constTok TcEnd }
-  <0> "in"     { constTok TcIn }
+  <0> "let"      { constTok TcLet }
+  <0> "fun"      { constTok TcFun }
+  <0> "and"      { constTok TcAnd }
+  <0> "if"       { constTok TcIf }
+  <0> "then"     { constTok TcThen }
+  <0> "else"     { constTok TcElse }
+  <0> "begin"    { constTok TcBegin }
+  <0> "end"      { constTok TcEnd }
+  <0> "in"       { constTok TcIn }
   <0> "external" { constTok TcExternal }
-  <0> "val"    { constTok TcVal }
-  <0> "true"   { constTok TcTrue }
-  <0> "false"  { constTok TcFalse }
-  <0> "match"  { constTok TcMatch }
-  <0> "with"   { constTok TcWith }
+  <0> "val"      { constTok TcVal }
+  <0> "true"     { constTok TcTrue }
+  <0> "false"    { constTok TcFalse }
+  <0> "match"    { constTok TcMatch }
+  <0> "with"     { constTok TcWith }
   <0> "function" { constTok TcFunction }
-  <0> "type"   { constTok TcType }
-  <0> "of"     { constTok TcOf }
-  <0> "module" { constTok TcModule }
-  <0> "open"   { constTok TcOpen }
-  <0> "lazy"   { constTok TcLazy }
-  <0> "import" { constTok TcImport }
-  <0> "as"     { constTok TcAs }
+  <0> "type"     { constTok TcType }
+  <0> "of"       { constTok TcOf }
+  <0> "module"   { constTok TcModule }
+  <0> "open"     { constTok TcOpen }
+  <0> "lazy"     { constTok TcLazy }
+  <0> "import"   { constTok TcImport }
+  <0> "as"       { constTok TcAs }
   <0> "class"    { constTok TcClass }
   <0> "instance" { constTok TcInstance }
-  <0> "when"   { constTok TcWhen }
+  <0> "when"     { constTok TcWhen }
   <0> "private"  { constTok TcPrivate }
+  <0> "include"  { constTok TcInclude }
 
   <0> ","      { constTok TcComma }
   <0> "."      { constTok TcDot }

src/Parser/Token.hs

@@ -55,6 +55,7 @@ data TokenClass
   | TcWhen -- ^ A @when@ token.
   | TcPrivate -- ^ A @private@ token.
   | TcImport -- ^ An @import@ token.
+  | TcInclude -- ^ An @include@ token.
   | TcAs   -- ^ An @as@ token.
 
   | TcDot -- ^ A @.@ token.
@@ -141,6 +142,7 @@ instance Show TokenClass where
   show TcInstance = "instance"
   show TcWhen = "when"
   show TcPrivate = "private"
+  show TcInclude = "include"
 
   show TcComma = ","
   show TcDot = "."

src/Syntax/Desugar.hs

@@ -38,7 +38,10 @@ statement (Instance a b c m d) = Instance a (ty <$> b) (ty c) <$> traverse instI
   instItem (TypeImpl v as t a) = pure $ TypeImpl v (map tyA as) (ty t) a
 statement (Class am a b c fd m d) = Class am a (ty <$> b) (tyA <$> c) (map go fd) <$> traverse classItem m <*> pure d where
   go (Fundep f t a) = Fundep f t a
+
 statement (Open v) = Open <$> modTerm v
+statement (Include v) = Include <$> modTerm v
+
 statement (ForeignVal am v x t a) = pure $ ForeignVal am v x (ty t) a
 statement (TypeDecl am v arg cs a) = pure $ TypeDecl am v (map tyA arg) (map ctor <$> cs) a
 statement (TySymDecl am v arg exp a) = pure $ TySymDecl am v (map tyA arg) (ty exp) a

src/Syntax/Resolve.hs

@@ -157,6 +157,14 @@ reTops (r@(Open mod):rest) sig = do
     Nothing -> confess empty
     Just sig' -> local (scope %~ (<>sig')) $ first3 (Open mod':) <$> reTops rest sig
 
+reTops (r@(Include mod):rest) sig = do
+  (mod', sig') <- retcons (wrapError r) $ reModule mod
+  case sig' of
+    Nothing -> confess empty
+    Just sig' -> local (scope %~ (<>sig')) $ do
+      (prog, siga, sigb) <- reTops rest sig
+      pure (Include mod':prog, siga <> sig', sigb)
+
 reTops (r@(Module am name mod):rest) sig = do
   name' <- tagVar name
   (mod', sig') <- retcons (wrapError r) $ reModule mod

src/Syntax/Toplevel.hs

@@ -41,8 +41,10 @@ data Toplevel p
   | ForeignVal TopAccess (Var p) Text (Type p) (Ann p)
   | TypeDecl TopAccess (Var p) [TyConArg p] (Maybe [Constructor p]) (Ann p)
   | TySymDecl TopAccess (Var p) [TyConArg p] (Type p) (Ann p)
+
   | Module TopAccess (Var p) (ModuleTerm p)
   | Open (ModuleTerm p)
+  | Include (ModuleTerm p)
 
   | Class { className :: Var p
           , classAccess :: TopAccess
@@ -159,6 +161,7 @@ instance (Spanned (Constructor p), Spanned (Ann p)) => Spanned (Toplevel p) wher
   annotation x@TypeFunDecl{} = annotation (ann x)
   annotation (Module _ _ m) = annotation m
   annotation (Open m) = annotation m
+  annotation (Include m) = annotation m
 
 instance Spanned (Ann p) => Spanned (Fundep p) where
   annotation = annotation . view fdAnn
@@ -218,6 +221,7 @@ instance Pretty (Var p) => Pretty (Toplevel p) where
           Just cs -> equals <#> indent 2 (vsep (map ((pipe <+>) . pretty) cs))
     in keyword "type" <+> prettyAcc m <> pretty ty <+> hsep (map ((squote <>) . pretty) args) <+> ct
   pretty (Open m) = keyword "open" <+> pretty m
+  pretty (Include m) = keyword "include" <+> pretty m
 
   pretty (TySymDecl m ty args exp _) =
     prettyAcc m <+> keyword "type" <> pretty ty <+> hsep (map ((squote <>) . pretty) args) <+> pretty exp

src/Syntax/Verify.hs

@@ -83,6 +83,7 @@ verifyProgram = traverse_ verifyStmt where
   verifyStmt TypeFunDecl{} = pure ()
   verifyStmt (Module _ _ m) = verifyModule m
   verifyStmt (Open m) = verifyModule m
+  verifyStmt (Include m) = verifyModule m
 
 -- | Verify a recursive definition is well-formed
 verifyBindingGroup :: MonadVerify m

src/Types/Infer.hs

@@ -450,6 +450,11 @@ inferProg (Open mod:prg) = do
   local (exEnv. (classes %~ (<>modImplicits)) . (tySyms %~ (<>modTysym))) $
     consFst (Open mod') $ inferProg prg
 
+inferProg (Include mod:prg) = do
+  (mod', exEnv, (modImplicits, modTysym)) <- inferMod mod
+  local (exEnv. (classes %~ (<>modImplicits)) . (tySyms %~ (<>modTysym))) $
+    consFst (Include mod') $ inferProg prg
+
 inferProg (Module am name mod:prg) = do
   (mod', exEnv, modInfo) <- local (declaredHere .~ mempty) $ inferMod mod
   local (exEnv . (modules %~ Map.insert name modInfo)) $

tests/resolve/pass_include.ml

@@ -0,0 +1,11 @@
+module X = begin
+  let x = 1
+end
+
+module Y = begin
+  let y = 1
+  include X
+end
+
+external val (+) : int -> int -> int = "function(x, y) return x + y end"
+let _ = Y.x + Y.y

tests/resolve/pass_include.out

@@ -0,0 +1,9 @@
+module X#0 = begin
+  let x#1 = 1
+end
+module Y#2 = begin
+  let y#3 = 1
+  include X#0
+end
+foreign val +#4 : int -> int -> int = "function(x, y) return x + y end"
+let _ = (x#1 +#4 y#3)