Support top-level declarations

src/Clean.purs

@@ -2,18 +2,20 @@ module Clean
   ( defaultEnv
   , runTypeInference
   , typeInference
+  , typeInferModule
   ) where
 
 import Prelude
 
-import Clean.Types (Constraint, Exp(..), Kind(..), Label, Prim(..), Scheme(..), Subst, TyVar(..), Type(..), TypeEnv(..), TypeInference, TypeInferenceEnv(..), TypeInferenceState(..), applySubst, getFreeTypeVars, toList)
+import Clean.Types (Constraint, Declaration(..), Exp(..), Kind(..), Label, Module, Prim(..), Scheme(..), Subst, TyVar(..), Type(..), TypeEnv(..), TypeInference, TypeInferenceEnv(..), TypeInferenceState(..), applySubst, getFreeTypeVars, toList)
 import Control.Monad.Eff (Eff)
 import Control.Monad.Except.Trans (runExceptT, throwError)
 import Control.Monad.Reader.Trans (runReaderT)
 import Control.Monad.State.Trans (get, put, runStateT)
 import Data.Array as A
 import Data.Either (Either)
 import Data.Foldable (class Foldable, foldM)
+import Data.List (List(..))
 import Data.List as L
 import Data.Map as M
 import Data.Maybe (Maybe(..))
@@ -49,6 +51,7 @@ runTypeInference t = do
     initTypeInferenceEnv = TypeInferenceEnv
     initTypeInferenceState = TypeInferenceState { supply: 0
                                                 , subst: M.empty
+                                                , env: defaultEnv
                                                 }
 
 freshTyVar :: TypeInference Type
@@ -245,6 +248,22 @@ typeInferPrim env = case _ of
           pure t2)
         emptyType ts
 
+typeInferModule :: Module -> TypeInference Type
+typeInferModule decls = do
+  emptyType <- freshTyVar
+  foldM go emptyType decls
+  where
+  go :: Type -> Declaration -> TypeInference Type
+  go t1 = case _ of
+    VariableDeclaration exp -> case exp of
+      ELet name _ _ -> do
+        t2 <- typeInference exp
+        let scheme = Scheme Nil t2
+        TypeInferenceState s@{ env: TypeEnv env } <- get
+        _ <- put $ TypeInferenceState s { env = TypeEnv $ M.insert name scheme env }
+        pure t2
+      _             -> throwError $ "Only let declarations are supported. Found " <> show exp
+    _                       -> throwError "Only variable declarations are supported at this time"
 
 typeInference :: Exp -> TypeInference Type
 typeInference e = do

src/Clean/Expressions.purs

@@ -1,20 +1,63 @@
-module Clean.Expressions (babylonToClean) where
+module Clean.Expressions (babylonToClean, fileToModule) where
 
-import Babylon.Types (BinaryExpression', BinaryOperator(Pipe, Instanceof, In, NotEquals, Equals), Node(ImportDeclaration, ExportNamedDeclaration, VariableDeclaration, Identifier, VariableDeclarator, BlockStatement, ReturnStatement, Program, ObjectProperty, ArrayExpression, MemberExpression, ObjectExpression, CallExpression, ArrowFunctionExpression, ConditionalExpression, BinaryExpression, UnaryExpression, StringLiteral, BooleanLiteral, NumericLiteral, File), Node', UnaryOperator(Typeof, Plus, Minus, Void, Delete, Throw), VariableKind(Let))
-import Clean.Types (Exp(..), Prim(..))
+import Babylon.Types (BinaryExpression', BinaryOperator(Pipe, Instanceof, In, NotEquals, Equals), Node(..), Node', UnaryOperator(Typeof, Plus, Minus, Void, Delete, Throw), VariableKind(Let))
+import Clean.Types (Exp(ELet, EVar, EAbs, EApp, EPrim), Prim(Cond, LString, RecordEmpty, RecordExtend, RecordSelect, LArray, LBoolean, LNumber))
+import Clean.Types as CT
 import Control.Monad.Except (Except, throwError)
 import Data.Array (last, length, unsnoc)
 import Data.Foldable (foldr)
