From d4d451aac1256f9b5b88217b00cc134d74b7262b Mon Sep 17 00:00:00 2001 From: Ian Grant Jeffries Date: Sat, 9 Nov 2019 17:42:02 -0500 Subject: [PATCH] Remove withCurrentDirctory ".." hack ...from bowtie tests. Also change style. --- bowtie-blueprint/src/Bowtie/Blueprint.hs | 2 +- bowtie-blueprint/test/Test.hs | 6 +-- bowtie-js/test/Test.hs | 6 +-- bowtie-visualize/src/Bowtie/Visualize.hs | 7 +-- bowtie/src/Bowtie/Infer/Solve.hs | 7 +-- bowtie/src/Bowtie/Infer/Unify.hs | 48 +++++++++----------- bowtie/src/Bowtie/Surface/Infer.hs | 7 +-- bowtie/test/Test.hs | 58 +++++++++++------------- 8 files changed, 67 insertions(+), 74 deletions(-) diff --git a/bowtie-blueprint/src/Bowtie/Blueprint.hs b/bowtie-blueprint/src/Bowtie/Blueprint.hs index cbabea9..a1f5900 100644 --- a/bowtie-blueprint/src/Bowtie/Blueprint.hs +++ b/bowtie-blueprint/src/Bowtie/Blueprint.hs @@ -77,7 +77,7 @@ parseBlueprint = programTypesParser :: Parse.Parser [Item] programTypesParser = do res <- - many $ Mega.try $ do + many $ Mega.try do _ <- Lexer.indentGuard Parse.spacesOrNewlines EQ Mega.pos1 parseOne _ <- Lexer.indentGuard Parse.spacesOrNewlines EQ Mega.pos1 diff --git a/bowtie-blueprint/test/Test.hs b/bowtie-blueprint/test/Test.hs index 5bd3dff..f48f6b4 100644 --- a/bowtie-blueprint/test/Test.hs +++ b/bowtie-blueprint/test/Test.hs @@ -18,17 +18,17 @@ main :: IO () main = do blueprintExamples <- getBlueprintExamples - hspec $ do + hspec do describe "blueprint" $ for_ blueprintExamples g where g :: FilePath -> Spec g path = - it path $ do + it path do src <- TIO.readFile (dir path) case blueprint src of - Left e -> do + Left e -> expectationFailure (Text.unpack e) Right _ -> diff --git a/bowtie-js/test/Test.hs b/bowtie-js/test/Test.hs index f1067c0..216c159 100644 --- a/bowtie-js/test/Test.hs +++ b/bowtie-js/test/Test.hs @@ -14,7 +14,7 @@ import qualified Data.Text.IO as TIO main :: IO () main = - hspec $ do + hspec do describe "well-typed-examples" (for_ Bowtie.Example.wellTyped runWellTyped) @@ -25,7 +25,7 @@ main = runWellTyped :: (FilePath, Text) -> Spec runWellTyped (name, src) = - it name $ do + it name do js <- case transpile src of Left e -> exitWithError (prettyError e) @@ -39,7 +39,7 @@ runWellTyped (name, src) = testApps :: Spec testApps = - it "lunar-lander" $ do + it "lunar-lander" do appSource <- TIO.readFile "../example-app/lunar-lander.bowtie" libFiles <- readDirectoryFiles "../example-lib" -- TODO: wasted work -- TODO: get rid of .. diff --git a/bowtie-visualize/src/Bowtie/Visualize.hs b/bowtie-visualize/src/Bowtie/Visualize.hs index b82b8b4..1d56dde 100644 --- a/bowtie-visualize/src/Bowtie/Visualize.hs +++ b/bowtie-visualize/src/Bowtie/Visualize.hs @@ -66,9 +66,10 @@ solutionSteps :: (MonadState Int m, MonadError SolveError m) => Constraints -> m solutionSteps cs = do case next cs of Nothing -> - if Constraints.isEmpty cs - then pure mempty - else throwError SolveStuck + if Constraints.isEmpty cs then + pure mempty + else + throwError SolveStuck Just (c, rest) -> do (_sub, rest2) <- mapError SolveUnifyError (solveConstraint c rest) diff --git a/bowtie/src/Bowtie/Infer/Solve.hs b/bowtie/src/Bowtie/Infer/Solve.hs index b7f42be..946f13d 100644 --- a/bowtie/src/Bowtie/Infer/Solve.hs +++ b/bowtie/src/Bowtie/Infer/Solve.hs @@ -21,9 +21,10 @@ solve :: (MonadState Int m, MonadError SolveError m) => Constraints -> m Substit solve cs = do case next cs of Nothing -> - if Constraints.isEmpty cs - then pure mempty - else throwError SolveStuck + if Constraints.isEmpty cs then + pure mempty + else + throwError SolveStuck Just (c, rest) -> do (sub, rest2) <- mapError SolveUnifyError (solveConstraint c rest) diff --git a/bowtie/src/Bowtie/Infer/Unify.hs b/bowtie/src/Bowtie/Infer/Unify.hs index 8dc6c4b..abd7a48 100644 --- a/bowtie/src/Bowtie/Infer/Unify.hs +++ b/bowtie/src/Bowtie/Infer/Unify.hs @@ -44,36 +44,32 @@ unify t1 t2 = -- 5. It returns the composition of these, substituting Int for 1, -- followed by Int for 0. - if t1 == t2 - then - Right mempty + if t1 == t2 then + Right mempty + else + case (t1, t2) of + (TVariable id, _) -> + unifyVariable id t2 - else - case (t1, t2) of - (TVariable id, _) -> - unifyVariable id t2 + (_, TVariable id) -> + unifyVariable id t1 - (_, TVariable id) -> - unifyVariable id t1 + (TArrow arg1 res1, TArrow arg2 res2) -> do + s1 <- unify arg1 arg2 + s2 <- unify (substType s1 res1) (substType s1 res2) + Right (s1 <> s2) - (TArrow arg1 res1, TArrow arg2 res2) -> do - s1 <- unify arg1 arg2 - s2 <- unify (substType s1 res1) (substType s1 res2) - Right (s1 <> s2) + (TypeApp a1 b1, TypeApp a2 b2) -> do + s1 <- unify a1 a2 + s2 <- unify (substType s1 b1) (substType s1 b2) + Right (s1 <> s2) - (TypeApp a1 b1, TypeApp a2 b2) -> do - s1 <- unify a1 a2 - s2 <- unify (substType s1 b1) (substType s1 b2) - Right (s1 <> s2) - - _ -> - Left (UnifyError t1 t2) + _ -> + Left (UnifyError t1 t2) where unifyVariable :: Id -> Type -> Either UnifyError Substitution unifyVariable id typ = - if Set.member id (freeVars typ) - then - Left (OccursCheckFailed id typ) - - else - Right (singleSub id typ) + if Set.member id (freeVars typ) then + Left (OccursCheckFailed id typ) + else + Right (singleSub id typ) diff --git a/bowtie/src/Bowtie/Surface/Infer.hs b/bowtie/src/Bowtie/Surface/Infer.hs index ce3f7d1..616dc3a 100644 --- a/bowtie/src/Bowtie/Surface/Infer.hs +++ b/bowtie/src/Bowtie/Surface/Infer.hs @@ -67,9 +67,10 @@ gatherConstraints env expr = do remaining :: Set Id remaining = Set.difference (Assumptions.keys a) (Environment.keys env) - if Set.null remaining - then pure () - else throwError (AssumptionsRemain a) + if Set.null remaining then + pure () + else + throwError (AssumptionsRemain a) pure (c <> explicitConstraintOnSet env a, t) diff --git a/bowtie/test/Test.hs b/bowtie/test/Test.hs index 5b432bb..8a983a8 100644 --- a/bowtie/test/Test.hs +++ b/bowtie/test/Test.hs @@ -14,41 +14,35 @@ import qualified Data.Text as Text import qualified Data.Text.IO as TIO import qualified Text.Megaparsec as Mega -dir :: FilePath -dir = - "example-app" - main :: IO () main = do - -- hack, because changing dir to "../app" makes listDirectory fail. - withCurrentDirectory ".." do - appExamples <- (fmap.fmap) (\p -> dir p) getAppExamples - hspec do - describe - "valid-syntax-examples" - (for_ Bowtie.Example.validSyntax run) - - describe - "invalid-syntax-examples" - (for_ Bowtie.Example.invalidSyntax runInvalidSyntax) - - describe - "well-typed-examples" - (for_ Bowtie.Example.wellTyped run) - - describe - "ill-typed-examples" - (for_ Bowtie.Example.illTyped runIllTyped) - - Bowtie.Surface.InferSpec.spec - - describe "example-app" $ - for_ appExamples f + appExamples <- getAppExamples + hspec do + describe + "valid-syntax-examples" + (for_ Bowtie.Example.validSyntax run) + + describe + "invalid-syntax-examples" + (for_ Bowtie.Example.invalidSyntax runInvalidSyntax) + + describe + "well-typed-examples" + (for_ Bowtie.Example.wellTyped run) + + describe + "ill-typed-examples" + (for_ Bowtie.Example.illTyped runIllTyped) + + Bowtie.Surface.InferSpec.spec + + describe "example-app" $ + for_ appExamples f where f :: FilePath -> Spec f path = it path do - libFiles <- readDirectoryFiles "example-lib" -- TODO: wasted work + libFiles <- readDirectoryFiles "../example-lib" -- TODO: wasted work appSource <- TIO.readFile path case Interpret.interpretProgram libFiles (path, appSource) of Left e -> @@ -67,7 +61,7 @@ runInvalidSyntax (name, src) = case Surface.Parse.parse name src of Left e -> TIO.writeFile - ("bowtie" "test" "invalid-syntax-examples" name) + ("test" "invalid-syntax-examples" name) (Text.pack (Mega.errorBundlePretty e)) Right _ -> @@ -89,7 +83,7 @@ runIllTyped (name, src) = Interpret.TypeError e -> TIO.writeFile - ("bowtie" "test" "ill-typed-examples" name) + ("test" "ill-typed-examples" name) (show e) Right _ -> @@ -97,7 +91,7 @@ runIllTyped (name, src) = getAppExamples :: IO [FilePath] getAppExamples = do - appPaths <- listDirectory dir + appPaths <- (fmap.fmap) ("../example-app" ) (listDirectory "../example-app") let (langs, other) = List.partition (\path -> takeExtension path == ".bowtie") appPaths