From 424b24a200a658673ab4387965a7fd9670a7ecfa Mon Sep 17 00:00:00 2001 From: matheus Date: Fri, 25 Oct 2019 14:33:04 -0300 Subject: [PATCH] Feature: 'include' statement (#207) --- repl.sh | 2 +- src/Core/Lower.hs | 6 +++++ src/Parser.y | 2 ++ src/Parser/Lexer.x | 45 +++++++++++++++++----------------- src/Parser/Token.hs | 2 ++ src/Syntax/Desugar.hs | 3 +++ src/Syntax/Resolve.hs | 8 ++++++ src/Syntax/Toplevel.hs | 4 +++ src/Syntax/Verify.hs | 1 + src/Types/Infer.hs | 5 ++++ tests/resolve/pass_include.ml | 11 +++++++++ tests/resolve/pass_include.out | 9 +++++++ 12 files changed, 75 insertions(+), 23 deletions(-) create mode 100644 tests/resolve/pass_include.ml create mode 100644 tests/resolve/pass_include.out diff --git a/repl.sh b/repl.sh index 19e6bd4d5..c25465a1f 100755 --- a/repl.sh +++ b/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 "$@" diff --git a/src/Core/Lower.hs b/src/Core/Lower.hs index 37ba8dfa7..db5607ba0 100644 --- a/src/Core/Lower.hs +++ b/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) diff --git a/src/Parser.y b/src/Parser.y index 0002ce07a..3acf43a07 100644 --- a/src/Parser.y +++ b/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) diff --git a/src/Parser/Lexer.x b/src/Parser/Lexer.x index 4ead807dd..3e91d288e 100644 --- a/src/Parser/Lexer.x +++ b/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 } diff --git a/src/Parser/Token.hs b/src/Parser/Token.hs index be96c4f7e..7be096b32 100644 --- a/src/Parser/Token.hs +++ b/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 = "." diff --git a/src/Syntax/Desugar.hs b/src/Syntax/Desugar.hs index 414d0cff3..c34dbbfa7 100644 --- a/src/Syntax/Desugar.hs +++ b/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 diff --git a/src/Syntax/Resolve.hs b/src/Syntax/Resolve.hs index db76f4c9c..0dae541b8 100644 --- a/src/Syntax/Resolve.hs +++ b/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 diff --git a/src/Syntax/Toplevel.hs b/src/Syntax/Toplevel.hs index 26d2db1bd..5222d587d 100644 --- a/src/Syntax/Toplevel.hs +++ b/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 diff --git a/src/Syntax/Verify.hs b/src/Syntax/Verify.hs index 3a0eae2ae..903300867 100644 --- a/src/Syntax/Verify.hs +++ b/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 diff --git a/src/Types/Infer.hs b/src/Types/Infer.hs index 3b9bed3e8..572d2ae2e 100644 --- a/src/Types/Infer.hs +++ b/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)) $ diff --git a/tests/resolve/pass_include.ml b/tests/resolve/pass_include.ml new file mode 100644 index 000000000..74d791b27 --- /dev/null +++ b/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 diff --git a/tests/resolve/pass_include.out b/tests/resolve/pass_include.out new file mode 100644 index 000000000..1a5c34799 --- /dev/null +++ b/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)