+import Data.List as L
 import Data.Maybe (Maybe(..), maybe)
-import Data.Traversable (traverse)
+import Data.Traversable (sequence, traverse)
 import Prelude (bind, join, otherwise, pure, show, ($), (<$>), (<*>), (<<<), (<>), (==))
 
 
 type Expression = Except String Exp
 
+fileToModule :: Node -> Except String CT.Module
+fileToModule = case _ of
+  File { program: Program { body } }
+    -> case body of
+     []    -> throwError "Modules must node be empty"
+     decls -> sequence $ L.fromFoldable $ declToDecl <$> decls
+  _ -> throwError "Files must be files"
+
+declToDecl :: Node -> Except String CT.Declaration
+declToDecl = case _ of
+  ImportDeclaration imp      -> importToDeclaration imp
+  ExportNamedDeclaration exp -> exportToDeclaration exp
+  VariableDeclaration decl   -> variableToDeclaration decl
+  d                          -> throwError $ "Unsupported declaration type " <> show d
+  where
+    importToDeclaration { source, specifiers } = do
+      src <- babylonToClean source
+      specs <- traverse babylonToClean specifiers
+      pure $ CT.ImportDeclaration (L.fromFoldable specs) src
+
+    exportToDeclaration { declaration
+                        , source
+                        , specifiers
+                        } = case declaration, source, specifiers of
+      Just decl, Nothing, [] -> declToDecl decl
+      _, _, _                -> throwError $ "Unsupported export declaration"
+
+    variableToDeclaration { declarations, kind } = case kind of
+      Let -> case declarations of
+        [VariableDeclarator { id: Identifier { name }, init }]
+               -> CT.VariableDeclaration <$> (declaratorToELet name init)
+        _      -> throwError $ "Exactly ONE declarator allowed at the top-level. "
+                  <> show (length declarations)
+                  <> " provided."
+      _ -> throwError $ "Unsupported variable declaration type: " <> show kind
+      where
+        declaratorToELet :: String -> Maybe Node -> Expression
+        declaratorToELet name init = case init of
+          Just init' -> let result = (babylonToClean init')
+                        in ELet name <$> result <*> result
+          Nothing    -> throwError "`let` declarations must be initialized"
+
 babylonToClean :: Node -> Expression
 babylonToClean = case _ of
-  File                    f -> fileToExp f
   NumericLiteral          e -> literalToEPrim LNumber e
   BooleanLiteral          e -> literalToEPrim LBoolean e
   StringLiteral           e -> literalToEPrim LString e
@@ -60,11 +103,6 @@ propertyToString = case _ of
   EVar s            -> Just s
   _                 -> Nothing
 
-fileToExp :: Node' ( program :: Node ) -> Expression
-fileToExp { program } = case program of
-  Program { body } -> programBodyToELet body
-  _                -> throwError "Files must contain programs"
-
 unaryExpressionToEApp ::
   Node' ( operator :: UnaryOperator
         , argument :: Node
@@ -154,32 +192,8 @@ bodyToELet decls ret = do
 
 type DeclaratorRecord = { id :: String, init :: Maybe Node }
 
-programBodyToELet :: Array Node -> Expression
-programBodyToELet declarations = case declarations of
-  [] -> throwError "Programs must contains declarations"
-  _  -> do
-    decls <- variableDeclarationsToDeclarators declarations
-    let d = case last decls of
-          Nothing -> throwError $ "Impossible state!"
-          Just { id } -> pure $ EVar id
-    foldr letDeclaratorReducer d decls
-
 variableDeclarationsToDeclarators :: Array Node -> Except String (Array DeclaratorRecord)
 variableDeclarationsToDeclarators ns = join <$> (traverse go ns) where
