cover more import cases (#49)

* Fix imports inside scope of other imports.

* Named input imports, imports under imports, handle cycles

Author: gmorpheme

src/Eucalypt/Core/Import.hs

@@ -13,7 +13,7 @@ import Control.Monad.Trans
 import Data.Foldable (toList)
 import qualified Data.Graph as G
 import qualified Data.Map as M
-import Data.Maybe (fromJust)
+import Data.Maybe (fromMaybe)
 import Eucalypt.Core.Metadata
 import Eucalypt.Core.Syn
 import Eucalypt.Core.Unit
@@ -44,7 +44,8 @@ processImports ::
 processImports load expr@(CoreMeta m body) =
   case importsFromMetadata m of
     Just imports ->
-      CoreMeta (pruneImports m) $ foldr (\i e -> rebody (load i) e) body imports
+      CoreMeta (pruneImports m) $
+      foldr (\i e -> rebody (load i) e) (processImports load body) imports
     Nothing -> expr
 processImports load (CoreLet bs b) = CoreLet bs' b'
   where
@@ -80,15 +81,25 @@ processUnit load u@TranslationUnit {truCore = body} =
 
 
 
--- | Process all imports in topologically sorted order
-applyAllImports :: M.Map Input TranslationUnit -> M.Map Input TranslationUnit
-applyAllImports unitMap = foldl processInput unitMap sortedInputs
+-- | Process all imports in topologically sorted order unless there
+-- are cycles, in which case return the inputs involved in the cycles
+-- (in Left)
+applyAllImports ::
+     M.Map Input TranslationUnit -> Either [Input] (M.Map Input TranslationUnit)
+applyAllImports unitMap =
+  if (not . null) cyclicInputs
+    then Left cyclicInputs
+    else Right $ foldl processInput unitMap sortedInputs
   where
     (graph, getVertex) = G.graphFromEdges' $ map edgeSpec $ M.assocs unitMap
     edgeSpec (k, v) = (k, k, toList $ truImports v)
-    sortedInputs = map (toInput . getVertex) $ (reverse . G.topSort) graph
-    toInput (i, _, _) = i
-    toLoadFn m k = truCore $ fromJust (M.lookup k m)
-    processInput ::
-         M.Map Input TranslationUnit -> Input -> M.Map Input TranslationUnit
+    sortedInputs = map toInput $ (reverse . G.topSort) graph
+    toInput v =
+      case getVertex v of
+        (i, _, _) -> i
+    toLoadFn m k =
+      truCore $ fromMaybe (error $ "no such key: " ++ show k) (M.lookup k m)
     processInput m input = M.update (return . processUnit (toLoadFn m)) input m
+    cyclicInputs =
+      (map toInput . mconcat . filter isCycle . map toList . G.scc) graph
+    isCycle cc = length cc > 1 || (minimum cc, minimum cc) `elem` G.edges graph

src/Eucalypt/Driver/Error.hs

@@ -1,7 +1,19 @@
+{-|
+Module      : Eucalypt.Core.Error
+Description : Errors detected during driver stages
+Copyright   : (c) Greg Hawkins, 2018
+License     :
+Maintainer  : greg@curvelogic.co.uk
+Stability   : experimental
+-}
 module Eucalypt.Driver.Error where
 
-import Data.Typeable
+import Control.Exception.Safe
 import Eucalypt.Syntax.Input (Input)
 
-newtype CommandError = InvalidInput Input
+data CommandError
+  = InvalidInput Input -- ^ invalid input (bad format etc.)
+  | CyclicInputs [Input] -- ^ input imports form one or more cycles
   deriving (Show, Typeable)
+
+instance Exception CommandError

src/Eucalypt/Driver/Evaluator.hs

@@ -11,7 +11,7 @@ module Eucalypt.Driver.Evaluator
 where
 
 import Control.Applicative ((<|>))
-import Control.Exception.Safe (try)
+import Control.Exception.Safe (throwM, try)
 import Control.Monad (forM_, unless, when)
 import Control.Monad.Loops (iterateUntilM)
 import Data.Bifunctor
@@ -262,8 +262,10 @@ formEvaluand opts targets source =
 parseInputsAndImports :: [Input] -> IO [TranslationUnit]
 parseInputsAndImports inputs = do
   unitMap <- parseAllUnits inputs
-  let processedUnitMap = applyAllImports unitMap
-  return $ mapMaybe (`M.lookup` processedUnitMap) inputs
+  case applyAllImports unitMap of
+    Right processedUnitMap ->
+      return $ mapMaybe (`M.lookup` processedUnitMap) inputs
+    Left cyclicInputs -> throwM $ CyclicInputs cyclicInputs
 
 
 

test/Eucalypt/Core/ImportSpec.hs

@@ -3,6 +3,7 @@ module Eucalypt.Core.ImportSpec
   , spec
   ) where
 
+import Data.Either (fromLeft, fromRight)
 import qualified Data.Map as M
 import Data.Maybe (fromJust)
 import qualified Data.Set as S
@@ -103,16 +104,145 @@ unitsABC :: M.Map Input TranslationUnit
 unitsABC =
   M.fromList [(unitAInput, unitA), (unitBInput, unitB), (unitCInput, unitC)]
 
