Move over and implement qualified export with TS path resolution

src/Data/Syntax/Declaration.hs

@@ -203,54 +203,6 @@ instance Show1 Comprehension where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Comprehension
 
 
--- | Qualified Export declarations
-newtype QualifiedExport a = QualifiedExport { qualifiedExportSymbols :: [(Name, Name)] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
-
-instance Eq1 QualifiedExport where liftEq = genericLiftEq
-instance Ord1 QualifiedExport where liftCompare = genericLiftCompare
-instance Show1 QualifiedExport where liftShowsPrec = genericLiftShowsPrec
-
-instance Evaluatable QualifiedExport where
-  eval (QualifiedExport exportSymbols) = do
-    -- Insert the aliases with no addresses.
-    for_ exportSymbols $ \(name, alias) ->
-      addExport name alias Nothing
-    unit
-
-
--- | Qualified Export declarations that export from another module.
-data QualifiedExportFrom a = QualifiedExportFrom { qualifiedExportFrom :: !a, qualifiedExportFromSymbols :: ![(Name, Name)]}
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
-
-instance Eq1 QualifiedExportFrom where liftEq = genericLiftEq
-instance Ord1 QualifiedExportFrom where liftCompare = genericLiftCompare
-instance Show1 QualifiedExportFrom where liftShowsPrec = genericLiftShowsPrec
-
-instance Evaluatable QualifiedExportFrom where
-  eval (QualifiedExportFrom from exportSymbols) = do
-    let moduleName = freeVariable (subterm from)
-    (importedEnv, _) <- isolate (require moduleName)
-    -- Look up addresses in importedEnv and insert the aliases with addresses into the exports.
-    for_ exportSymbols $ \(name, alias) -> do
-      let address = Env.lookup name importedEnv
-      maybe (cannotExport moduleName name) (addExport name alias . Just) address
-    unit
-    where
-      cannotExport moduleName name = fail $
-        "module " <> show (friendlyName moduleName) <> " does not export " <> show (friendlyName name)
-
-
-newtype DefaultExport a = DefaultExport { defaultExport :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
-
-instance Eq1 DefaultExport where liftEq = genericLiftEq
-instance Ord1 DefaultExport where liftCompare = genericLiftCompare
-instance Show1 DefaultExport where liftShowsPrec = genericLiftShowsPrec
-
-instance Evaluatable DefaultExport where
-
-
 -- | Qualified Import declarations (symbols are qualified in calling environment).
 --
 -- If the list of symbols is empty copy and qualify everything to the calling environment.

src/Language/TypeScript/Assignment.hs

@@ -35,9 +35,6 @@ type Syntax = '[
   , Declaration.PublicFieldDefinition
   , Declaration.VariableDeclaration
   , Declaration.TypeAlias
-  , Declaration.DefaultExport
-  , Declaration.QualifiedExport
-  , Declaration.QualifiedExportFrom
   , Expression.Arithmetic
   , Expression.Bitwise
   , Expression.Boolean
@@ -165,6 +162,9 @@ type Syntax = '[
   , TypeScript.Syntax.Import
   , TypeScript.Syntax.QualifiedImport
   , TypeScript.Syntax.SideEffectImport
+  , TypeScript.Syntax.DefaultExport
+  , TypeScript.Syntax.QualifiedExport
+  , TypeScript.Syntax.QualifiedExportFrom
   , []
   ]
 
@@ -667,11 +667,6 @@ importStatement =   makeImportTerm <$> symbol Grammar.ImportStatement <*> childr
     -- TODO: Need to validate that inline comments are still handled with this change in assigning to Path and not a Term.
     fromClause = symbol Grammar.String *> (path <$> source)
 
-fromClause :: Assignment
-fromClause = makeTerm <$> symbol Grammar.String <*> (Syntax.Identifier <$> (toName <$> source))
-  where
-    toName = qualifiedName . splitOnPathSeparator . dropRelativePrefix . stripQuotes
-
 debuggerStatement :: Assignment
 debuggerStatement = makeTerm <$> symbol Grammar.DebuggerStatement <*> (TypeScript.Syntax.Debugger <$ source)
 
@@ -715,9 +710,9 @@ ambientDeclaration :: Assignment
 ambientDeclaration = makeTerm <$> symbol Grammar.AmbientDeclaration <*> children (TypeScript.Syntax.AmbientDeclaration <$> term (choice [declaration, statementBlock]))
 
 exportStatement :: Assignment
-exportStatement = makeTerm <$> symbol Grammar.ExportStatement <*> children (flip Declaration.QualifiedExportFrom <$> exportClause <*> term fromClause)
-  <|> makeTerm <$> symbol Grammar.ExportStatement <*> children (Declaration.QualifiedExport <$> exportClause)
-  <|> makeTerm <$> symbol Grammar.ExportStatement <*> children (Declaration.DefaultExport <$> contextualize decorator (term (declaration <|> expression <|> identifier <|> importAlias')))
+exportStatement = makeTerm <$> symbol Grammar.ExportStatement <*> children (flip TypeScript.Syntax.QualifiedExportFrom <$> exportClause <*> fromClause)
+  <|> makeTerm <$> symbol Grammar.ExportStatement <*> children (TypeScript.Syntax.QualifiedExport <$> exportClause)
+  <|> makeTerm <$> symbol Grammar.ExportStatement <*> children (TypeScript.Syntax.DefaultExport <$> contextualize decorator (term (declaration <|> expression <|> identifier <|> importAlias')))
   where
     exportClause = symbol Grammar.ExportClause *> children (many exportSymbol)
     exportSymbol = symbol Grammar.ExportSpecifier *> children (makeNameAliasPair <$> rawIdentifier <*> (Just <$> rawIdentifier))
@@ -725,6 +720,8 @@ exportStatement = makeTerm <$> symbol Grammar.ExportStatement <*> children (flip
     makeNameAliasPair from (Just alias) = (from, alias)
     makeNameAliasPair from Nothing = (from, from)
     rawIdentifier = (symbol Identifier <|> symbol Identifier') *> (name <$> source)
+    -- TODO: Need to validate that inline comments are still handled with this change in assigning to Path and not a Term.
+    fromClause = symbol Grammar.String *> (path <$> source)
 
 propertySignature :: Assignment
 propertySignature = makePropertySignature <$> symbol Grammar.PropertySignature <*> children ((,,,) <$> (term accessibilityModifier' <|> emptyTerm) <*> (term readonly' <|> emptyTerm) <*> term propertyName <*> (term typeAnnotation' <|> emptyTerm))

src/Language/TypeScript/Syntax.hs

@@ -61,6 +61,7 @@ resolveTSModule path = maybe (Left searchPaths) Right <$> resolve searchPaths
           -- <> [searchDir </> "package.json"]
           <> (((path </> "index") <.>) <$> exts)
 
+
 data Import a = Import { importFrom :: Path, importSymbols :: ![(Name, Name)], importWildcardToken :: !a }
   deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
 
@@ -121,6 +122,58 @@ instance Show1 SideEffectImport where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable SideEffectImport
 
+-- | Qualified Export declarations
+newtype QualifiedExport a = QualifiedExport { qualifiedExportSymbols :: [(Name, Name)] }
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+
+instance Eq1 QualifiedExport where liftEq = genericLiftEq
+instance Ord1 QualifiedExport where liftCompare = genericLiftCompare
+instance Show1 QualifiedExport where liftShowsPrec = genericLiftShowsPrec
+
+instance Evaluatable QualifiedExport where
+  eval (QualifiedExport exportSymbols) = do
+    -- Insert the aliases with no addresses.
+    for_ exportSymbols $ \(name, alias) ->
+      addExport name alias Nothing
+    unit
+
+
+-- | Qualified Export declarations that export from another module.
+data QualifiedExportFrom a = QualifiedExportFrom { qualifiedExportFrom :: Path, qualifiedExportFromSymbols :: ![(Name, Name)]}
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+
+instance Eq1 QualifiedExportFrom where liftEq = genericLiftEq
+instance Ord1 QualifiedExportFrom where liftCompare = genericLiftCompare
+instance Show1 QualifiedExportFrom where liftShowsPrec = genericLiftShowsPrec
+
+instance Evaluatable QualifiedExportFrom where
+  eval (QualifiedExportFrom (Path path NonRelative) symbols) = do
+    modulePath <- resolveNonRelativeTSModule path
+    doQualifiedExportFrom modulePath symbols *> unit
+  eval (QualifiedExportFrom (Path path Relative) symbols) = do
+    modulePath <- resolveRelativeTSModule path
+    doQualifiedExportFrom modulePath symbols *> unit
+
+doQualifiedExportFrom :: MonadEvaluatable term value m => M.ModuleName -> [(Name, Name)] -> m ()
+doQualifiedExportFrom modulePath exportSymbols = do
+    (importedEnv, _) <- isolate (require modulePath)
+    -- Look up addresses in importedEnv and insert the aliases with addresses into the exports.
+    for_ exportSymbols $ \(name, alias) -> do
+      let address = Env.lookup name importedEnv
+      maybe (cannotExport modulePath name) (addExport name alias . Just) address
+    where
+      cannotExport moduleName name = fail $
+        "module " <> show moduleName <> " does not export " <> show (friendlyName name)
+
+
+newtype DefaultExport a = DefaultExport { defaultExport :: a }
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+
+instance Eq1 DefaultExport where liftEq = genericLiftEq
+instance Ord1 DefaultExport where liftCompare = genericLiftCompare
+instance Show1 DefaultExport where liftShowsPrec = genericLiftShowsPrec
+
+instance Evaluatable DefaultExport where
 
 
 -- | Lookup type for a type-level key in a typescript map.