-  fromDeclarator = case _ of
-    VariableDeclarator { id: (Identifier { name: id })
-                       , init
-                       } -> pure { id, init }
-
-    _                    -> throwError
-                            "A `let` declaration must bind an expression to an identifier"
-
-  exportToDeclarators { declaration, specifiers } = case specifiers of
-    [] -> case declaration of
-      Nothing -> throwError "Named exports must include a `let` declaration"
-      Just d  -> go d
-    _  -> throwError "Export specifiers are not allowed"
-
   go = case _ of
     VariableDeclaration { kind
                         , declarations
@@ -198,6 +212,21 @@ variableDeclarationsToDeclarators ns = join <$> (traverse go ns) where
                        <> show d
                        <> ". Only `let` and `return` statements are allowed."
 
+  fromDeclarator = case _ of
+    VariableDeclarator { id: (Identifier { name: id })
+                       , init
+                       } -> pure { id, init }
+
+    _                    -> throwError
+                            "A `let` declaration must bind an expression to an identifier"
+
+  exportToDeclarators { declaration, specifiers } = case specifiers of
+    [] -> case declaration of
+      Nothing -> throwError "Named exports must include a `let` declaration"
+      Just d  -> go d
+    _  -> throwError "Export specifiers are not allowed"
+
+
 letDeclaratorReducer :: DeclaratorRecord -> Expression -> Expression
 letDeclaratorReducer { id, init } acc = case init of
   Nothing    -> throwError "`let` declarations must be initialized"

src/Clean/Types.purs

@@ -37,6 +37,16 @@ instance showExp :: Show Exp where
 showParen :: forall a. Show a => a -> String
 showParen x = "(" <> show x <> ")"
 
+-- Declarations
+data Declaration
+  = ImportDeclaration (List Exp) Exp
+  | ExportDeclaration Exp   -- ELet
+  | VariableDeclaration Exp -- ELet
+derive instance eqDeclaration :: Eq Declaration
+derive instance ordDeclaration :: Ord Declaration
+
+type Module = List Declaration
+
 -- Primitives
 data Prim
   = LNumber Number
@@ -176,6 +186,7 @@ instance showScheme :: Show Scheme where
 data TypeInferenceEnv = TypeInferenceEnv
 data TypeInferenceState = TypeInferenceState { supply :: Int
                                              , subst :: Subst
+                                             , env :: TypeEnv
                                              }
 
 toList :: Type -> { rows :: List { label :: Label, type :: Type }, tyVar :: Maybe TyVar }

src/Main.purs

@@ -3,9 +3,9 @@ module Main where
 import Prelude
 
 import Babylon.Types as B
-import Clean (defaultEnv, runTypeInference, typeInference)
-import Clean.Expressions (babylonToClean)
-import Clean.Types (Exp, Type)
+import Clean (runTypeInference, typeInferModule)
+import Clean.Expressions (fileToModule)
+import Clean.Types (Exp, Type, Module)
 import Control.Comonad (extract)
 import Control.Monad.Eff (Eff)
 import Control.Monad.Eff.Console (CONSOLE, log)
@@ -59,20 +59,19 @@ main = do
       logResults src result)
     value
 
-jsToClean :: forall e. String -> Either String Exp
+jsToClean :: String -> Either String Module
 jsToClean = extract <<< runExceptT <<< go B.parse'
   where
-    go :: (String -> F B.Node) -> String -> Except String Exp
     go parse js = do
       ast <- relaxF $ parse js
-      babylonToClean ast
+      fileToModule ast
 
 infer :: forall e. String -> Eff (console :: CONSOLE | e) (Either String Type)
 infer src =
   case jsToClean src of
     Left err -> pure $ Left $ "JS error: " <> err
     Right exp -> do
-      Tuple r _ <- runTypeInference (typeInference defaultEnv exp)
+      Tuple r _ <- runTypeInference (typeInferModule exp)
       pure r
 
 showClean :: Either String Exp -> String
@@ -87,5 +86,3 @@ logResults src result = do
     Left err -> log $ "error: " <> err <> " in\n\n" <> src
     Right t  -> log $ src <> " :: " <> show t
 
-
-