+namedInput :: Input
+namedInput = fromJust $ parseInputFromString "namedInput"
+
+namedUnit :: TranslationUnit
+namedUnit = applyName "name"
+  TranslationUnit
+    { truCore = unitACore
+    , truImports = mempty
+    , truTargets = mempty
+    }
+
+unitDInput :: Input
+unitDInput = fromJust $ parseInputFromString "unitD"
+
+unitDCore :: CoreExpr
+unitDCore =
+  letexp
+    [ ( "nest"
+      , withMeta (block [element "import" $ str "namedInput"]) $
+        block [element "name" $ var "name"])
+    ] $
+  block [element "quux" $ var "quux"]
+
+unitDCoreResult :: CoreExpr
+unitDCoreResult =
+  letexp
+    [ ( "nest"
+      , withMeta (block []) $
+        letexp
+          [ ( "name"
+            , letexp [("foo", sym "foo"), ("bar", sym "bar")] $
+              block [element "foo" $ var "foo", element "bar" $ var "bar"])
+          ] $
+        block [element "name" $ var "name"])
+    ] $
+  block [element "quux" $ var "quux"]
+
+unitD :: TranslationUnit
+unitD =
+  TranslationUnit
+    { truCore = unitDCore
+    , truImports = S.fromList [namedInput]
+    , truTargets = mempty
+    }
+
+unitsNamedAndD :: M.Map Input TranslationUnit
+unitsNamedAndD =
+  M.fromList [(namedInput, namedUnit), (unitDInput, unitD)]
+
+
+importUnderImportInput :: Input
+importUnderImportInput = fromJust $ parseInputFromString "importUnderImport"
+
+importUnderImportCore :: CoreExpr
+importUnderImportCore =
+  withMeta (block [element "import" $ str "unitA"]) $
+  letexp
+    [ ( "nest"
+      , withMeta (block [element "import" $ str "unitA"]) $
+        block [element "foo" $ var "foo"])
+    ] $
+  block [element "foo" $ var "foo"]
+
+importUnderImportCoreResult :: CoreExpr
+importUnderImportCoreResult =
+  withMeta (block []) $
+  letexp [("foo", sym "foo"), ("bar", sym "bar")] $
+  letexp
+    [ ( "nest"
+      , withMeta (block []) $
+        letexp [("foo", sym "foo"), ("bar", sym "bar")] $
+        block [element "foo" $ var "foo"])
+    ] $
+  block [element "foo" $ var "foo"]
+
+
+importUnderImport :: TranslationUnit
+importUnderImport =
+  TranslationUnit
+    { truCore = importUnderImportCore
+    , truImports = S.fromList [unitAInput]
+    , truTargets = mempty
+    }
+
+unitsImportUnderImportAndA :: M.Map Input TranslationUnit
+unitsImportUnderImportAndA =
+  M.fromList [(unitAInput, unitA), (importUnderImportInput, importUnderImport)]
+
+circularImportInput :: Input
+circularImportInput = fromJust $ parseInputFromString "circularImport"
+
+circularImportCore :: CoreExpr
+circularImportCore =
+  letexp
+    [ ( "z"
+      , withMeta (block [element "import" $ str "circularImport"]) $
+        block [element "foo" $ var "foo"])
+    ] $
+  block [element "z" $ var "z"]
+
+circularImport :: TranslationUnit
+circularImport =
+  TranslationUnit
+    { truCore = circularImportCore
+    , truImports = S.fromList [circularImportInput]
+    , truTargets = mempty
+    }
+
+unitsCircularImport :: M.Map Input TranslationUnit
+unitsCircularImport =
+  M.fromList [(circularImportInput, circularImport)]
+
+importAll :: M.Map Input TranslationUnit -> M.Map Input TranslationUnit
+importAll = fromRight mempty . applyAllImports
+
 spec :: Spec
 spec =
   describe "Import processing" $ do
     context "single imports" $ do
       it "processes a single import" $
         processImports (const unitACore) unitBCore `shouldBe` unitBCoreResult
       it "processes single import from unit map" $
-        truCore <$> M.lookup unitBInput (applyAllImports unitsAB) `shouldBe` Just unitBCoreResult
+        truCore <$>
+        M.lookup unitBInput (importAll unitsAB) `shouldBe` Just unitBCoreResult
+      it "processes single named import from unit map" $
+        truCore <$>
+        M.lookup unitDInput (importAll unitsNamedAndD) `shouldBe`
+        Just unitDCoreResult
+      it "processes imports under imports" $
+        truCore <$>
+        M.lookup importUnderImportInput (importAll unitsImportUnderImportAndA) `shouldBe`
+        Just importUnderImportCoreResult
+      it "handles circular imports gracefully" $
+        fromLeft [] (applyAllImports unitsCircularImport) `shouldBe`
+        [circularImportInput]
     context "transitive imports" $ do
       it "intermediates are correct" $
-        truCore <$> M.lookup unitBInput (applyAllImports unitsABC) `shouldBe` Just unitBCoreResult
+        truCore <$>
+        M.lookup unitBInput (importAll unitsABC) `shouldBe` Just unitBCoreResult
       it "end result is correct" $
-        truCore <$> M.lookup unitCInput (applyAllImports unitsABC) `shouldBe` Just unitCCoreResult
+        truCore <$>
+        M.lookup unitCInput (importAll unitsABC) `shouldBe` Just unitCCoreResult

test/Eucalypt/Core/MetadataSpec.hs

@@ -0,0 +1,20 @@
+module Eucalypt.Core.MetadataSpec
+  ( main
+  , spec
+  ) where
+
+import Eucalypt.Core.Metadata
+import Eucalypt.Core.Syn
+import Eucalypt.Syntax.Input
+import Test.Hspec
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec =
+  describe "import recognition" $
+  it "recognises imports in { import: \"a=blah\" }" $
+  importsFromMetadata (block [element "import" $ str "a=blah"] :: CoreExpr) `shouldBe`
+  pure <$>
+  parseInputFromString "a=blah"