From 14202fdf9106a57bdb02805668eb3e5b56d233cb Mon Sep 17 00:00:00 2001 From: Ian Grant Jeffries Date: Sat, 9 May 2020 17:34:05 -0400 Subject: [PATCH] Format: ormolu --- .dir-locals.el | 4 + .stylish-haskell.yaml | 44 ---- bowtie-blueprint/Main.hs | 12 +- bowtie-blueprint/src/Bowtie/Blueprint.hs | 60 +++--- bowtie-blueprint/test/Test.hs | 14 +- bowtie-js/Main.hs | 15 +- bowtie-js/src/Bowtie/JS.hs | 51 ++--- bowtie-js/src/Bowtie/JS/AST.hs | 16 +- bowtie-js/src/Bowtie/JS/Imperativize.hs | 122 +++++------ bowtie-js/src/Bowtie/JS/Serialize.hs | 27 +-- bowtie-js/test/Test.hs | 26 +-- bowtie-visualize/Main.hs | 12 +- bowtie-visualize/src/Bowtie/Visualize.hs | 90 ++++---- .../src/Bowtie/Visualize/GraphConstraints.hs | 38 ++-- bowtie/Main.hs | 15 +- bowtie/doctest/DocTest.hs | 41 ++-- bowtie/package.yaml | 2 +- bowtie/src/Bowtie/Core/Expr.hs | 37 ++-- bowtie/src/Bowtie/Infer/Assumptions.hs | 16 +- bowtie/src/Bowtie/Infer/BottomUp.hs | 193 ++++++++--------- bowtie/src/Bowtie/Infer/Constraints.hs | 29 ++- bowtie/src/Bowtie/Infer/Elaborate.hs | 20 +- bowtie/src/Bowtie/Infer/Generalize.hs | 18 +- bowtie/src/Bowtie/Infer/Solve.hs | 55 ++--- bowtie/src/Bowtie/Infer/Substitution.hs | 23 +-- bowtie/src/Bowtie/Infer/Unify.hs | 48 ++--- bowtie/src/Bowtie/Interpret.hs | 113 +++++----- bowtie/src/Bowtie/Lib/Environment.hs | 4 +- bowtie/src/Bowtie/Lib/OrderedMap.hs | 61 +++--- bowtie/src/Bowtie/Lib/Prelude.hs | 26 ++- bowtie/src/Bowtie/Lib/TypeScheme.hs | 4 +- bowtie/src/Bowtie/Surface/AST.hs | 38 ++-- bowtie/src/Bowtie/Surface/Desugar.hs | 195 ++++++++---------- bowtie/src/Bowtie/Surface/Infer.hs | 67 +++--- bowtie/src/Bowtie/Surface/Parse.hs | 89 ++++---- bowtie/src/Bowtie/Type/AST.hs | 9 +- bowtie/src/Bowtie/Type/Kindcheck.hs | 32 ++- bowtie/src/Bowtie/Type/Parse.hs | 112 +++++----- bowtie/src/Bowtie/Untyped/Erase.hs | 24 +-- bowtie/src/Bowtie/Untyped/Eval.hs | 84 +++----- bowtie/src/Bowtie/Untyped/Expr.hs | 36 +--- bowtie/test/Bowtie/Surface/InferSpec.hs | 77 +++---- bowtie/test/Test.hs | 21 +- bowtie/test/Test/Quoted/AST.hs | 13 +- bowtie/test/Test/Quoted/Expr.hs | 32 +-- bowtie/test/Test/Shared.hs | 7 +- spec/src/Bowtie/Example.hs | 14 +- 47 files changed, 881 insertions(+), 1205 deletions(-) create mode 100644 .dir-locals.el delete mode 100644 .stylish-haskell.yaml diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 0000000..4cf3418 --- /dev/null +++ b/.dir-locals.el @@ -0,0 +1,4 @@ +; emacs config + +((haskell-mode + (mode . ormolu-format-0.0.5.0-on-save))) diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml deleted file mode 100644 index c6b1191..0000000 --- a/.stylish-haskell.yaml +++ /dev/null @@ -1,44 +0,0 @@ -# https://github.com/jaspervdj/stylish-haskell - -steps: - - simple_align: - cases: false - top_level_patterns: false - records: false - - imports: - align: group - list_align: after_alias - pad_module_names: false - long_list_align: new_line - empty_list_align: inherit - list_padding: 2 - separate_lists: false - space_surround: false - - language_pragmas: - style: vertical - align: false - remove_redundant: false - - tabs: - spaces: 2 - - trailing_whitespace: {} -columns: 80 -newline: lf -language_extensions: - - BlockArguments - - DeriveAnyClass - - DeriveDataTypeable - - DeriveFunctor - - DeriveGeneric - - DerivingStrategies - - ExistentialQuantification - - FlexibleContexts - - FlexibleInstances - - FunctionalDependencies - - GeneralizedNewtypeDeriving - - InstanceSigs - - MultiParamTypeClasses - - NoImplicitPrelude - - OverloadedStrings - - RankNTypes - - ScopedTypeVariables - - StrictData diff --git a/bowtie-blueprint/Main.hs b/bowtie-blueprint/Main.hs index c4dced9..1368bd9 100644 --- a/bowtie-blueprint/Main.hs +++ b/bowtie-blueprint/Main.hs @@ -2,9 +2,8 @@ module Main (main) where import Bowtie.Blueprint import Bowtie.Lib.Prelude -import Options.Applicative - import qualified Data.Text.IO as TIO +import Options.Applicative main :: IO () main = do @@ -25,7 +24,8 @@ configParser = parser :: Parser Config parser = Config - <$> argument str - ( metavar "FILE" - <> help "Path to source file" - ) + <$> argument + str + ( metavar "FILE" + <> help "Path to source file" + ) diff --git a/bowtie-blueprint/src/Bowtie/Blueprint.hs b/bowtie-blueprint/src/Bowtie/Blueprint.hs index 8bc3642..23eff85 100644 --- a/bowtie-blueprint/src/Bowtie/Blueprint.hs +++ b/bowtie-blueprint/src/Bowtie/Blueprint.hs @@ -2,7 +2,6 @@ module Bowtie.Blueprint where import Bowtie.Lib.Prelude import Bowtie.Type.AST (Type, TypeDeclaration) - import qualified Bowtie.Type.Parse as Parse import qualified CMark import qualified Data.HashMap.Strict as HashMap @@ -20,26 +19,22 @@ data Item blueprint :: Text -> Either Text Blueprint blueprint src = do - let - node :: CMark.Node - node = - CMark.commonmarkToNode mempty src - - codeBlocks :: [Text] - codeBlocks = - extractCode node + let node :: CMark.Node + node = + CMark.commonmarkToNode mempty src + codeBlocks :: [Text] + codeBlocks = + extractCode node code <- case codeBlocks of - [] -> - Left "no code found in markdown file" - - _ -> - pure (Text.intercalate "\n" codeBlocks) + [] -> + Left "no code found in markdown file" + _ -> + pure (Text.intercalate "\n" codeBlocks) case parseBlueprint code of Left e -> do Left (Text.pack (Mega.errorBundlePretty e)) - Right bp -> do pure bp @@ -48,7 +43,6 @@ blueprintIO src = case blueprint src of Left e -> exitWithError e - Right bp -> pure bp @@ -58,17 +52,24 @@ conv items = where decls :: HashMap Id TypeDeclaration decls = - let xs = mapMaybe (\a -> case a of - Decl id def -> Just (id, def) - Func {} -> Nothing) items - in HashMap.fromList xs - + let xs = + mapMaybe + ( \a -> case a of + Decl id def -> Just (id, def) + Func {} -> Nothing + ) + items + in HashMap.fromList xs funcs :: HashMap Id Type funcs = - let xs = mapMaybe (\a -> case a of - Func id def -> Just (id, def) - Decl {} -> Nothing) items - in HashMap.fromList xs + let xs = + mapMaybe + ( \a -> case a of + Func id def -> Just (id, def) + Decl {} -> Nothing + ) + items + in HashMap.fromList xs parseBlueprint :: Text -> Either (Mega.ParseErrorBundle Text Void) Blueprint parseBlueprint = @@ -85,9 +86,10 @@ programTypesParser = do parseOne :: Parse.Parser Item parseOne = - Mega.label "parseOne" - ( Mega.try (fmap (uncurry Decl) Parse.typeDeclarationParser) - <|> Mega.try (fmap (uncurry Func) Parse.typeSignatureParser) + Mega.label + "parseOne" + ( Mega.try (fmap (uncurry Decl) Parse.typeDeclarationParser) + <|> Mega.try (fmap (uncurry Func) Parse.typeSignatureParser) ) -- * Markdown @@ -101,9 +103,7 @@ extractCode (CMark.Node _ nodeType nodes) = case nt of CMark.CODE_BLOCK _ t -> [t] - CMark.CODE _ -> mempty - _ -> mempty diff --git a/bowtie-blueprint/test/Test.hs b/bowtie-blueprint/test/Test.hs index f48f6b4..8bf53cd 100644 --- a/bowtie-blueprint/test/Test.hs +++ b/bowtie-blueprint/test/Test.hs @@ -2,13 +2,12 @@ module Main where import Bowtie.Blueprint import Bowtie.Lib.Prelude -import System.Directory -import System.FilePath (takeExtension, ()) -import Test.Hspec - import qualified Data.List as List import qualified Data.Text as Text import qualified Data.Text.IO as TIO +import System.Directory +import System.FilePath ((), takeExtension) +import Test.Hspec dir :: FilePath dir = @@ -21,7 +20,6 @@ main = do hspec do describe "blueprint" $ for_ blueprintExamples g - where g :: FilePath -> Spec g path = @@ -30,16 +28,14 @@ main = do case blueprint src of Left e -> expectationFailure (Text.unpack e) - Right _ -> pure () getBlueprintExamples :: IO [FilePath] getBlueprintExamples = do appPaths <- listDirectory dir - let - (blueprints, other) = - List.partition (\path -> takeExtension path == ".md") appPaths + let (blueprints, other) = + List.partition (\path -> takeExtension path == ".md") appPaths when (other /= mempty) diff --git a/bowtie-js/Main.hs b/bowtie-js/Main.hs index c093b0d..f47184f 100644 --- a/bowtie-js/Main.hs +++ b/bowtie-js/Main.hs @@ -1,11 +1,10 @@ module Main where +import qualified Bowtie.Interpret as Interpret import Bowtie.JS import Bowtie.Lib.Prelude -import Options.Applicative - -import qualified Bowtie.Interpret as Interpret import qualified Data.Text.IO as TIO +import Options.Applicative main :: IO () main = do @@ -15,7 +14,6 @@ main = do case Interpret.sourcesToCore libFiles (name, appSource) of Left e -> exitWithError (Interpret.prettyError e) - Right (env, coreExpr) -> TIO.putStrLn (transpileCore env coreExpr) @@ -32,7 +30,8 @@ configParser = parser :: Parser Config parser = Config - <$> argument str - ( metavar "FILE" - <> help "Path to source file" - ) + <$> argument + str + ( metavar "FILE" + <> help "Path to source file" + ) diff --git a/bowtie-js/src/Bowtie/JS.hs b/bowtie-js/src/Bowtie/JS.hs index 0eb183a..9b740a3 100644 --- a/bowtie-js/src/Bowtie/JS.hs +++ b/bowtie-js/src/Bowtie/JS.hs @@ -1,26 +1,26 @@ {-# LANGUAGE QuasiQuotes #-} module Bowtie.JS - ( transpile - , transpileCore - , transpileAndExecute - , appendConsoleLog - , runTextCommand - ) where + ( transpile, + transpileCore, + transpileAndExecute, + appendConsoleLog, + runTextCommand, + ) +where +import qualified Bowtie.Core.Expr as Core +import qualified Bowtie.Interpret as Interpret import Bowtie.JS.Imperativize (makeImp) import Bowtie.JS.Serialize (serializeTop) import Bowtie.Lib.Environment import Bowtie.Lib.Prelude +import qualified Data.ByteString.Lazy as LBS import Data.String.QQ (s) +import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8) import System.Process.Typed -import qualified Bowtie.Core.Expr as Core -import qualified Bowtie.Interpret as Interpret -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Text as Text - -- | Internal. builtinJsSource :: Text builtinJsSource = @@ -53,10 +53,8 @@ transpile src = do transpileCore :: Environment -> Core.Expr -> Text transpileCore env expr = - let - jsAST = makeImp env expr - in - "'use strict';\n\n" <> builtinJsSource <> "\n" <> serializeTop jsAST + let jsAST = makeImp env expr + in "'use strict';\n\n" <> builtinJsSource <> "\n" <> serializeTop jsAST transpileAndExecute :: Text -> IO Text transpileAndExecute src = do @@ -70,20 +68,24 @@ appendConsoleLog js = -- * Below should be in a lib somewhere -- | NOTE: Only used with trused input! -runTextCommand - :: Text -- ^ Command injection vulnerability when passed untrusted input. - -> Text -- ^ Command injection vulnerability when passed untrusted input. - -> IO Text +runTextCommand :: + -- | Command injection vulnerability when passed untrusted input. + Text -> + -- | Command injection vulnerability when passed untrusted input. + Text -> + IO Text runTextCommand cmd input = do res <- runCommand cmd "" (encodeUtf8 input) pure (decodeUtf8 res) -- todo -- | NOTE: Only used with trused input! -runCommand - :: Text -- ^ Command injection vulnerability when passed untrusted input. - -> Text -- ^ Command injection vulnerability when passed untrusted input. - -> ByteString - -> IO ByteString +runCommand :: + -- | Command injection vulnerability when passed untrusted input. + Text -> + -- | Command injection vulnerability when passed untrusted input. + Text -> + ByteString -> + IO ByteString runCommand cmd arg input = do fmap LBS.toStrict (readProcessStdout_ proc2) where @@ -91,7 +93,6 @@ runCommand cmd arg input = do proc1 :: ProcessConfig () () () proc1 = shell (Text.unpack cmd <> " " <> Text.unpack arg) - -- Command with argument and stdin proc2 :: ProcessConfig () () () proc2 = diff --git a/bowtie-js/src/Bowtie/JS/AST.hs b/bowtie-js/src/Bowtie/JS/AST.hs index f20e1fc..a39ef32 100644 --- a/bowtie-js/src/Bowtie/JS/AST.hs +++ b/bowtie-js/src/Bowtie/JS/AST.hs @@ -7,24 +7,24 @@ data AST = Var Id | Lam Id AST | App AST AST - | Assignment AST AST | Block [AST] | Return AST - | Array [AST] | IndexArray AST Natural | IfThen AST AST | Else AST | Throw AST -- Will only be used with JSString | Equal AST AST - | LambdaUnit AST -- ^ @(() => { " <> ast <> "})()@ - + | -- | @(() => { " <> ast <> "})()@ + LambdaUnit AST | JSInt Integer | JSString Text - | Compare AST AST - | Plus AST AST -- ^ Only works on Ints - | Multiply AST AST -- ^ Only works on Ints - | ShowInt AST -- ^ Only works on Int + | -- | Only works on Ints + Plus AST AST + | -- | Only works on Ints + Multiply AST AST + | -- | Only works on Int + ShowInt AST deriving (Eq, Show) diff --git a/bowtie-js/src/Bowtie/JS/Imperativize.hs b/bowtie-js/src/Bowtie/JS/Imperativize.hs index a9a3893..e4e7e47 100644 --- a/bowtie-js/src/Bowtie/JS/Imperativize.hs +++ b/bowtie-js/src/Bowtie/JS/Imperativize.hs @@ -1,17 +1,17 @@ module Bowtie.JS.Imperativize - ( makeImp - ) where + ( makeImp, + ) +where +import qualified Bowtie.Core.Expr as Core import Bowtie.JS.AST +import qualified Bowtie.JS.AST as JS import Bowtie.Lib.Environment import Bowtie.Lib.OrderedMap (OrderedMap) +import qualified Bowtie.Lib.OrderedMap as OrderedMap import Bowtie.Lib.Prelude import Bowtie.Lib.TypeScheme -import Bowtie.Type.AST (Type(..)) - -import qualified Bowtie.Core.Expr as Core -import qualified Bowtie.JS.AST as JS -import qualified Bowtie.Lib.OrderedMap as OrderedMap +import Bowtie.Type.AST (Type (..)) import qualified Data.HashMap.Strict as HashMap makeImp :: Environment -> Core.Expr -> JS.AST @@ -21,14 +21,10 @@ makeImp (Environment env) expr = conFuncs :: [JS.AST] conFuncs = fmap conTypeToFunction (hashmapToSortedList env) - (coreBindings, coreExpr) = packageUp expr - bindings = fmap assign (OrderedMap.toList coreBindings) - assign (id, e) = Assignment (Var id) (coreToImp e) - result = assign (Id "result", coreExpr) coreToImp :: Core.Expr -> JS.AST @@ -36,56 +32,50 @@ coreToImp topExpr = case topExpr of Core.Var id -> Var id - Core.Lam id _typ expr -> Lam id ((coreToImp expr)) - Core.App e1 e2 -> App (coreToImp e1) (coreToImp e2) - Core.Let bindings body -> - let - f :: (Id, (Core.Expr, typ)) -> AST - f (id, (expr, _)) = - Assignment (Var id) (coreToImp expr) - in - LambdaUnit - (Block - (addReturn - ( fmap f (hashmapToSortedList bindings) - <> [coreToImp body] -- PERFORMANCE - ))) - + let f :: (Id, (Core.Expr, typ)) -> AST + f (id, (expr, _)) = + Assignment (Var id) (coreToImp expr) + in LambdaUnit + ( Block + ( addReturn + ( fmap f (hashmapToSortedList bindings) + <> [coreToImp body] -- PERFORMANCE + ) + ) + ) Core.Construct id -> Var id - Core.Case expr alts -> - let - mkAssign :: (Natural, Id) -> AST - mkAssign (n, id) = - Assignment (Var id) (IndexArray (Var (Id "$1")) n) - - altToImp :: Core.Alt -> AST - altToImp (Core.Alt id args body) = - IfThen - (Equal - (IndexArray (Var (Id "$1")) 0) - (conToString id)) - (Block $ addReturn - ( fmap mkAssign (zip [1..] args) - <> [coreToImp body] -- PERFORMANCE - )) - in - LambdaUnit - (Block - ( Assignment (Var (Id "$1")) (coreToImp expr) - : fmap altToImp alts - <> [Else (Throw (JSString "no match"))] - )) - + let mkAssign :: (Natural, Id) -> AST + mkAssign (n, id) = + Assignment (Var id) (IndexArray (Var (Id "$1")) n) + altToImp :: Core.Alt -> AST + altToImp (Core.Alt id args body) = + IfThen + ( Equal + (IndexArray (Var (Id "$1")) 0) + (conToString id) + ) + ( Block $ + addReturn + ( fmap mkAssign (zip [1 ..] args) + <> [coreToImp body] -- PERFORMANCE + ) + ) + in LambdaUnit + ( Block + ( Assignment (Var (Id "$1")) (coreToImp expr) + : fmap altToImp alts + <> [Else (Throw (JSString "no match"))] + ) + ) Core.PrimInt n -> JSInt n - Core.PrimOp op -> coreOperationToImp op @@ -94,16 +84,12 @@ coreOperationToImp op = case op of Core.Compare e1 e2 -> Compare (coreToImp e1) (coreToImp e2) - Core.Plus e1 e2 -> Plus (coreToImp e1) (coreToImp e2) - Core.Multiply e1 e2 -> Multiply (coreToImp e1) (coreToImp e2) - Core.ShowInt expr -> ShowInt (coreToImp expr) - Core.Panic expr -> LambdaUnit (Throw (coreToImp expr)) @@ -120,33 +106,28 @@ conTypeToFunction (id, TypeScheme _ tsType) = where addLambdas :: [Id] -> JS.AST -> JS.AST addLambdas [] ast = ast - addLambdas (y:ys) ast = Lam y (addLambdas ys ast) - + addLambdas (y : ys) ast = Lam y (addLambdas ys ast) args :: [Id] args = f 1 tsType - f :: Natural -> Type -> [Id] f n typ = case typ of TVariable _ -> panic ("construct unexpected type" <> show typ) - TConstructor _ -> [] - TArrow _ t2 -> Id ("arg" <> show n) : f (n + 1) t2 - - TypeApp _ _ -> -- eg List a + TypeApp _ _ -> + -- eg List a [] addReturn :: [JS.AST] -> [JS.AST] addReturn ys = case reverse ys of - y:rest -> + y : rest -> reverse rest <> [Return y] -- PERFORMANCE - _ -> ys @@ -174,15 +155,12 @@ packageUp expr = case OrderedMap.fromList (HashMap.toList (fmap fst bindings)) of Left _ -> panic "shouldn't happen" - Right oBindings -> let (more, finalBody) = packageUp body - in case OrderedMap.append oBindings more of - Left _ -> - panic "also shouldn't happen" - - Right res -> - (res, finalBody) - + in case OrderedMap.append oBindings more of + Left _ -> + panic "also shouldn't happen" + Right res -> + (res, finalBody) _ -> (OrderedMap.empty, expr) diff --git a/bowtie-js/src/Bowtie/JS/Serialize.hs b/bowtie-js/src/Bowtie/JS/Serialize.hs index 1a68dd3..56acfdb 100644 --- a/bowtie-js/src/Bowtie/JS/Serialize.hs +++ b/bowtie-js/src/Bowtie/JS/Serialize.hs @@ -1,11 +1,11 @@ module Bowtie.JS.Serialize - ( serializeTop - , serialize - ) where + ( serializeTop, + serialize, + ) +where import Bowtie.JS.AST import Bowtie.Lib.Prelude - import qualified Data.Text as Text serializeTop :: AST -> Text @@ -13,7 +13,6 @@ serializeTop ast = case ast of Block xs -> Text.intercalate "\n" (fmap serialize xs) - _ -> serialize ast @@ -22,58 +21,40 @@ serialize topAst = case topAst of Var id -> serializeId id - Lam id ast -> serializeId id <> " => " <> serialize ast - App a1 a2 -> serialize a1 <> "(" <> serialize a2 <> ")" - Assignment a1 a2 -> "const " <> serialize a1 <> " = " <> serialize a2 <> ";" - Block asts -> Text.intercalate "\n" (fmap serialize asts) - Return ast -> "return " <> serialize ast - Array asts -> "[" <> Text.intercalate ", " (fmap serialize asts) <> "]" - IndexArray ast index -> serialize ast <> "[" <> show index <> "]" - IfThen a1 a2 -> "if (" <> serialize a1 <> ") { " <> serialize a2 <> "}" - Else ast -> " else { " <> serialize ast <> " }" - Throw ast -> "throw " <> serialize ast - Equal a1 a2 -> serialize a1 <> " === " <> serialize a2 - LambdaUnit ast -> "(() => { " <> serialize ast <> "})()" - JSInt n -> show n - JSString t -> "\"" <> t <> "\"" - Compare ast1 ast2 -> "$compareBuiltin(" <> serialize ast1 <> ", " <> serialize ast2 <> ")" - Plus ast1 ast2 -> "(" <> serialize ast1 <> " + " <> serialize ast2 <> ")" - Multiply ast1 ast2 -> "(" <> serialize ast1 <> " * " <> serialize ast2 <> ")" - ShowInt ast -> "$unicodeListizeBuiltin(" <> serialize ast <> ".toString())" diff --git a/bowtie-js/test/Test.hs b/bowtie-js/test/Test.hs index c3e9cc1..6c8646f 100644 --- a/bowtie-js/test/Test.hs +++ b/bowtie-js/test/Test.hs @@ -2,16 +2,15 @@ module Main where +import qualified Bowtie.Example import Bowtie.Interpret import Bowtie.JS import Bowtie.Lib.Prelude import Data.String.QQ (s) +import qualified Data.Text.IO as TIO import System.FilePath (()) import Test.Hspec -import qualified Bowtie.Example -import qualified Data.Text.IO as TIO - main :: IO () main = do libFiles <- readDirectoryFiles "../example-lib" @@ -28,11 +27,10 @@ runWellTyped :: (FilePath, Text) -> Spec runWellTyped (name, src) = it name do js <- case transpile src of - Left e -> - exitWithError (prettyError e) - - Right a -> - pure (appendConsoleLog a) + Left e -> + exitWithError (prettyError e) + Right a -> + pure (appendConsoleLog a) res <- runTextCommand "node" js let annotatedRes = res <> "\n\n/*\n" <> js <> "\n*/\n" @@ -43,14 +41,12 @@ testApps libFiles = it "lunar-lander" do appSource <- TIO.readFile "../example-app/lunar-lander.bowtie" js <- case sourcesToCore libFiles ("../example-app/lunar-lander.bowtie", appSource) of - Left e -> - exitWithError (prettyError e) - - Right (env, coreExpr) -> - pure (transpileCore env coreExpr <> exerciseLunarLander) + Left e -> + exitWithError (prettyError e) + Right (env, coreExpr) -> + pure (transpileCore env coreExpr <> exerciseLunarLander) runTextCommand "node" js - `shouldReturn` - "[ 'Step',\n [ 'Pictures', [ 'Cons', [Array], [Array] ] ],\n [Function] ]\n" + `shouldReturn` "[ 'Step',\n [ 'Pictures', [ 'Cons', [Array], [Array] ] ],\n [Function] ]\n" exerciseLunarLander :: Text exerciseLunarLander = diff --git a/bowtie-visualize/Main.hs b/bowtie-visualize/Main.hs index a4268f8..d7c05ab 100644 --- a/bowtie-visualize/Main.hs +++ b/bowtie-visualize/Main.hs @@ -2,9 +2,8 @@ module Main (main) where import Bowtie.Lib.Prelude import Bowtie.Visualize -import Options.Applicative - import qualified Data.Text.IO as TIO +import Options.Applicative main :: IO () main = do @@ -27,7 +26,8 @@ configParser = parser :: Parser Config parser = Config - <$> argument str - ( metavar "FILE" - <> help "Path to source file" - ) + <$> argument + str + ( metavar "FILE" + <> help "Path to source file" + ) diff --git a/bowtie-visualize/src/Bowtie/Visualize.hs b/bowtie-visualize/src/Bowtie/Visualize.hs index fdf1169..8ae3181 100644 --- a/bowtie-visualize/src/Bowtie/Visualize.hs +++ b/bowtie-visualize/src/Bowtie/Visualize.hs @@ -1,99 +1,94 @@ module Bowtie.Visualize - ( run - , writeConstraints - ) where + ( run, + writeConstraints, + ) +where import Bowtie.Infer.Assumptions (Assumptions) import Bowtie.Infer.Constraints +import qualified Bowtie.Infer.Constraints as Constraints import Bowtie.Infer.Solve import Bowtie.Infer.Unify +import qualified Bowtie.Interpret as Interpret import Bowtie.Lib.CanFailWith import Bowtie.Lib.Environment import Bowtie.Lib.Prelude -import Bowtie.Surface.AST (AST(astTerms, astTypes)) -import Bowtie.Type.Kindcheck (kindcheck) -import Bowtie.Visualize.GraphConstraints (graphConstraints) -import Control.Monad.State.Class -import System.Process.Typed - -import qualified Bowtie.Infer.Constraints as Constraints -import qualified Bowtie.Interpret as Interpret +import Bowtie.Surface.AST (AST (astTerms, astTypes)) import qualified Bowtie.Surface.AST as Surface import qualified Bowtie.Surface.Desugar as Surface.Desugar import qualified Bowtie.Surface.Infer as Infer +import Bowtie.Type.Kindcheck (kindcheck) +import Bowtie.Visualize.GraphConstraints (graphConstraints) +import Control.Monad.State.Class import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.List as List import qualified Data.Text as Text +import System.Process.Typed run :: HashMap FilePath Text -> (FilePath, Text) -> IO [Constraints] run libFiles appFile = do case Interpret.sourcesToAST libFiles appFile of Left e -> exitWithError (Interpret.prettyError (Interpret.toBowtieError e)) - Right ast -> do - let - env :: Environment - env = - kindcheck (astTypes ast) - - dsg :: Surface.Expr - dsg = - Surface.Desugar.extractResult (astTerms ast) + let env :: Environment + env = + kindcheck (astTypes ast) + dsg :: Surface.Expr + dsg = + Surface.Desugar.extractResult (astTerms ast) - let - f :: ( MonadState Int m - , CanFailWith SolveStuck m - , CanFailWith UnifyError m - , CanFailWith Assumptions m - ) => m [Constraints] - f = do - (constraints, _) <- Infer.gatherConstraints env dsg - solutionSteps constraints + let f :: + ( MonadState Int m, + CanFailWith SolveStuck m, + CanFailWith UnifyError m, + CanFailWith Assumptions m + ) => + m [Constraints] + f = do + (constraints, _) <- Infer.gatherConstraints env dsg + solutionSteps constraints case Infer.runInfer f of Left e -> throwText (show e) - Right constraints -> pure constraints writeConstraints :: [Constraints] -> IO () writeConstraints cs = - for_ (List.zip cs [1..]) f + for_ (List.zip cs [1 ..]) f where f :: (Constraints, Natural) -> IO () f (c, n) = do bts <- runCommand "dot" "-Tsvg" (encodeUtf8 (graphConstraints c)) BS.writeFile (Text.unpack (show n <> ".svg")) bts -solutionSteps - :: (MonadState Int m, CanFailWith SolveStuck m, CanFailWith UnifyError m) - => Constraints - -> m [Constraints] +solutionSteps :: + (MonadState Int m, CanFailWith SolveStuck m, CanFailWith UnifyError m) => + Constraints -> + m [Constraints] solutionSteps cs = do case next cs of Nothing -> if Constraints.isEmpty cs - then - pure mempty - - else - failWith SolveStuckError - + then pure mempty + else failWith SolveStuckError Just (c, rest) -> do (_sub, rest2) <- solveConstraint c rest - fmap (rest:) (solutionSteps rest2) + fmap (rest :) (solutionSteps rest2) -- | Below should be in a lib somewhere -- -- NOTE: Only used with trused input! -runCommand - :: Text -- ^ Command injection vulnerability when passed untrusted input. - -> Text -- ^ Command injection vulnerability when passed untrusted input. - -> ByteString - -> IO ByteString +runCommand :: + -- | Command injection vulnerability when passed untrusted input. + Text -> + -- | Command injection vulnerability when passed untrusted input. + Text -> + ByteString -> + IO ByteString runCommand cmd arg input = do fmap LBS.toStrict (readProcessStdout_ proc2) where @@ -101,7 +96,6 @@ runCommand cmd arg input = do proc1 :: ProcessConfig () () () proc1 = shell (Text.unpack cmd <> " " <> Text.unpack arg) - -- Command with argument and stdin proc2 :: ProcessConfig () () () proc2 = diff --git a/bowtie-visualize/src/Bowtie/Visualize/GraphConstraints.hs b/bowtie-visualize/src/Bowtie/Visualize/GraphConstraints.hs index 4dcad17..cac7ac3 100644 --- a/bowtie-visualize/src/Bowtie/Visualize/GraphConstraints.hs +++ b/bowtie-visualize/src/Bowtie/Visualize/GraphConstraints.hs @@ -3,11 +3,10 @@ module Bowtie.Visualize.GraphConstraints where import Bowtie.Infer.Constraints +import qualified Bowtie.Infer.Constraints as Constraints import Bowtie.Lib.Prelude import Bowtie.Lib.TypeScheme import Bowtie.Type.AST - -import qualified Bowtie.Infer.Constraints as Constraints import qualified Data.GraphViz as GV import qualified Data.GraphViz.Attributes as Attributes import qualified Data.GraphViz.Printing as GP @@ -27,29 +26,24 @@ prettyType t = case t of TArrow t1 t2 -> prettyType t1 <> " -> " <> prettyType t2 - TConstructor (Id id) -> id - TVariable (Id id) -> id - TypeApp _ _ -> "TypeApp" -ff :: Set Constraint -> [(TypeScheme,TypeScheme,Constraint)] +ff :: Set Constraint -> [(TypeScheme, TypeScheme, Constraint)] ff cs = fmap f (Set.toList cs) where - f :: Constraint -> (TypeScheme,TypeScheme,Constraint) + f :: Constraint -> (TypeScheme, TypeScheme, Constraint) f c = case c of EqualityConstraint t1 t2 -> (TypeScheme mempty t1, TypeScheme mempty t2, c) - ExplicitInstanceConstraint t ts -> (TypeScheme mempty t, ts, c) - ImplicitInstanceConstraint t1 _ t2 -> (TypeScheme mempty t1, TypeScheme mempty t2, c) @@ -60,37 +54,31 @@ graphConstraints cst@(Constraints cs) = dot :: GP.DotCode dot = GP.toDot graphInDotFormat - graphInDotFormat :: GV.DotGraph TypeScheme graphInDotFormat = GV.graphElemsToDot params nodes edges - - nodes :: [(TypeScheme,Text)] + nodes :: [(TypeScheme, Text)] nodes = fmap (\c -> (c, "todo")) (Set.toList (Constraints.toTypeSchemes cst)) - - edges :: [(TypeScheme,TypeScheme,Constraint)] + edges :: [(TypeScheme, TypeScheme, Constraint)] edges = ff cs params :: GV.GraphvizParams TypeScheme Text Constraint () Text params = GV.nonClusteredParams - { GV.fmtNode = nodeFmt - , GV.fmtEdge = edgeFmt + { GV.fmtNode = nodeFmt, + GV.fmtEdge = edgeFmt } where - nodeFmt :: (TypeScheme,Text) -> [GV.Attribute] - nodeFmt (_,_) = [] -- [GV.toLabel l] - + nodeFmt :: (TypeScheme, Text) -> [GV.Attribute] + nodeFmt (_, _) = [] -- [GV.toLabel l] edgeFmt :: (TypeScheme, TypeScheme, Constraint) -> GV.Attributes - edgeFmt (_,_,c) = + edgeFmt (_, _, c) = case c of - EqualityConstraint{} -> + EqualityConstraint {} -> [Attributes.edgeEnds Attributes.NoDir] - - ExplicitInstanceConstraint{} -> + ExplicitInstanceConstraint {} -> [Attributes.color Attributes.Yellow] - - ImplicitInstanceConstraint{} -> + ImplicitInstanceConstraint {} -> [Attributes.color Attributes.Red] diff --git a/bowtie/Main.hs b/bowtie/Main.hs index 1481cbb..ca81152 100644 --- a/bowtie/Main.hs +++ b/bowtie/Main.hs @@ -1,10 +1,9 @@ module Main where -import Bowtie.Lib.Prelude -import Options.Applicative - import qualified Bowtie.Interpret as Interpret +import Bowtie.Lib.Prelude import qualified Data.Text.IO as TIO +import Options.Applicative main :: IO () main = do @@ -14,7 +13,6 @@ main = do case Interpret.interpretProgram libFiles (name, appSource) of Left e -> exitWithError (Interpret.prettyError e) - Right untypedValue -> TIO.putStrLn (show untypedValue) @@ -31,7 +29,8 @@ configParser = parser :: Parser Config parser = Config - <$> argument str - ( metavar "FILE" - <> help "Path to source file" - ) + <$> argument + str + ( metavar "FILE" + <> help "Path to source file" + ) diff --git a/bowtie/doctest/DocTest.hs b/bowtie/doctest/DocTest.hs index 57258c3..90aa7d3 100644 --- a/bowtie/doctest/DocTest.hs +++ b/bowtie/doctest/DocTest.hs @@ -1,30 +1,31 @@ module Main (main) where -import Prelude import System.FilePath.Glob (glob) import Test.DocTest (doctest) +import Prelude main :: IO () main = do sourceFiles <- glob "src/**/*.hs" doctest -- NOTE: Keep in sync with package.yaml. - $ "-XStrictData" - : "-XBlockArguments" - : "-XDeriveAnyClass" - : "-XDeriveDataTypeable" - : "-XDeriveFunctor" - : "-XDeriveGeneric" - : "-XDerivingStrategies" - : "-XExistentialQuantification" - : "-XFlexibleContexts" - : "-XFlexibleInstances" - : "-XFunctionalDependencies" - : "-XGeneralizedNewtypeDeriving" - : "-XInstanceSigs" - : "-XMultiParamTypeClasses" - : "-XNoImplicitPrelude" - : "-XOverloadedStrings" - : "-XRankNTypes" - : "-XScopedTypeVariables" - : sourceFiles + ( "-XStrictData" + : "-XBlockArguments" + : "-XDeriveAnyClass" + : "-XDeriveDataTypeable" + : "-XDeriveFunctor" + : "-XDeriveGeneric" + : "-XDerivingStrategies" + : "-XExistentialQuantification" + : "-XFlexibleContexts" + : "-XFlexibleInstances" + : "-XFunctionalDependencies" + : "-XGeneralizedNewtypeDeriving" + : "-XInstanceSigs" + : "-XMultiParamTypeClasses" + : "-XNoImplicitPrelude" + : "-XOverloadedStrings" + : "-XRankNTypes" + : "-XScopedTypeVariables" + : sourceFiles + ) diff --git a/bowtie/package.yaml b/bowtie/package.yaml index 34c4503..55c2675 100644 --- a/bowtie/package.yaml +++ b/bowtie/package.yaml @@ -1,6 +1,6 @@ name: bowtie default-extensions: - # NOTE: Keep in sync with ./doctest/DocTest.hs and ./.stylish-haskell.yaml + # NOTE: Keep in sync with ./doctest/DocTest.hs # Notable diff --git a/bowtie/src/Bowtie/Core/Expr.hs b/bowtie/src/Bowtie/Core/Expr.hs index 0130ba4..8ae2eef 100644 --- a/bowtie/src/Bowtie/Core/Expr.hs +++ b/bowtie/src/Bowtie/Core/Expr.hs @@ -3,20 +3,18 @@ module Bowtie.Core.Expr where import Bowtie.Lib.FreeVars import Bowtie.Lib.Prelude import Bowtie.Type.AST - import qualified Data.HashMap.Strict as HashMap import qualified Data.Set as Set data Expr = Var Id - | Lam Id Type Expr -- ^ @Type@ is the type of the argument, not the @Expr@ + | -- | @Type@ is the type of the argument, not the @Expr@ + Lam Id Type Expr | App Expr Expr - | Let (HashMap Id (Expr, Type)) Expr - - | Construct Id -- ^ E.g. @Just@ + | -- | E.g. @Just@ + Construct Id | Case Expr [Alt] - | PrimInt Integer | PrimOp Operation deriving (Eq, Show) @@ -37,10 +35,14 @@ data Alt data Operation = Compare Expr Expr - | Plus Expr Expr -- ^ Only works on PrimInts - | Multiply Expr Expr -- ^ Only works on PrimInts - | ShowInt Expr -- ^ Only works on PrimInt - | Panic Expr -- ^ Only works on Text + | -- | Only works on PrimInts + Plus Expr Expr + | -- | Only works on PrimInts + Multiply Expr Expr + | -- | Only works on PrimInt + ShowInt Expr + | -- | Only works on Text + Panic Expr deriving (Eq, Show) instance FreeVars Expr where @@ -49,40 +51,29 @@ instance FreeVars Expr where case topExpr of Var i -> Set.singleton i - Lam i _ e -> Set.delete i (freeVars e) - App e1 e2 -> freeVars e1 <> freeVars e2 - Let decls expr -> - foldMap freeVars (fmap fst (HashMap.elems decls)) - <> freeVars expr `Set.difference` Set.fromList (HashMap.keys decls) -- NOTE: careful, this part isn't tested - + foldMap freeVars (fmap fst (HashMap.elems decls)) + <> freeVars expr `Set.difference` Set.fromList (HashMap.keys decls) -- NOTE: careful, this part isn't tested Construct _ -> mempty - Case e alts -> freeVars e <> foldMap freeVars alts - PrimInt _ -> mempty - PrimOp op -> case op of Compare e1 e2 -> freeVars e1 <> freeVars e2 - Plus e1 e2 -> freeVars e1 <> freeVars e2 - Multiply e1 e2 -> freeVars e1 <> freeVars e2 - ShowInt e -> freeVars e - Panic e -> freeVars e diff --git a/bowtie/src/Bowtie/Infer/Assumptions.hs b/bowtie/src/Bowtie/Infer/Assumptions.hs index 5d5c78d..43d94cf 100644 --- a/bowtie/src/Bowtie/Infer/Assumptions.hs +++ b/bowtie/src/Bowtie/Infer/Assumptions.hs @@ -1,15 +1,15 @@ module Bowtie.Infer.Assumptions - ( Assumptions - , singleton - , lookup - , delete - , keys - , toList - ) where + ( Assumptions, + singleton, + lookup, + delete, + keys, + toList, + ) +where import Bowtie.Lib.Prelude hiding (toList) import Bowtie.Type.AST - import qualified Data.HashMap.Strict as HashMap import qualified Data.Set as Set diff --git a/bowtie/src/Bowtie/Infer/BottomUp.hs b/bowtie/src/Bowtie/Infer/BottomUp.hs index 4e0e788..6f3649e 100644 --- a/bowtie/src/Bowtie/Infer/BottomUp.hs +++ b/bowtie/src/Bowtie/Infer/BottomUp.hs @@ -1,77 +1,69 @@ module Bowtie.Infer.BottomUp where import Bowtie.Infer.Assumptions (Assumptions) +import qualified Bowtie.Infer.Assumptions as Assumptions import Bowtie.Infer.Constraints +import qualified Bowtie.Infer.Constraints as Constraints +import qualified Bowtie.Lib.Builtin as Builtin import Bowtie.Lib.Environment import Bowtie.Lib.OrderedMap (OrderedMap) +import qualified Bowtie.Lib.OrderedMap as OrderedMap import Bowtie.Lib.Prelude import Bowtie.Lib.TypeScheme import Bowtie.Surface.AST import Control.Monad.State.Class - -import qualified Bowtie.Infer.Assumptions as Assumptions -import qualified Bowtie.Infer.Constraints as Constraints -import qualified Bowtie.Lib.Builtin as Builtin -import qualified Bowtie.Lib.OrderedMap as OrderedMap import qualified Data.Set as Set -bottomUp - :: forall m. MonadState Int m - => Environment - -> Set Id - -> Expr - -> m (Assumptions, Constraints, Type) +bottomUp :: + forall m. + MonadState Int m => + Environment -> + Set Id -> + Expr -> + m (Assumptions, Constraints, Type) bottomUp env ms topExpr = case topExpr of Var id -> do var <- fmap TVariable genVar pure (Assumptions.singleton id var, mempty, var) - Lam id _mType expr -> do (a1, c1, t1) <- bottomUp env (Set.insert id ms) expr newTypeVar <- fmap TVariable genVar - let - newC :: Constraints - newC = - case Assumptions.lookup id a1 of - Nothing -> - mempty - - Just ts -> - Constraints (Set.map (\t -> EqualityConstraint newTypeVar t) ts) + let newC :: Constraints + newC = + case Assumptions.lookup id a1 of + Nothing -> + mempty + Just ts -> + Constraints (Set.map (\t -> EqualityConstraint newTypeVar t) ts) pure (Assumptions.delete id a1, c1 <> newC, TArrow newTypeVar t1) - App e1 e2 -> do (a1, c1, t1) <- bottomUp env ms e1 (a2, c2, t2) <- bottomUp env ms e2 var <- fmap TVariable genVar pure (a1 <> a2, c1 <> c2 <> Constraints.singleton (EqualityConstraint t1 (TArrow t2 var)), var) - Let bindings expr -> bottomUpLet env ms bindings expr - Construct id -> do var <- fmap TVariable genVar pure (Assumptions.singleton id var, mempty, var) - Case expr alts -> bottomUpCase env ms expr alts - IntLiteral _ -> pure (mempty, mempty, TConstructor Builtin.int) - TextLiteral _ -> pure (mempty, mempty, TConstructor Builtin.text) -bottomUpLet - :: forall m. MonadState Int m - => Environment - -> Set Id - -> OrderedMap Id (Expr, Type) - -> Expr - -> m (Assumptions, Constraints, Type) +bottomUpLet :: + forall m. + MonadState Int m => + Environment -> + Set Id -> + OrderedMap Id (Expr, Type) -> + Expr -> + m (Assumptions, Constraints, Type) bottomUpLet env ms bindings expr = do (aBody, cBody, tBody) <- bottomUp env monomorphized expr (aNew, cNew) <- foldM f (aBody, cBody) bindingList @@ -82,93 +74,81 @@ bottomUpLet env ms bindings expr = do monomorphized :: Set Id monomorphized = Set.difference ms (Set.fromList (OrderedMap.keys bindings)) - bindingList :: [(Id, (Expr, Type))] bindingList = OrderedMap.toList bindings - -- TODO: cluster by cycle - -- - -- List.reverse (Desugar.clusterLetBindings bindings) + -- TODO: cluster by cycle + -- + -- List.reverse (Desugar.clusterLetBindings bindings) f :: (Assumptions, Constraints) -> (Id, (Expr, Type)) -> m (Assumptions, Constraints) f (a2, c2) (_id, (e, typeAnnotation)) = do (a1, c1, t1) <- bottomUp env monomorphized e - let - annotation :: Constraints - annotation = - -- constrain the inferred type to be an instance of the explicit type annotation - Constraints.singleton (ImplicitInstanceConstraint t1 monomorphized typeAnnotation) + let annotation :: Constraints + annotation = + -- constrain the inferred type to be an instance of the explicit type annotation + Constraints.singleton (ImplicitInstanceConstraint t1 monomorphized typeAnnotation) pure (a1 <> a2, c1 <> c2 <> annotation) - deleteAssumptions :: Assumptions -> Assumptions deleteAssumptions as = foldr Assumptions.delete as (OrderedMap.keys bindings) - newC :: Assumptions -> Constraints newC aa = - let - g :: (Id, (Expr, Type)) -> Constraints -> Constraints - g (id, (_, typeAnnotation)) cc = - case Assumptions.lookup id aa of - Nothing -> - cc - - Just ts -> - -- using typeAnnotation because it's less general than the inferred type - cc <> Constraints (Set.map (\t -> ImplicitInstanceConstraint t monomorphized typeAnnotation) ts) - in - foldr g mempty (OrderedMap.toList bindings) - -bottomUpCase - :: forall m. MonadState Int m - => Environment - -> Set Id - -> Expr - -> [Alt] - -> m (Assumptions, Constraints, Type) + let g :: (Id, (Expr, Type)) -> Constraints -> Constraints + g (id, (_, typeAnnotation)) cc = + case Assumptions.lookup id aa of + Nothing -> + cc + Just ts -> + -- using typeAnnotation because it's less general than the inferred type + cc <> Constraints (Set.map (\t -> ImplicitInstanceConstraint t monomorphized typeAnnotation) ts) + in foldr g mempty (OrderedMap.toList bindings) + +bottomUpCase :: + forall m. + MonadState Int m => + Environment -> + Set Id -> + Expr -> + [Alt] -> + m (Assumptions, Constraints, Type) bottomUpCase env ms targetExpr alts = do (targetA, targetC, targetT) <- bottomUp env ms targetExpr processedAlts :: [(TypeScheme, [(Id, Type)], Expr)] <- for alts addConInfo - let - inferAlt :: (TypeScheme, [(Id, Type)], Expr) -> m (TypeScheme, Assumptions, Constraints, Type) - inferAlt (scheme, bindings, expr) = do - let bindingIds = fmap fst bindings - (aa, cc, t) <- bottomUp env (ms <> Set.fromList bindingIds) expr - let - addC :: (Id, Type) -> Constraints -> Constraints - addC (bindingId, bindingType) oldC = - case Assumptions.lookup bindingId aa of - Nothing -> - oldC - - Just ts -> - -- NOTE: should EqualityConstraint be an instance constraint? - oldC <> Constraints (Set.map (\tc -> EqualityConstraint tc bindingType) ts) - - newC :: Constraints - newC = - foldr addC mempty bindings - pure (scheme, foldr Assumptions.delete aa bindingIds, cc <> newC, t) + let inferAlt :: (TypeScheme, [(Id, Type)], Expr) -> m (TypeScheme, Assumptions, Constraints, Type) + inferAlt (scheme, bindings, expr) = do + let bindingIds = fmap fst bindings + (aa, cc, t) <- bottomUp env (ms <> Set.fromList bindingIds) expr + let addC :: (Id, Type) -> Constraints -> Constraints + addC (bindingId, bindingType) oldC = + case Assumptions.lookup bindingId aa of + Nothing -> + oldC + Just ts -> + -- NOTE: should EqualityConstraint be an instance constraint? + oldC <> Constraints (Set.map (\tc -> EqualityConstraint tc bindingType) ts) + newC :: Constraints + newC = + foldr addC mempty bindings + pure (scheme, foldr Assumptions.delete aa bindingIds, cc <> newC, t) res <- for processedAlts inferAlt - let - go - :: Type - -> (Assumptions, Constraints) - -> (TypeScheme, Assumptions, Constraints, Type) - -> m (Assumptions, Constraints) - go t (a, c) (_, aa, cc, tt) = - pure (a <> aa, c <> cc <> Constraints.singleton (EqualityConstraint tt t)) + let go :: + Type -> + (Assumptions, Constraints) -> + (TypeScheme, Assumptions, Constraints, Type) -> + m (Assumptions, Constraints) + go t (a, c) (_, aa, cc, tt) = + pure (a <> aa, c <> cc <> Constraints.singleton (EqualityConstraint tt t)) case res of (ts, aaa, ccc, t) : xs -> do (aZ, cZ) <- foldM (go t) (aaa, ccc) xs pure - ( targetA <> aZ - , targetC <> Constraints.singleton (ExplicitInstanceConstraint targetT ts) <> cZ - , t + ( targetA <> aZ, + targetC <> Constraints.singleton (ExplicitInstanceConstraint targetT ts) <> cZ, + t ) - [] -> panic "Case statement has no alternatives (this should have been caught by the parser)" where @@ -186,18 +166,15 @@ bottomUpCase env ms targetExpr alts = do case lookup conId env of Nothing -> panic ("Constructor id not found: " <> unId conId) - Just (TypeScheme polyVars typ) -> do - let - g :: (Type, [(Id, Type)]) -> Id -> m (Type, [(Id, Type)]) - g (t, xs) binding = - case t of - TArrow targ t2 -> - pure (t2, (binding, targ) : xs) - - _ -> - -- TODO: find another way to report this than panic: - panic ("Alternative tries to bind too many variables: " <> unId conId) + let g :: (Type, [(Id, Type)]) -> Id -> m (Type, [(Id, Type)]) + g (t, xs) binding = + case t of + TArrow targ t2 -> + pure (t2, (binding, targ) : xs) + _ -> + -- TODO: find another way to report this than panic: + panic ("Alternative tries to bind too many variables: " <> unId conId) (finalType, args) <- foldM g (typ, mempty) bindings pure (TypeScheme polyVars finalType, args, expr) diff --git a/bowtie/src/Bowtie/Infer/Constraints.hs b/bowtie/src/Bowtie/Infer/Constraints.hs index 0bf882c..1166fc8 100644 --- a/bowtie/src/Bowtie/Infer/Constraints.hs +++ b/bowtie/src/Bowtie/Infer/Constraints.hs @@ -4,7 +4,6 @@ import Bowtie.Infer.Substitution import Bowtie.Lib.Prelude import Bowtie.Lib.TypeScheme import Bowtie.Type.AST - import qualified Data.List as List import qualified Data.Set as Set @@ -16,8 +15,8 @@ newtype Constraints data Constraint = EqualityConstraint Type Type | ExplicitInstanceConstraint Type TypeScheme - | ImplicitInstanceConstraint Type (Set Id) Type - -- ^ @Set Id@ are monomorphic types variables. + | -- | @Set Id@ are monomorphic types variables. + ImplicitInstanceConstraint Type (Set Id) Type deriving (Eq, Ord, Show) toTypeSchemes :: Constraints -> Set TypeScheme @@ -29,10 +28,8 @@ toTypeSchemes (Constraints cs) = case c of EqualityConstraint t1 t2 -> [TypeScheme mempty t1, TypeScheme mempty t2] - ExplicitInstanceConstraint t ts -> [TypeScheme mempty t, ts] - ImplicitInstanceConstraint t1 _ t2 -> [TypeScheme mempty t1, TypeScheme mempty t2] @@ -52,15 +49,13 @@ subst :: Substitution -> Constraints -> Constraints subst sub (Constraints conMap) = Constraints (Set.map substConstraint conMap) where - substConstraint :: Constraint -> Constraint - substConstraint c = - case c of - EqualityConstraint t1 t2 -> - EqualityConstraint (substType sub t1) (substType sub t2) - - ExplicitInstanceConstraint t ts -> - ExplicitInstanceConstraint (substType sub t) (substTypeScheme sub ts) - - ImplicitInstanceConstraint t1 monomorphicIds t2 -> - -- TODO: is this right? - ImplicitInstanceConstraint (substType sub t1) monomorphicIds (substType sub t2) + substConstraint :: Constraint -> Constraint + substConstraint c = + case c of + EqualityConstraint t1 t2 -> + EqualityConstraint (substType sub t1) (substType sub t2) + ExplicitInstanceConstraint t ts -> + ExplicitInstanceConstraint (substType sub t) (substTypeScheme sub ts) + ImplicitInstanceConstraint t1 monomorphicIds t2 -> + -- TODO: is this right? + ImplicitInstanceConstraint (substType sub t1) monomorphicIds (substType sub t2) diff --git a/bowtie/src/Bowtie/Infer/Elaborate.hs b/bowtie/src/Bowtie/Infer/Elaborate.hs index c74b477..addb517 100644 --- a/bowtie/src/Bowtie/Infer/Elaborate.hs +++ b/bowtie/src/Bowtie/Infer/Elaborate.hs @@ -12,41 +12,31 @@ freshenExpr expr = case expr of Var _ -> pure expr - Lam id mType body -> case mType of Just _ -> -- If there's already an explicit type on the argument, do nothing. pure expr - Nothing -> do -- If there's no explicit type on the argument, place a new type -- variable there to be inferred later. newTypeVar <- fmap TVariable genVar body' <- freshenExpr body pure (Lam id (Just newTypeVar) body') - App e1 e2 -> fmap App (freshenExpr e1) <*> freshenExpr e2 - Let bindings body -> - let - f :: (Expr, typ) -> m (Expr, typ) - f (e, t) = do - e' <- freshenExpr e - pure (e', t) - in - fmap Let (for bindings f) <*> freshenExpr body - + let f :: (Expr, typ) -> m (Expr, typ) + f (e, t) = do + e' <- freshenExpr e + pure (e', t) + in fmap Let (for bindings f) <*> freshenExpr body Construct _ -> pure expr - Case caseExpr alts -> fmap Case (freshenExpr caseExpr) <*> for alts freshenAlt - IntLiteral _ -> pure expr - TextLiteral _ -> pure expr diff --git a/bowtie/src/Bowtie/Infer/Generalize.hs b/bowtie/src/Bowtie/Infer/Generalize.hs index 1a5ee17..bbe9032 100644 --- a/bowtie/src/Bowtie/Infer/Generalize.hs +++ b/bowtie/src/Bowtie/Infer/Generalize.hs @@ -6,24 +6,22 @@ import Bowtie.Lib.Prelude import Bowtie.Lib.TypeScheme import Bowtie.Type.AST import Control.Monad.State.Class - import qualified Data.HashMap.Strict as HashMap import qualified Data.Set as Set generalize :: Set Id -> Type -> TypeScheme generalize env typ = - let - polyVars :: Set Id - polyVars = - freeVars typ `Set.difference` env - in - TypeScheme polyVars typ + let polyVars :: Set Id + polyVars = + freeVars typ `Set.difference` env + in TypeScheme polyVars typ instantiate :: forall m. MonadState Int m => TypeScheme -> m Type instantiate (TypeScheme polyVars typ) = do - sub <- fmap - (Substitution . HashMap.fromList) - (traverse pairStaleWithFresh (Set.toList polyVars)) + sub <- + fmap + (Substitution . HashMap.fromList) + (traverse pairStaleWithFresh (Set.toList polyVars)) pure (substType sub typ) where pairStaleWithFresh :: Id -> m (Id, Type) diff --git a/bowtie/src/Bowtie/Infer/Solve.hs b/bowtie/src/Bowtie/Infer/Solve.hs index 54d5d82..d88abc1 100644 --- a/bowtie/src/Bowtie/Infer/Solve.hs +++ b/bowtie/src/Bowtie/Infer/Solve.hs @@ -1,14 +1,13 @@ module Bowtie.Infer.Solve where import Bowtie.Infer.Constraints +import qualified Bowtie.Infer.Constraints as Constraints import Bowtie.Infer.Generalize (generalize, instantiate) import Bowtie.Infer.Substitution import Bowtie.Infer.Unify import Bowtie.Lib.CanFailWith import Bowtie.Lib.Prelude import Control.Monad.State.Class - -import qualified Bowtie.Infer.Constraints as Constraints import qualified Data.List as List import qualified Data.Set as Set @@ -16,45 +15,38 @@ data SolveStuck = SolveStuckError deriving (Eq, Show) -solve - :: (MonadState Int m, CanFailWith SolveStuck m, CanFailWith UnifyError m) - => Constraints - -> m Substitution +solve :: + (MonadState Int m, CanFailWith SolveStuck m, CanFailWith UnifyError m) => + Constraints -> + m Substitution solve cs = do case next cs of Nothing -> if Constraints.isEmpty cs - then - pure mempty - - else - failWith SolveStuckError - + then pure mempty + else failWith SolveStuckError Just (c, rest) -> do (sub, rest2) <- solveConstraint c rest fmap (\a -> a <> sub) (solve rest2) -solveConstraint - :: (MonadState Int m, CanFailWith UnifyError m) - => Constraint - -> Constraints - -> m (Substitution, Constraints) +solveConstraint :: + (MonadState Int m, CanFailWith UnifyError m) => + Constraint -> + Constraints -> + m (Substitution, Constraints) solveConstraint c rest = do case c of EqualityConstraint t1 t2 -> do sub <- case unify t1 t2 of - Left unifyError -> - failWith unifyError - - Right s -> - pure s + Left unifyError -> + failWith unifyError + Right s -> + pure s pure (sub, Constraints.subst sub rest) - ExplicitInstanceConstraint t ts -> do res <- instantiate ts pure (mempty, Constraints.add (EqualityConstraint t res) rest) - ImplicitInstanceConstraint t ms t2 -> do let res = generalize ms t2 pure (mempty, Constraints.add (ExplicitInstanceConstraint t res) rest) @@ -65,9 +57,9 @@ solveConstraint c rest = do next :: Constraints -> Maybe (Constraint, Constraints) next cs = asum - [ nextEquality cs - , nextExplicit cs - , nextValidImplicit cs + [ nextEquality cs, + nextExplicit cs, + nextValidImplicit cs ] nextEquality :: Constraints -> Maybe (Constraint, Constraints) @@ -78,9 +70,8 @@ nextEquality (Constraints cs) = do f :: Constraint -> Bool f c = case c of - EqualityConstraint{} -> + EqualityConstraint {} -> True - _ -> False @@ -92,9 +83,8 @@ nextExplicit (Constraints cs) = do f :: Constraint -> Bool f c = case c of - ExplicitInstanceConstraint{} -> + ExplicitInstanceConstraint {} -> True - _ -> False @@ -107,8 +97,7 @@ nextValidImplicit (Constraints cs) = do f c = -- TODO: freevars activevars check case c of - ImplicitInstanceConstraint{} -> + ImplicitInstanceConstraint {} -> True - _ -> False diff --git a/bowtie/src/Bowtie/Infer/Substitution.hs b/bowtie/src/Bowtie/Infer/Substitution.hs index 45fa158..25fc887 100644 --- a/bowtie/src/Bowtie/Infer/Substitution.hs +++ b/bowtie/src/Bowtie/Infer/Substitution.hs @@ -4,7 +4,6 @@ import Bowtie.Lib.Environment import Bowtie.Lib.Prelude import Bowtie.Lib.TypeScheme import Bowtie.Surface.AST - import qualified Data.HashMap.Strict as HashMap -- tapl 318 @@ -35,28 +34,21 @@ substExpr sub expr = case expr of Var _ -> expr - Lam id mType body -> Lam id (fmap (substType sub) mType) (substExpr sub body) - App e1 e2 -> App (substExpr sub e1) (substExpr sub e2) - Let bindings body -> - Let (fmap (\(a,b) -> (substExpr sub a, substType sub b)) bindings) (substExpr sub body) - + Let (fmap (\(a, b) -> (substExpr sub a, substType sub b)) bindings) (substExpr sub body) Construct _ -> expr - Case caseExpr alts -> Case (substExpr sub caseExpr) (fmap (substAlt sub) alts) - IntLiteral _ -> expr - TextLiteral _ -> expr @@ -75,28 +67,21 @@ substType sub@(Substitution subst) typ = case HashMap.lookup id subst of Nothing -> typ - Just new -> new - TConstructor id -> case HashMap.lookup id subst of Nothing -> typ - Just _ -> panic "subst tcon" - TArrow t1 t2 -> TArrow (substType sub t1) (substType sub t2) - TypeApp t1 t2 -> TypeApp (substType sub t1) (substType sub t2) substTypeScheme :: Substitution -> TypeScheme -> TypeScheme substTypeScheme (Substitution subHm) (TypeScheme polyVars t) = - let - -- Algorithm W Step by Step by Martin G. - sub2 = Substitution (foldr HashMap.delete subHm polyVars) - in - TypeScheme polyVars (substType sub2 t) + let -- Algorithm W Step by Step by Martin G. + sub2 = Substitution (foldr HashMap.delete subHm polyVars) + in TypeScheme polyVars (substType sub2 t) diff --git a/bowtie/src/Bowtie/Infer/Unify.hs b/bowtie/src/Bowtie/Infer/Unify.hs index cba50cf..6d6d117 100644 --- a/bowtie/src/Bowtie/Infer/Unify.hs +++ b/bowtie/src/Bowtie/Infer/Unify.hs @@ -4,7 +4,6 @@ import Bowtie.Infer.Substitution import Bowtie.Lib.FreeVars import Bowtie.Lib.Prelude import Bowtie.Surface.AST - import qualified Data.Set as Set data UnifyError @@ -15,7 +14,6 @@ data UnifyError -- | Implementation based on . unify :: Type -> Type -> Either UnifyError Substitution unify t1 t2 = - -- For example consider: -- -- (\x -> x) 5 @@ -45,35 +43,25 @@ unify t1 t2 = -- followed by Int for 0. if t1 == t2 - then - Right mempty - - else - case (t1, t2) of - (TVariable id, _) -> - unifyVariable id t2 - - (_, 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) - - (TypeApp a1 b1, TypeApp a2 b2) -> do - s1 <- unify a1 a2 - s2 <- unify (substType s1 b1) (substType s1 b2) - Right (s1 <> s2) - - _ -> - Left (TypeMismatch t1 t2) + then Right mempty + else case (t1, t2) of + (TVariable id, _) -> + unifyVariable id t2 + (_, 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) + (TypeApp a1 b1, TypeApp a2 b2) -> do + s1 <- unify a1 a2 + s2 <- unify (substType s1 b1) (substType s1 b2) + Right (s1 <> s2) + _ -> + Left (TypeMismatch t1 t2) where unifyVariable :: Id -> Type -> Either UnifyError Substitution unifyVariable id typ = if Set.member id (freeVars typ) - then - Left (IdOccursInType id typ) - - else - Right (singleSub id typ) + then Left (IdOccursInType id typ) + else Right (singleSub id typ) diff --git a/bowtie/src/Bowtie/Interpret.hs b/bowtie/src/Bowtie/Interpret.hs index 22b5a45..7acac60 100644 --- a/bowtie/src/Bowtie/Interpret.hs +++ b/bowtie/src/Bowtie/Interpret.hs @@ -1,24 +1,24 @@ module Bowtie.Interpret - ( BowtieError(..) - , interpret - , interpretProgram - , sourcesToAST - , sourcesToCore - , prettyError - , toBowtieError - ) where + ( BowtieError (..), + interpret, + interpretProgram, + sourcesToAST, + sourcesToCore, + prettyError, + toBowtieError, + ) +where +import qualified Bowtie.Core.Expr as Core import Bowtie.Lib.Environment import Bowtie.Lib.Prelude -import Bowtie.Surface.AST (AST(astTerms, astTypes), IdConfict(..), concatASTs) -import Bowtie.Type.Kindcheck -import Bowtie.Type.Parse (ParserErrorBundle) - -import qualified Bowtie.Core.Expr as Core +import Bowtie.Surface.AST (AST (astTerms, astTypes), IdConfict (..), concatASTs) import qualified Bowtie.Surface.AST as Surface import qualified Bowtie.Surface.Desugar as Desugar import qualified Bowtie.Surface.Infer as Infer import qualified Bowtie.Surface.Parse as Parse +import Bowtie.Type.Kindcheck +import Bowtie.Type.Parse (ParserErrorBundle) import qualified Bowtie.Untyped.Erase as Erase import qualified Bowtie.Untyped.Eval as Eval import qualified Bowtie.Untyped.Expr as Untyped @@ -38,10 +38,10 @@ interpret src = interpretProgram mempty ("", src) -- | For use by the executable. -interpretProgram - :: HashMap FilePath Text - -> (FilePath, Text) - -> Either BowtieError Untyped.Expr +interpretProgram :: + HashMap FilePath Text -> + (FilePath, Text) -> + Either BowtieError Untyped.Expr interpretProgram libFiles appFile = do (_, res) <- Bifunctor.first toBowtieError (interpretImpl libFiles appFile) (_, _, val) <- Bifunctor.first TypeError res @@ -50,69 +50,60 @@ interpretProgram libFiles appFile = do -- | Internal. -- -- NOTE: Environment is just the data types. -interpretImpl - :: HashMap FilePath Text - -> (FilePath, Text) - -> Either - (Either ParserErrorBundle IdConfict) - ( AST - , Either - Infer.TypeError - (Environment, Core.Expr, Untyped.Expr) - ) +interpretImpl :: + HashMap FilePath Text -> + (FilePath, Text) -> + Either + (Either ParserErrorBundle IdConfict) + ( AST, + Either + Infer.TypeError + (Environment, Core.Expr, Untyped.Expr) + ) interpretImpl libFiles appFile = do - -- Parse - let - parse :: (FilePath, Text) -> Either (Either ParserErrorBundle IdConfict) AST - parse = - Bifunctor.first Left . uncurry Parse.parse + let parse :: (FilePath, Text) -> Either (Either ParserErrorBundle IdConfict) AST + parse = + Bifunctor.first Left . uncurry Parse.parse libPrograms <- for (hashmapToSortedList libFiles) parse appProgram <- parse appFile ast <- Bifunctor.first Right (concatASTs (libPrograms <> [appProgram])) -- PERFORMANCE - pure (ast, inferAndEval ast) where inferAndEval :: AST -> Either Infer.TypeError (Environment, Core.Expr, Untyped.Expr) inferAndEval ast = do - -- Kindcheck and infer - let - env :: Environment - env = - kindcheck (astTypes ast) - - dsg :: Surface.Expr - dsg = - Desugar.extractResult (astTerms ast) + let env :: Environment + env = + kindcheck (astTypes ast) + dsg :: Surface.Expr + dsg = + Desugar.extractResult (astTerms ast) (_, _, explicitlyTypedExpr) <- Infer.elaborate env dsg -- Desugar and erase - let - core :: Core.Expr - core = - Desugar.desugar explicitlyTypedExpr - - untyped :: Untyped.Expr - untyped = - Erase.erase core + let core :: Core.Expr + core = + Desugar.desugar explicitlyTypedExpr + untyped :: Untyped.Expr + untyped = + Erase.erase core -- Eval case Eval.eval mempty untyped of Left e -> panic ("Evaluating failed (this should never happen): " <> show e) - Right val -> pure (env, core, val) -- | For use by tests or other packages. -sourcesToAST - :: HashMap FilePath Text - -> (FilePath, Text) - -> Either (Either ParserErrorBundle IdConfict) AST +sourcesToAST :: + HashMap FilePath Text -> + (FilePath, Text) -> + Either (Either ParserErrorBundle IdConfict) AST sourcesToAST libFiles appFile = do (ast, _) <- interpretImpl libFiles appFile pure ast @@ -120,10 +111,10 @@ sourcesToAST libFiles appFile = do -- | For use by tests or other packages. -- -- NOTE: Environment is just the data types. -sourcesToCore - :: HashMap FilePath Text - -> (FilePath, Text) - -> Either BowtieError (Environment, Core.Expr) +sourcesToCore :: + HashMap FilePath Text -> + (FilePath, Text) -> + Either BowtieError (Environment, Core.Expr) sourcesToCore libFiles appFile = do (_, res) <- Bifunctor.first toBowtieError (interpretImpl libFiles appFile) (env, core, _) <- Bifunctor.first TypeError res @@ -134,13 +125,10 @@ prettyError err = case err of ParseError e -> "Parse error: " <> Text.pack (Mega.errorBundlePretty e) - NameClash (TypeIdConflict id) -> "Duplicate type definitions found in multiple modules with name " <> unId id - NameClash (TermIdConflict id) -> "Duplicate term definitions found in multiple modules with name " <> unId id - TypeError e -> "Type error: " <> show e @@ -149,6 +137,5 @@ toBowtieError err = case err of Left e -> ParseError e - Right e -> NameClash e diff --git a/bowtie/src/Bowtie/Lib/Environment.hs b/bowtie/src/Bowtie/Lib/Environment.hs index 29ebd10..4a3ed55 100644 --- a/bowtie/src/Bowtie/Lib/Environment.hs +++ b/bowtie/src/Bowtie/Lib/Environment.hs @@ -5,14 +5,12 @@ module Bowtie.Lib.Environment where import Bowtie.Lib.FreeVars import Bowtie.Lib.Prelude import Bowtie.Lib.TypeScheme - import qualified Data.HashMap.Strict as HashMap import qualified Data.Set as Set -- | (A type environment, not a term environment like appear elsewhere -- in the code) -newtype Environment - = Environment { unEnvironment :: HashMap Id TypeScheme } +newtype Environment = Environment {unEnvironment :: HashMap Id TypeScheme} deriving stock (Eq, Show) deriving newtype (Semigroup, Monoid) diff --git a/bowtie/src/Bowtie/Lib/OrderedMap.hs b/bowtie/src/Bowtie/Lib/OrderedMap.hs index 27f941b..feb5d34 100644 --- a/bowtie/src/Bowtie/Lib/OrderedMap.hs +++ b/bowtie/src/Bowtie/Lib/OrderedMap.hs @@ -2,34 +2,35 @@ -- http://hackage.haskell.org/package/ordered-containers -- a BSD-3 library by Daniel Wagner. module Bowtie.Lib.OrderedMap - ( OrderedMap - , empty - , singleton - , insert - , append - , lookup - , delete - , fromList - , toList - , keys - , elems - ) where + ( OrderedMap, + empty, + singleton, + insert, + append, + lookup, + delete, + fromList, + toList, + keys, + elems, + ) +where import Bowtie.Lib.Prelude hiding (empty, toList) import Data.Data (Data) -import Data.Map (Map) -import Prelude (succ) - import qualified Data.HashMap.Strict as HashMap +import Data.Map (Map) import qualified Data.Map as Map +import Prelude (succ) -- | Note that entries show up twice when printed by 'Show', -- but there's no way around this if we want to obey the show/read law. +-- +-- Using @Map@ in the second argument for @.maxViewWithKey@. data OrderedMap k v = OrderedMap !(HashMap k (Natural, v)) !(Map Natural (k, v)) - -- ^ Using Map for maxViewWithKey deriving stock (Eq, Show, Functor, Data) -- | NOTE: Not used right now? @@ -41,7 +42,7 @@ instance Foldable (OrderedMap k) where instance (Eq k, Hashable k) => Traversable (OrderedMap k) where traverse :: Applicative f => (a -> f b) -> OrderedMap k a -> f (OrderedMap k b) traverse f (OrderedMap _ ivs) = - fromKV <$> traverse (\(k,v) -> (,) k <$> f v) ivs + fromKV <$> traverse (\(k, v) -> (,) k <$> f v) ivs -- | Internal for @Traversable@. fromKV :: forall k v. (Eq k, Hashable k) => Map Natural (k, v) -> OrderedMap k v @@ -50,31 +51,30 @@ fromKV ivs = where kvs :: HashMap k (Natural, v) kvs = - HashMap.fromList [(k,(t,v)) | (t,(k,v)) <- Map.toList ivs] + HashMap.fromList [(k, (t, v)) | (t, (k, v)) <- Map.toList ivs] empty :: (Eq k, Hashable k) => OrderedMap k v empty = OrderedMap mempty mempty -singleton - :: (Eq k, Hashable k) - => k - -> v - -> OrderedMap k v +singleton :: + (Eq k, Hashable k) => + k -> + v -> + OrderedMap k v singleton k v = OrderedMap (HashMap.singleton k (0, v)) (Map.singleton 0 (k, v)) -insert - :: (Eq k, Hashable k) - => k - -> v - -> OrderedMap k v - -> Maybe (OrderedMap k v) +insert :: + (Eq k, Hashable k) => + k -> + v -> + OrderedMap k v -> + Maybe (OrderedMap k v) insert k v o@(OrderedMap kvs nvs) = case lookup k o of Just _ -> Nothing - Nothing -> Just $ OrderedMap @@ -98,7 +98,6 @@ delete k o@(OrderedMap kvs ivs) = case HashMap.lookup k kvs of Nothing -> o - Just (n, _) -> OrderedMap (HashMap.delete k kvs) (Map.delete n ivs) diff --git a/bowtie/src/Bowtie/Lib/Prelude.hs b/bowtie/src/Bowtie/Lib/Prelude.hs index 02e734b..519ed0b 100644 --- a/bowtie/src/Bowtie/Lib/Prelude.hs +++ b/bowtie/src/Bowtie/Lib/Prelude.hs @@ -1,12 +1,16 @@ {-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} + -- Normally we use hlint to enforce importing Data.Text as Text, -- but here we want to import it as X: {-# HLINT ignore "Avoid restricted qualification" #-} module Bowtie.Lib.Prelude - ( module Bowtie.Lib.Prelude - , module X - ) where + ( module Bowtie.Lib.Prelude, + module X, + ) +where + +{- ORMOLU_DISABLE -} -- Re-exports: @@ -48,13 +52,15 @@ import qualified Data.Text as Text import qualified Data.Text.IO as TIO import qualified Prelude +{- ORMOLU_ENABLE -} + newtype Id = Id Text deriving stock (Eq, Ord, Show, Generic) deriving newtype (Hashable) deriving anyclass (NFData) --- | Note making this a field of @id@ since then it would +-- | Not making this a field of @id@ since then it would -- be printed every time an @Id@ is shown. unId :: Id -> Text unId (Id t) = @@ -92,13 +98,13 @@ hashmapToSortedList = readDirectoryFiles :: FilePath -> IO (HashMap FilePath Text) readDirectoryFiles dir = do - paths <- (fmap.fmap) (\p -> dir p) (listDirectory dir) + paths <- (fmap . fmap) (\p -> dir p) (listDirectory dir) fmap HashMap.fromList (for paths f) - where - f :: FilePath -> IO (FilePath, Text) - f path = do - t <- TIO.readFile path - pure (path, t) + where + f :: FilePath -> IO (FilePath, Text) + f path = do + t <- TIO.readFile path + pure (path, t) charToCodepoint :: Char -> Natural charToCodepoint = diff --git a/bowtie/src/Bowtie/Lib/TypeScheme.hs b/bowtie/src/Bowtie/Lib/TypeScheme.hs index 7778f2d..365dec2 100644 --- a/bowtie/src/Bowtie/Lib/TypeScheme.hs +++ b/bowtie/src/Bowtie/Lib/TypeScheme.hs @@ -3,12 +3,12 @@ module Bowtie.Lib.TypeScheme where import Bowtie.Lib.FreeVars import Bowtie.Lib.Prelude import Bowtie.Surface.AST - import qualified Data.Set as Set +-- | Quantitied over the variables in @Set Id@. data TypeScheme = TypeScheme - (Set Id) -- ^ Quantitied over these variables + (Set Id) Type deriving (Eq, Ord, Show) diff --git a/bowtie/src/Bowtie/Surface/AST.hs b/bowtie/src/Bowtie/Surface/AST.hs index 15c5a30..da40f37 100644 --- a/bowtie/src/Bowtie/Surface/AST.hs +++ b/bowtie/src/Bowtie/Surface/AST.hs @@ -1,21 +1,22 @@ module Bowtie.Surface.AST - ( module Bowtie.Surface.AST - , module Bowtie.Type.AST - ) where + ( module Bowtie.Surface.AST, + module Bowtie.Type.AST, + ) +where import Bowtie.Lib.FreeVars import Bowtie.Lib.OrderedMap (OrderedMap) +import qualified Bowtie.Lib.OrderedMap as OrderedMap import Bowtie.Lib.Prelude import Bowtie.Type.AST - -import qualified Bowtie.Lib.OrderedMap as OrderedMap import qualified Data.Bifunctor as Bifunctor import qualified Data.Set as Set data AST = AST - { astTypes :: OrderedMap Id TypeDeclaration - , astTerms :: OrderedMap Id (Expr, Type) - } deriving stock (Eq, Show) + { astTypes :: OrderedMap Id TypeDeclaration, + astTerms :: OrderedMap Id (Expr, Type) + } + deriving stock (Eq, Show) emptyAST :: AST emptyAST = @@ -40,22 +41,20 @@ data Expr = Var Id | Lam Id (Maybe Type) Expr | App Expr Expr - | Let (OrderedMap Id (Expr, Type)) Expr - | Construct Id | Case Expr [Alt] - | IntLiteral Integer | TextLiteral Text deriving (Eq, Show) --- | For example, consider @Just n -> n + 1@ +-- | For example, consider @Just n -> n + 1@. +-- +-- The first argument is the @Just@. +-- The second argument is the first @n@. +-- The third argument is the @n + 1@. data Alt - = Alt - Id -- ^ This would be the @Just@ - [Id] -- ^ This would be the first @n@ - Expr -- ^ This would be the @n + 1@ + = Alt Id [Id] Expr deriving (Eq, Show) instance FreeVars Expr where @@ -64,26 +63,19 @@ instance FreeVars Expr where case topExpr of Var i -> Set.singleton i - Lam i _ e -> Set.delete i (freeVars e) - App e1 e2 -> freeVars e1 <> freeVars e2 - Let decls expr -> (freeVars expr <> foldMap freeVars (fmap fst (OrderedMap.elems decls))) `Set.difference` Set.fromList (OrderedMap.keys decls) -- NOTE: careful, this part isn't tested - Construct _ -> mempty - Case e alts -> freeVars e <> foldMap freeVars alts - IntLiteral _ -> mempty - TextLiteral _ -> mempty diff --git a/bowtie/src/Bowtie/Surface/Desugar.hs b/bowtie/src/Bowtie/Surface/Desugar.hs index debf28d..86bb7e2 100644 --- a/bowtie/src/Bowtie/Surface/Desugar.hs +++ b/bowtie/src/Bowtie/Surface/Desugar.hs @@ -1,17 +1,17 @@ module Bowtie.Surface.Desugar - ( desugar - , extractResult - , clusterLetBindings - ) where + ( desugar, + extractResult, + clusterLetBindings, + ) +where +import qualified Bowtie.Core.Expr as Core +import qualified Bowtie.Lib.Builtin as Builtin import Bowtie.Lib.FreeVars import Bowtie.Lib.OrderedMap (OrderedMap) +import qualified Bowtie.Lib.OrderedMap as OrderedMap import Bowtie.Lib.Prelude hiding (all, rem) import Bowtie.Surface.AST - -import qualified Bowtie.Core.Expr as Core -import qualified Bowtie.Lib.Builtin as Builtin -import qualified Bowtie.Lib.OrderedMap as OrderedMap import qualified Data.Graph as Graph import qualified Data.HashMap.Strict as HashMap import qualified Data.Set as Set @@ -22,7 +22,6 @@ extractResult decls = case OrderedMap.lookup (Id "result") decls of Nothing -> panic "result id not found" - Just (resultExpr, _typ) -> Let (OrderedMap.delete (Id "result") decls) resultExpr @@ -38,17 +37,14 @@ clusterLetBindings decls = g :: (Id, (Expr, Type)) -> ((Expr, Type), Id, [Id]) g (id, (expr, typ)) = ((expr, typ), id, Set.toList (freeVars expr)) - f :: Graph.SCC ((Expr, Type), Id, ids) -> [[(Id, (Expr, Type))]] -> [[(Id, (Expr, Type))]] f grph acc = case grph of Graph.AcyclicSCC (expr, id, _) -> [(id, expr)] : acc - -- A binding that refers to itself Graph.CyclicSCC [(expr, id, _)] -> [(id, expr)] : acc - -- Mutually recursive bindings Graph.CyclicSCC bindings -> fmap (\(expr, id, _) -> (id, expr)) bindings : acc @@ -58,35 +54,25 @@ desugar topExpr = case topExpr of Var i -> Core.Var i - Lam id mType e -> case mType of Nothing -> panic "desugar type is Nothing" - Just typ -> Core.Lam id typ (desugar e) - App e1 e2 -> Core.App (desugar e1) (desugar e2) - Let decls e -> desugarLet decls e - Construct tag -> Core.Construct tag - Case e matches -> - let - f :: Alt -> Core.Alt - f (Alt i i2 expr) = - Core.Alt i i2 (desugar expr) - in - Core.Case (desugar e) (fmap f matches) - + let f :: Alt -> Core.Alt + f (Alt i i2 expr) = + Core.Alt i i2 (desugar expr) + in Core.Case (desugar e) (fmap f matches) IntLiteral n -> Core.PrimInt n - TextLiteral t -> desugarText t @@ -105,17 +91,14 @@ desugarText = toList' :: Text -> Core.Expr toList' = Text.foldr consCodepoint (Core.Construct Builtin.nil) - consCodepoint :: Char -> Core.Expr -> Core.Expr consCodepoint c expr = - let - consCodePoint :: Core.Expr - consCodePoint = - Core.App - (Core.Construct Builtin.cons) - (Core.PrimInt (fromIntegral (charToCodepoint c))) - in - Core.App consCodePoint expr + let consCodePoint :: Core.Expr + consCodePoint = + Core.App + (Core.Construct Builtin.cons) + (Core.PrimInt (fromIntegral (charToCodepoint c))) + in Core.App consCodePoint expr -- | This one isn't used for inference, but just going to core. desugarLet :: OrderedMap Id (Expr, Type) -> Expr -> Core.Expr @@ -127,12 +110,10 @@ desugarLet decls body = where addLet :: [(Id, (Expr, Type))] -> Core.Expr -> Core.Expr addLet recursiveBindings acc = - let - f :: (Id, (Expr, Type)) -> (Id, (Core.Expr, Type)) - f (id, (expr, typ)) = - (id, (desugarBinding id expr, typ)) - in - Core.Let (HashMap.fromList (fmap f recursiveBindings)) acc + let f :: (Id, (Expr, Type)) -> (Id, (Core.Expr, Type)) + f (id, (expr, typ)) = + (id, (desugarBinding id expr, typ)) + in Core.Let (HashMap.fromList (fmap f recursiveBindings)) acc -- | Internal. Used by 'desugarLet'. desugarBinding :: Id -> Expr -> Core.Expr @@ -147,79 +128,77 @@ desugarBinding id expr = -- the function definitions. case id of Id "compare" -> - let - a = Id "a" - b = Id "b" - aType = TVariable (Id "a") - in - Core.Lam - a - aType - (Core.Lam - b + let a = Id "a" + b = Id "b" + aType = TVariable (Id "a") + in Core.Lam + a aType - (Core.PrimOp - (Core.Compare - (Core.Var a) - (Core.Var b)))) - + ( Core.Lam + b + aType + ( Core.PrimOp + ( Core.Compare + (Core.Var a) + (Core.Var b) + ) + ) + ) Id "plus" -> - let - a = Id "a" - b = Id "b" - iType = TConstructor Builtin.int - in - Core.Lam - a - iType - (Core.Lam - b + let a = Id "a" + b = Id "b" + iType = TConstructor Builtin.int + in Core.Lam + a iType - (Core.PrimOp - (Core.Plus - (Core.Var a) - (Core.Var b)))) - + ( Core.Lam + b + iType + ( Core.PrimOp + ( Core.Plus + (Core.Var a) + (Core.Var b) + ) + ) + ) Id "multiply" -> - let - a = Id "a" - b = Id "b" - iType = TConstructor Builtin.int - in - Core.Lam - a - iType - (Core.Lam - b + let a = Id "a" + b = Id "b" + iType = TConstructor Builtin.int + in Core.Lam + a iType - (Core.PrimOp - (Core.Multiply - (Core.Var a) - (Core.Var b)))) - + ( Core.Lam + b + iType + ( Core.PrimOp + ( Core.Multiply + (Core.Var a) + (Core.Var b) + ) + ) + ) Id "showInt" -> - let - a = Id "a" - arrTyp = TArrow (TConstructor Builtin.int) (TConstructor Builtin.text) - in - Core.Lam - a - arrTyp - (Core.PrimOp - (Core.ShowInt - (Core.Var a))) - + let a = Id "a" + arrTyp = TArrow (TConstructor Builtin.int) (TConstructor Builtin.text) + in Core.Lam + a + arrTyp + ( Core.PrimOp + ( Core.ShowInt + (Core.Var a) + ) + ) Id "panic" -> - let - a = Id "a" - textType = TConstructor Builtin.text - in - Core.Lam - a - textType - (Core.PrimOp - (Core.Panic - (Core.Var a))) - + let a = Id "a" + textType = TConstructor Builtin.text + in Core.Lam + a + textType + ( Core.PrimOp + ( Core.Panic + (Core.Var a) + ) + ) _ -> desugar expr diff --git a/bowtie/src/Bowtie/Surface/Infer.hs b/bowtie/src/Bowtie/Surface/Infer.hs index e14e648..822d7a4 100644 --- a/bowtie/src/Bowtie/Surface/Infer.hs +++ b/bowtie/src/Bowtie/Surface/Infer.hs @@ -2,22 +2,21 @@ module Bowtie.Surface.Infer where import Bowtie.Infer.Assumptions (Assumptions) +import qualified Bowtie.Infer.Assumptions as Assumptions import Bowtie.Infer.BottomUp import Bowtie.Infer.Constraints +import qualified Bowtie.Infer.Elaborate as Elaborate import Bowtie.Infer.Solve import Bowtie.Infer.Substitution import Bowtie.Infer.Unify import Bowtie.Lib.CanFailWith import Bowtie.Lib.Environment +import qualified Bowtie.Lib.Environment as Environment import Bowtie.Lib.Prelude import Bowtie.Surface.AST import Control.Monad.Except import Control.Monad.State.Class import Control.Monad.Trans.State - -import qualified Bowtie.Infer.Assumptions as Assumptions -import qualified Bowtie.Infer.Elaborate as Elaborate -import qualified Bowtie.Lib.Environment as Environment import qualified Data.Set as Set data TypeError @@ -29,50 +28,43 @@ data TypeError elaborate :: Environment -> Expr -> Either TypeError (Substitution, Type, Expr) elaborate env expr = do - let - freshExpr = evalState (Elaborate.freshenExpr expr) 10000000 -- TODO - + let freshExpr = evalState (Elaborate.freshenExpr expr) 10000000 -- TODO case runInfer (inferType env freshExpr) of Left e -> Left e - Right (sub, typ) -> pure (sub, typ, substExpr sub freshExpr) -inferType - :: ( MonadState Int m - , CanFailWith SolveStuck m - , CanFailWith UnifyError m - , CanFailWith Assumptions m - ) - => Environment - -> Expr - -> m (Substitution, Type) +inferType :: + ( MonadState Int m, + CanFailWith SolveStuck m, + CanFailWith UnifyError m, + CanFailWith Assumptions m + ) => + Environment -> + Expr -> + m (Substitution, Type) inferType env expr = do (constraints, typ) <- gatherConstraints env expr s <- solve constraints -- Heeren paper doesn't do the substType here: pure (s, substType s typ) -gatherConstraints - :: (MonadState Int m, CanFailWith Assumptions m) - => Environment - -> Expr - -> m (Constraints, Type) +gatherConstraints :: + (MonadState Int m, CanFailWith Assumptions m) => + Environment -> + Expr -> + m (Constraints, Type) gatherConstraints env expr = do (a, c, t) <- bottomUp env mempty expr -- if dom A not a subset of domain env then undefined variables exist - let - remaining :: Set Id - remaining = - Set.difference (Assumptions.keys a) (Environment.keys env) + let remaining :: Set Id + remaining = + Set.difference (Assumptions.keys a) (Environment.keys env) if Set.null remaining - then - pure () - - else - failWith a + then pure () + else failWith a pure (c <> explicitConstraintOnSet env a, t) @@ -100,12 +92,13 @@ instance CanFailWith SolveStuck Infer where instance CanFailWith UnifyError Infer where failWith :: UnifyError -> Infer a failWith e = - throwError (case e of - TypeMismatch t1 t2 -> - UnifyError t1 t2 - - IdOccursInType id t -> - OccursCheckFailed id t) + throwError + ( case e of + TypeMismatch t1 t2 -> + UnifyError t1 t2 + IdOccursInType id t -> + OccursCheckFailed id t + ) instance CanFailWith Assumptions Infer where failWith :: Assumptions -> Infer a diff --git a/bowtie/src/Bowtie/Surface/Parse.hs b/bowtie/src/Bowtie/Surface/Parse.hs index db9cbf3..d491b58 100644 --- a/bowtie/src/Bowtie/Surface/Parse.hs +++ b/bowtie/src/Bowtie/Surface/Parse.hs @@ -2,30 +2,36 @@ {-# OPTIONS_GHC -fno-warn-unused-imports #-} module Bowtie.Surface.Parse - ( parse - , exprParser - - -- | For test and REPL use - , dirtyParseExpr - , dirtyParseAST - ) where + ( parse, + exprParser, + -- | For test and REPL use + dirtyParseExpr, + dirtyParseAST, + ) +where import Bowtie.Lib.OrderedMap (OrderedMap) +import qualified Bowtie.Lib.OrderedMap as OrderedMap import Bowtie.Lib.Prelude hiding (many, some) import Bowtie.Surface.AST import Bowtie.Type.Parse - (Parser, ParserErrorBundle, lexeme, lowerIdParser, parseTest, - spacesOrNewlines, symbol, upperIdParser) -import Control.Applicative.Combinators.NonEmpty -import Text.Megaparsec hiding (parse, parseTest, some) - -import qualified Bowtie.Lib.OrderedMap as OrderedMap + ( Parser, + ParserErrorBundle, + lexeme, + lowerIdParser, + parseTest, + spacesOrNewlines, + symbol, + upperIdParser, + ) import qualified Bowtie.Type.Parse as Type +import Control.Applicative.Combinators.NonEmpty import qualified Data.Char as Char import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text as Text -import qualified Prelude +import Text.Megaparsec hiding (parse, parseTest, some) import qualified Text.Megaparsec.Char.Lexer as Lexer +import qualified Prelude parse :: FilePath -> Text -> Either ParserErrorBundle AST parse path = @@ -38,7 +44,6 @@ parse path = -- ^^ TODO: OrderedMaps do not do well with Show sourceParser :: Parser AST sourceParser = do - -- This was my other attempt at this, -- but the "try" made for terrible errors -- @@ -63,18 +68,17 @@ sourceParser = do case appendAST s1 s2 of Left (TypeIdConflict id) -> fail ("Duplicate type definitions found in module with name " <> Text.unpack (unId id)) - Left (TermIdConflict id) -> fail ("Duplicate type definitions found in module with name " <> Text.unpack (unId id)) - Right a -> pure a declarationParser :: Parser AST declarationParser = - label "declarationParser" - ( fmap (\(i,d) -> AST (OrderedMap.singleton i d) OrderedMap.empty) Type.typeDeclarationParser - <|> fmap (\(i,e,typ) -> AST OrderedMap.empty (OrderedMap.singleton i (e, typ))) bindingParser + label + "declarationParser" + ( fmap (\(i, d) -> AST (OrderedMap.singleton i d) OrderedMap.empty) Type.typeDeclarationParser + <|> fmap (\(i, e, typ) -> AST OrderedMap.empty (OrderedMap.singleton i (e, typ))) bindingParser ) -- | @@ -107,11 +111,12 @@ bindingBodyParser = do exprParser :: Parser Expr exprParser = - label "exprParser" - ( lamParser - <|> letParser - <|> caseParser - <|> listToAppParser + label + "exprParser" + ( lamParser + <|> letParser + <|> caseParser + <|> listToAppParser ) -- | @@ -150,19 +155,15 @@ letParser = do p = do symbol "let" pure (Lexer.IndentSome Nothing g bindingParser) - g :: [(Id, Expr, Type)] -> Parser (OrderedMap Id (Expr, Type)) g decls = - let - f :: (Id, Expr, Type) -> (Id, (Expr, Type)) - f (i,e,typ) = (i, (e, typ)) - in - case OrderedMap.fromList (fmap f decls) of - Left id -> - fail ("Duplicate identifiers found in let expression with id: " <> Text.unpack (unId id)) - - Right a -> - pure a + let f :: (Id, Expr, Type) -> (Id, (Expr, Type)) + f (i, e, typ) = (i, (e, typ)) + in case OrderedMap.fromList (fmap f decls) of + Left id -> + fail ("Duplicate identifiers found in let expression with id: " <> Text.unpack (unId id)) + Right a -> + pure a -- | -- >>> parseTest caseParser "case a of\n True -> 1\n\n False -> 2" @@ -210,12 +211,13 @@ listToAppParser = do itemParser :: Parser Expr itemParser = - label "itemParser" - ( Type.parens exprParser - <|> varParser - <|> conParser - <|> intParser - <|> textParser + label + "itemParser" + ( Type.parens exprParser + <|> varParser + <|> conParser + <|> intParser + <|> textParser ) varParser :: Parser Expr @@ -243,7 +245,6 @@ intParser = do case mNegate of Nothing -> digits - Just _ -> '-' : digits @@ -265,7 +266,6 @@ dirtyParseExpr src = case Type.runParser exprParser "" src of Left e -> panic (Text.pack (errorBundlePretty e)) - Right expr -> expr @@ -275,6 +275,5 @@ dirtyParseAST src = case parse "" src of Left e -> panic (Text.pack (errorBundlePretty e)) - Right program -> program diff --git a/bowtie/src/Bowtie/Type/AST.hs b/bowtie/src/Bowtie/Type/AST.hs index bea97cf..ffad92b 100644 --- a/bowtie/src/Bowtie/Type/AST.hs +++ b/bowtie/src/Bowtie/Type/AST.hs @@ -3,13 +3,14 @@ module Bowtie.Type.AST where import Bowtie.Lib.FreeVars import Bowtie.Lib.OrderedMap (OrderedMap) import Bowtie.Lib.Prelude - import qualified Data.Set as Set -- | With no items in the map this is Void, with one it's a wrapper/newtype. +-- +-- Polymorphic in the variables in @[Id]@. data TypeDeclaration = TypeDeclaration - [Id]-- ^ Polymorphic over these variables + [Id] (OrderedMap Id [Type]) deriving (Eq, Show) @@ -17,7 +18,6 @@ data Type = TVariable Id | TConstructor Id | TArrow Type Type - | TypeApp Type Type deriving (Eq, Ord, Show) @@ -27,7 +27,6 @@ instance FreeVars Type where case typ of TVariable id -> Set.singleton id - TConstructor _id -> -- TODO: -- @@ -44,9 +43,7 @@ instance FreeVars Type where -- this assumes we haven't already loaded constructors into the -- Environment. mempty - TArrow t1 t2 -> freeVars t1 <> freeVars t2 - TypeApp t1 t2 -> freeVars t1 <> freeVars t2 diff --git a/bowtie/src/Bowtie/Type/Kindcheck.hs b/bowtie/src/Bowtie/Type/Kindcheck.hs index 1afb956..8732847 100644 --- a/bowtie/src/Bowtie/Type/Kindcheck.hs +++ b/bowtie/src/Bowtie/Type/Kindcheck.hs @@ -2,11 +2,10 @@ module Bowtie.Type.Kindcheck where import Bowtie.Lib.Environment import Bowtie.Lib.OrderedMap (OrderedMap) +import qualified Bowtie.Lib.OrderedMap as OrderedMap import Bowtie.Lib.Prelude import Bowtie.Lib.TypeScheme import Bowtie.Type.AST - -import qualified Bowtie.Lib.OrderedMap as OrderedMap import qualified Data.HashMap.Strict as HashMap import qualified Data.Set as Set @@ -23,19 +22,16 @@ kindcheck = where constructorType :: (Id, [Type]) -> (Id, TypeScheme) constructorType (conId, args) = - let - finalType :: Type - finalType = - foldr f (TConstructor typeId) polyVars - where - f :: Id -> Type -> Type - f id acc = - TypeApp acc (TVariable id) - - typ :: Type - typ = - foldr TArrow finalType args - in - ( conId - , TypeScheme (Set.fromList polyVars) typ - ) + let finalType :: Type + finalType = + foldr f (TConstructor typeId) polyVars + where + f :: Id -> Type -> Type + f id acc = + TypeApp acc (TVariable id) + typ :: Type + typ = + foldr TArrow finalType args + in ( conId, + TypeScheme (Set.fromList polyVars) typ + ) diff --git a/bowtie/src/Bowtie/Type/Parse.hs b/bowtie/src/Bowtie/Type/Parse.hs index bdb526e..eebea47 100644 --- a/bowtie/src/Bowtie/Type/Parse.hs +++ b/bowtie/src/Bowtie/Type/Parse.hs @@ -1,35 +1,40 @@ module Bowtie.Type.Parse - ( Parser - , ParserErrorBundle - , typeDeclarationParser - , typeSignatureParser - , typeParser - , lowerIdParser - , upperIdParser - - -- | Helpers - , lexeme - , symbol - , spacesOrNewlines - , parens - , runParser - , parseTest - ) where - -import Bowtie.Lib.Prelude hiding (many, some) -import Bowtie.Type.AST -import Control.Applicative.Combinators.NonEmpty + ( Parser, + ParserErrorBundle, + typeDeclarationParser, + typeSignatureParser, + typeParser, + lowerIdParser, + upperIdParser, + -- | Helpers + lexeme, + symbol, + spacesOrNewlines, + parens, + runParser, + parseTest, + ) +where -- Hide @sepBy1@ because we're using the one from -- @Control.Applicative.Combinators.NonEmpty@ -- that returns a @NonEmpty@ list instead. -import Text.Megaparsec hiding - (State, Token, parse, parseTest, runParser, sepBy1) import qualified Bowtie.Lib.OrderedMap as OrderedMap +import Bowtie.Lib.Prelude hiding (many, some) +import Bowtie.Type.AST +import Control.Applicative.Combinators.NonEmpty import qualified Data.Char as Char import qualified Data.List.NonEmpty as NE import qualified Data.Text as Text +import Text.Megaparsec hiding + ( State, + Token, + parse, + parseTest, + runParser, + sepBy1, + ) import qualified Text.Megaparsec as Mega import qualified Text.Megaparsec.Char.Lexer as Lexer @@ -70,7 +75,6 @@ typeDeclarationParser = do case OrderedMap.fromList constructors of Left id -> fail ("Duplicate constructors found in type declaration with id: " <> Text.unpack (unId id)) - Right constructorMap -> pure (typeId, TypeDeclaration typeArgs constructorMap) @@ -97,9 +101,10 @@ constructorParser = do -- TVariable (Id "a") constructorArgParser :: Parser Type constructorArgParser = - label "constructorArgParser" - ( parens typeParser - <|> singleTypeParser' + label + "constructorArgParser" + ( parens typeParser + <|> singleTypeParser' ) -- | @@ -139,9 +144,10 @@ typeParser = do -- TypeApp (TConstructor (Id "Maybe")) (TVariable (Id "a")) typeStarParser :: Parser Type typeStarParser = - label "typeStarParser" - ( parens typeParser - <|> singleTypeParser + label + "typeStarParser" + ( parens typeParser + <|> singleTypeParser ) -- | @@ -160,8 +166,8 @@ singleTypeParser = do singleTypeParser' :: Parser Type singleTypeParser' = -- TODO: a good label - fmap TVariable (lexeme lowerIdParser) - <|> fmap TConstructor (lexeme upperIdParser) + fmap TVariable (lexeme lowerIdParser) + <|> fmap TConstructor (lexeme upperIdParser) -- | -- >>> parseTest lowerIdParser "a" @@ -184,11 +190,11 @@ lowerIdParser = do keywordList :: [Text] keywordList = - [ "type" - , "let" - , "in" - , "case" - , "of" + [ "type", + "let", + "in", + "case", + "of" ] -- | @@ -227,8 +233,10 @@ spaces = space1 :: Parser () space1 = void - (takeWhile1P (Just "space character (U+0020") - (== ' ')) + ( takeWhile1P + (Just "space character (U+0020") + (== ' ') + ) symbol :: Text -> Parser () symbol = @@ -245,20 +253,22 @@ spacesOrNewlines = spaceOrNewline1 :: Parser () spaceOrNewline1 = void - (takeWhile1P - (Just "space or newline (U+0020 or U+000A)") - (\c -> c == ' ' || c == '\n')) + ( takeWhile1P + (Just "space or newline (U+0020 or U+000A)") + (\c -> c == ' ' || c == '\n') + ) parens :: Parser a -> Parser a parens = between (symbol "(") (symbol ")") -- | Requires the parser to consume all input (unlike 'Mega.runParser'). -runParser - :: forall a. Parser a - -> FilePath - -> Text - -> Either (ParseErrorBundle Text Void) a +runParser :: + forall a. + Parser a -> + FilePath -> + Text -> + Either (ParseErrorBundle Text Void) a runParser parser path = Mega.runParser f path where @@ -270,11 +280,11 @@ runParser parser path = -- | For doctests. -- Requires the parser to consume all input (unlike 'Mega.parseTest'). -parseTest - :: (ShowErrorComponent e, Show a, Stream s) - => Parsec e s a - -> s - -> IO () +parseTest :: + (ShowErrorComponent e, Show a, Stream s) => + Parsec e s a -> + s -> + IO () parseTest p = Mega.parseTest do res <- p diff --git a/bowtie/src/Bowtie/Untyped/Erase.hs b/bowtie/src/Bowtie/Untyped/Erase.hs index 2fa4c05..366b3ea 100644 --- a/bowtie/src/Bowtie/Untyped/Erase.hs +++ b/bowtie/src/Bowtie/Untyped/Erase.hs @@ -1,9 +1,8 @@ module Bowtie.Untyped.Erase where +import qualified Bowtie.Core.Expr as Core import Bowtie.Lib.Prelude import Bowtie.Untyped.Expr - -import qualified Bowtie.Core.Expr as Core import qualified Data.HashMap.Strict as HashMap erase :: Core.Expr -> Expr @@ -11,30 +10,21 @@ erase topExpr = case topExpr of Core.Var i -> Var i - Core.Lam id _ e -> Lam Nothing id (erase e) - Core.App e1 e2 -> App (erase e1) (erase e2) - Core.Let decls e -> Let (fmap (erase . fst) decls) (erase e) - Core.Construct tag -> Construct tag mempty - Core.Case e matches -> - let - f :: Core.Alt -> HashMap Id Match - f (Core.Alt i i2 expr) = - HashMap.singleton i (Match i2 (erase expr)) - in - Case (erase e) (foldMap f matches) - + let f :: Core.Alt -> HashMap Id Match + f (Core.Alt i i2 expr) = + HashMap.singleton i (Match i2 (erase expr)) + in Case (erase e) (foldMap f matches) Core.PrimInt n -> PrimInt n - Core.PrimOp op -> PrimOp (eraseOperation op) @@ -43,15 +33,11 @@ eraseOperation op = case op of Core.Compare e1 e2 -> Compare (erase e1) (erase e2) - Core.Plus e1 e2 -> Plus (erase e1) (erase e2) - Core.Multiply e1 e2 -> Multiply (erase e1) (erase e2) - Core.ShowInt e -> ShowInt (erase e) - Core.Panic e -> Panic (erase e) diff --git a/bowtie/src/Bowtie/Untyped/Eval.hs b/bowtie/src/Bowtie/Untyped/Eval.hs index 9041553..3eeb8af 100644 --- a/bowtie/src/Bowtie/Untyped/Eval.hs +++ b/bowtie/src/Bowtie/Untyped/Eval.hs @@ -1,15 +1,14 @@ module Bowtie.Untyped.Eval where +import qualified Bowtie.Lib.Builtin as Builtin import Bowtie.Lib.FreeVars import Bowtie.Lib.Prelude import Bowtie.Untyped.Expr import Data.Function (fix) -import Safe.Exact (zipExactMay) - -import qualified Bowtie.Lib.Builtin as Builtin import qualified Data.HashMap.Strict as HashMap import qualified Data.Set as Set import qualified Data.Text as Text +import Safe.Exact (zipExactMay) data Error = AppNonLambda @@ -26,25 +25,18 @@ eval topEnv topExpr = case topExpr of Var id -> lookup id topEnv - Lam mEnv id expr -> evalLam topEnv mEnv id expr - App e1 e2 -> evalApp topEnv e1 e2 - Let decls e -> do evalLet topEnv decls e - Construct tag exps -> pure (Construct tag exps) - Case expr alternatives -> do evalCase topEnv expr alternatives - PrimInt n -> pure (PrimInt n) - PrimOp op -> evalOp topEnv op @@ -55,24 +47,22 @@ evalLam topEnv mEnv id expr = -- lexical scope, do nothing. Just _ -> pure (Lam mEnv id expr) - -- If this is the first time we've reaches the lambda, -- set it's environment to the lexical scope (minus variables -- which aren't free in the lambda, which would just be extraneous -- and clutter up debugging). Nothing -> do - let - free :: HashMap Id () - free = - HashMap.fromList (fmap (\a -> (a, ())) (Set.toList (freeVars expr))) - - newEnv :: TermEnv - newEnv = - TermEnv - (HashMap.intersectionWith - const - (unTermEnv topEnv) - free) + let free :: HashMap Id () + free = + HashMap.fromList (fmap (\a -> (a, ())) (Set.toList (freeVars expr))) + newEnv :: TermEnv + newEnv = + TermEnv + ( HashMap.intersectionWith + const + (unTermEnv topEnv) + free + ) pure (Lam (Just newEnv) id expr) @@ -85,13 +75,10 @@ evalApp topEnv e1 e2 = do case mEnv of Nothing -> panic "unexpected unscoped lambda" - Just env -> eval (addToEnv id arg env) lamExp - Construct tag exps -> do pure (Construct tag (exps <> [arg])) -- PERFORMANCE - _ -> Left AppNonLambda @@ -99,23 +86,18 @@ evalApp topEnv e1 e2 = do evalLet :: TermEnv -> HashMap Id Expr -> Expr -> Either Error Expr evalLet topEnv bindings body = do evaledBindings <- traverse (eval topEnv) bindings - let - addRecursiveReferences :: (Expr -> Expr) -> Expr -> Expr - addRecursiveReferences f expr = - case expr of - Lam (Just env) id e -> - let - fEnv :: TermEnv - fEnv = - TermEnv (fmap f evaledBindings <> unTermEnv env) - in - Lam (Just fEnv) id e - - _ -> expr - - selfReferencingBindings :: HashMap Id Expr - selfReferencingBindings = - fmap (fix addRecursiveReferences) evaledBindings + let addRecursiveReferences :: (Expr -> Expr) -> Expr -> Expr + addRecursiveReferences f expr = + case expr of + Lam (Just env) id e -> + let fEnv :: TermEnv + fEnv = + TermEnv (fmap f evaledBindings <> unTermEnv env) + in Lam (Just fEnv) id e + _ -> expr + selfReferencingBindings :: HashMap Id Expr + selfReferencingBindings = + fmap (fix addRecursiveReferences) evaledBindings eval (TermEnv (selfReferencingBindings <> unTermEnv topEnv)) body @@ -128,18 +110,15 @@ evalCase topEnv expr alternatives = do case HashMap.lookup conId alternatives of Nothing -> Left (CaseNoMatch conId alternatives) - Just (Match boundVars newExp) -> do xs :: [(Id, Expr)] <- case zipExactMay boundVars args of Nothing -> Left (CaseWrongNumberVarsMatched conId boundVars) - Just a -> Right a eval (TermEnv (HashMap.fromList xs) <> topEnv) newExp - _ -> Left (CaseNotConstruct res) @@ -152,27 +131,21 @@ evalOp topEnv op = case compare n1 n2 of -- TODO: Just using compare here is a bad idea LT -> pure (Construct Builtin.lessThan mempty) - EQ -> pure (Construct Builtin.equal mempty) - GT -> pure (Construct Builtin.greaterThan mempty) - Plus e1 e2 -> do n1 <- evalInt topEnv e1 n2 <- evalInt topEnv e2 pure (PrimInt (n1 + n2)) - Multiply e1 e2 -> do n1 <- evalInt topEnv e1 n2 <- evalInt topEnv e2 pure (PrimInt (n1 * n2)) - ShowInt expr -> do n <- evalInt topEnv expr pure (showIntBuiltin n) - Panic expr -> do n <- eval topEnv expr Left (ErrorPanic (show n)) -- TODO: show is not right @@ -185,13 +158,12 @@ showIntBuiltin n = exprList :: Text -> Expr exprList = Text.foldr consCodepoint (Construct Builtin.nil mempty) - consCodepoint :: Char -> Expr -> Expr consCodepoint c expr = Construct Builtin.cons - [ PrimInt (fromIntegral (charToCodepoint c)) - , expr + [ PrimInt (fromIntegral (charToCodepoint c)), + expr ] evalInt :: TermEnv -> Expr -> Either Error Integer @@ -200,7 +172,6 @@ evalInt env expr = do case res of PrimInt n -> pure n - _ -> Left (ExpectedAnInt res) @@ -209,7 +180,6 @@ lookup id env = case HashMap.lookup id (unTermEnv env) of Just expr -> pure expr - Nothing -> Left (NotFound id) diff --git a/bowtie/src/Bowtie/Untyped/Expr.hs b/bowtie/src/Bowtie/Untyped/Expr.hs index c205061..0e3adeb 100644 --- a/bowtie/src/Bowtie/Untyped/Expr.hs +++ b/bowtie/src/Bowtie/Untyped/Expr.hs @@ -2,25 +2,21 @@ module Bowtie.Untyped.Expr where import Bowtie.Lib.FreeVars import Bowtie.Lib.Prelude - import qualified Data.HashMap.Strict as HashMap import qualified Data.Set as Set data Expr = Var Id - | Lam (Maybe TermEnv) Id Expr - -- ^ @Maybe TermEnv@ is the lambda's lexical scope. + | -- | @Maybe TermEnv@ is the lambda's lexical scope. -- -- Invariant: this always starts as @Nothing@ and becomes @Just@ -- the first time the evaluator reaches the reaches the lambda. -- This is the only time it changes throughout evaluation. + Lam (Maybe TermEnv) Id Expr | App Expr Expr - | Let (HashMap Id Expr) Expr - | Construct Id [Expr] | Case Expr (HashMap Id Match) - | PrimInt Integer | PrimOp Operation deriving (Eq, Show, Generic, NFData) @@ -31,47 +27,34 @@ instance FreeVars Expr where case topExpr of Var id -> Set.singleton id - Lam _env id expr -> Set.delete id (freeVars expr) - App e1 e2 -> freeVars e1 <> freeVars e2 - Let bindings expr -> - let - boundIds :: Set Id - boundIds = - Set.fromList (HashMap.keys bindings) - in - Set.difference - (foldMap freeVars bindings <> freeVars expr) - boundIds - + let boundIds :: Set Id + boundIds = + Set.fromList (HashMap.keys bindings) + in Set.difference + (foldMap freeVars bindings <> freeVars expr) + boundIds Construct id exprs -> Set.singleton id <> foldMap freeVars exprs -- TODO: remove Set.singleton? - Case expr bindingsMap -> freeVars expr <> foldMap freeVars bindingsMap - PrimInt _ -> mempty - -- easy to forget there can be free variables in an Op PrimOp op -> case op of Compare e1 e2 -> freeVars e1 <> freeVars e2 - Plus e1 e2 -> freeVars e1 <> freeVars e2 - Multiply e1 e2 -> freeVars e1 <> freeVars e2 - ShowInt e -> freeVars e - Panic e -> freeVars e @@ -92,8 +75,7 @@ data Operation | Panic Expr deriving (Eq, Show, Generic, NFData) -newtype TermEnv - = TermEnv { unTermEnv :: HashMap Id Expr } +newtype TermEnv = TermEnv {unTermEnv :: HashMap Id Expr} deriving stock (Eq, Show, Generic) deriving newtype (Semigroup, Monoid) deriving anyclass (NFData) diff --git a/bowtie/test/Bowtie/Surface/InferSpec.hs b/bowtie/test/Bowtie/Surface/InferSpec.hs index c5208bd..5e0c59d 100644 --- a/bowtie/test/Bowtie/Surface/InferSpec.hs +++ b/bowtie/test/Bowtie/Surface/InferSpec.hs @@ -10,11 +10,10 @@ import Bowtie.Surface.AST import Bowtie.Surface.Desugar import Bowtie.Surface.Infer import Bowtie.Type.Kindcheck +import qualified Data.HashMap.Strict as HashMap import Test.Hspec import Test.Shared -import qualified Data.HashMap.Strict as HashMap - unitEnv :: Environment unitEnv = Environment (HashMap.singleton (Id "Unit") (TypeScheme mempty (TConstructor (Id "Unit")))) @@ -41,23 +40,19 @@ spec = do `shouldBe` Right (TConstructor (Id "Unit")) it "\\x. x 0" do fmap snd (infer mempty [quotedExpr|\x. x 0|]) - `shouldBe` - Right (TArrow (TArrow (TConstructor (Id "Int")) (TVariable (Id "1"))) (TVariable (Id "1"))) + `shouldBe` Right (TArrow (TArrow (TConstructor (Id "Int")) (TVariable (Id "1"))) (TVariable (Id "1"))) it "(\\x. x) 0" do fmap snd (infer mempty [quotedExpr|(\x. x) 0|]) - `shouldBe` - Right (TConstructor (Id "Int")) + `shouldBe` Right (TConstructor (Id "Int")) it "(\\x. x) (\\x. x)" do fmap snd (infer mempty [quotedExpr|(\x. x) (\x. x)|]) - `shouldBe` - Right (TArrow (TVariable (Id "2")) (TVariable (Id "2"))) - + `shouldBe` Right (TArrow (TVariable (Id "2")) (TVariable (Id "2"))) -- ================================================== it "let x = 1 in x" do - let - expr = [quotedExpr| + let expr = + [quotedExpr| let x : Int x = @@ -65,15 +60,13 @@ let in x|] fmap snd (infer mempty expr) - `shouldBe` - Right - (TConstructor (Id "Int")) - + `shouldBe` Right + (TConstructor (Id "Int")) -- ================================================== it "let x = 1 y = x in y" do - let - expr = [quotedExpr| + let expr = + [quotedExpr| let x : Int x = @@ -85,14 +78,12 @@ let in y|] fmap snd (infer mempty expr) - `shouldBe` - Right (TConstructor (Id "Int")) - + `shouldBe` Right (TConstructor (Id "Int")) -- ================================================== it "let id = \\x. x in id 1" do - let - expr = [quotedExpr| + let expr = + [quotedExpr| let id : Int -> Int id = @@ -101,35 +92,30 @@ let in id 1|] fmap snd (infer mempty expr) - `shouldBe` - Right (TConstructor (Id "Int")) - + `shouldBe` Right (TConstructor (Id "Int")) -- ================================================== it "case Unit of Unit -> 0" do - let - expr = [quotedExpr| + let expr = + [quotedExpr| case Unit of Unit -> 0|] fmap snd (infer unitEnv expr) - `shouldBe` - Right (TConstructor (Id "Int")) - + `shouldBe` Right (TConstructor (Id "Int")) -------------------------------------------------- -- Switching from Expr to Program -------------------------------------------------- - -- ================================================== it "types a particular situation correctly" do - let - -- This is a close to minimal test for a particular bug-- - -- Reducing it more by even changing type variable names prevents - -- it from triggering. - -- - -- See NOTE_ZK9 - program = [quotedAST| + let -- This is a close to minimal test for a particular bug-- + -- Reducing it more by even changing type variable names prevents + -- it from triggering. + -- + -- See NOTE_ZK9 + program = + [quotedAST| type Maybe b = Just b | Nothing type List a = Cons a (List a) | Nil @@ -156,11 +142,7 @@ result = 0 |] inferProgram program - `shouldBe` - Right (TConstructor (Id "Int")) - - - + `shouldBe` Right (TConstructor (Id "Int")) -- it "doesn't allow overly polymorphic type signatures" do -- let @@ -169,7 +151,8 @@ result = -- result : Maybe a -- result = -- Just 0 --- |] --- inferProgram program --- `shouldBe` --- Right (Substitution (HashMap.fromList [(Id "a",TConstructor (Id "Int"))]),TConstructor (Id "Int")) + +-- | ] +-- inferProgram program +-- `shouldBe` +-- Right (Substitution (HashMap.fromList [(Id "a",TConstructor (Id "Int"))]),TConstructor (Id "Int")) diff --git a/bowtie/test/Test.hs b/bowtie/test/Test.hs index e82b682..6ba8941 100644 --- a/bowtie/test/Test.hs +++ b/bowtie/test/Test.hs @@ -1,17 +1,16 @@ module Main where -import Bowtie.Lib.Prelude -import System.Directory -import System.FilePath (takeExtension, ()) -import Test.Hspec - import qualified Bowtie.Example import qualified Bowtie.Interpret as Interpret +import Bowtie.Lib.Prelude import qualified Bowtie.Surface.InferSpec import qualified Bowtie.Surface.Parse as Surface.Parse import qualified Data.List as List import qualified Data.Text as Text import qualified Data.Text.IO as TIO +import System.Directory +import System.FilePath ((), takeExtension) +import Test.Hspec import qualified Text.Megaparsec as Mega main :: IO () @@ -47,7 +46,6 @@ main = do case Interpret.interpretProgram libFiles (path, appSource) of Left e -> expectationFailure (Text.unpack (Interpret.prettyError e)) - Right _ -> pure () @@ -63,7 +61,6 @@ runInvalidSyntax (name, src) = TIO.writeFile ("test" "invalid-syntax-examples" name) (Text.pack (Mega.errorBundlePretty e)) - Right _ -> expectationFailure "Unexpected Right" @@ -76,25 +73,21 @@ runIllTyped (name, src) = Interpret.ParseError _ -> expectationFailure ("Unexpected parse error: " <> Text.unpack (Interpret.prettyError err)) - Interpret.NameClash conflict -> expectationFailure ("Unexpected name clash error : " <> Text.unpack (show conflict)) - Interpret.TypeError e -> TIO.writeFile ("test" "ill-typed-examples" name) (show e) - Right _ -> expectationFailure "Unexpected Right" getAppExamples :: IO [FilePath] getAppExamples = do - appPaths <- (fmap.fmap) ("../example-app" ) (listDirectory "../example-app") - let - (langs, other) = - List.partition (\path -> takeExtension path == ".bowtie") appPaths + appPaths <- (fmap . fmap) ("../example-app" ) (listDirectory "../example-app") + let (langs, other) = + List.partition (\path -> takeExtension path == ".bowtie") appPaths when (other /= mempty) diff --git a/bowtie/test/Test/Quoted/AST.hs b/bowtie/test/Test/Quoted/AST.hs index 1560142..4fa3066 100644 --- a/bowtie/test/Test/Quoted/AST.hs +++ b/bowtie/test/Test/Quoted/AST.hs @@ -7,21 +7,20 @@ import Bowtie.Lib.Prelude import Bowtie.Surface.AST import Bowtie.Surface.Parse import Data.Data +import qualified Data.Text as Text import Language.Haskell.TH.Quote import Test.Quoted.Expr (liftDataWithText, trimLeadingNewline) -import qualified Data.Text as Text - deriving stock instance Data AST + deriving stock instance Data TypeDeclaration quotedAST :: QuasiQuoter quotedAST = QuasiQuoter { quoteExp = - liftDataWithText . dirtyParseAST . Text.pack . trimLeadingNewline - - , quotePat = \_ -> panic "quotedAST: quotePat not defined" - , quoteType = \_ -> panic "quotedAST: quoteType not defined" - , quoteDec = \_ -> panic "quotedAST: quoteDec not defined" + liftDataWithText . dirtyParseAST . Text.pack . trimLeadingNewline, + quotePat = \_ -> panic "quotedAST: quotePat not defined", + quoteType = \_ -> panic "quotedAST: quoteType not defined", + quoteDec = \_ -> panic "quotedAST: quoteDec not defined" } diff --git a/bowtie/test/Test/Quoted/Expr.hs b/bowtie/test/Test/Quoted/Expr.hs index 96d35d2..67a6dd6 100644 --- a/bowtie/test/Test/Quoted/Expr.hs +++ b/bowtie/test/Test/Quoted/Expr.hs @@ -1,42 +1,43 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} - {-# OPTIONS_GHC -fno-warn-orphans #-} module Test.Quoted.Expr - ( quotedExpr + ( quotedExpr, - -- * For Test.Quoted.Program (which also uses these orphan instances) - , liftDataWithText - , trimLeadingNewline - ) where + -- * For Test.Quoted.Program (which also uses these orphan instances) + liftDataWithText, + trimLeadingNewline, + ) +where import Bowtie.Lib.Prelude import Bowtie.Surface.AST import Bowtie.Surface.Parse +import qualified Bowtie.Type.AST as TYP import Data.Data import Data.Text (Text) +import qualified Data.Text as Text import Language.Haskell.TH import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax (lift) -import qualified Bowtie.Type.AST as TYP -import qualified Data.Text as Text - deriving stock instance Data Expr + deriving stock instance Data TYP.Type + deriving stock instance Data Alt + deriving stock instance Data Id quotedExpr :: QuasiQuoter quotedExpr = QuasiQuoter { quoteExp = - liftDataWithText . dirtyParseExpr . Text.pack . trimLeadingNewline - - , quotePat = \_ -> panic "quotedExpr: quotePat not defined" - , quoteType = \_ -> panic "quotedExpr: quoteType not defined" - , quoteDec = \_ -> panic "quotedExpr: quoteDec not defined" + liftDataWithText . dirtyParseExpr . Text.pack . trimLeadingNewline, + quotePat = \_ -> panic "quotedExpr: quotePat not defined", + quoteType = \_ -> panic "quotedExpr: quoteType not defined", + quoteDec = \_ -> panic "quotedExpr: quoteDec not defined" } -- This and liftText from: https://stackoverflow.com/a/38182444 @@ -52,7 +53,6 @@ liftDataWithText = f :: forall b. Typeable b => b -> Maybe (Q Exp) f = fmap liftText . (cast :: b -> Maybe Text) - liftText :: Text -> Q Exp liftText txt = AppE (VarE 'Text.pack) <$> lift (Text.unpack txt) @@ -60,5 +60,5 @@ liftDataWithText = trimLeadingNewline :: [Char] -> [Char] trimLeadingNewline cs = case cs of - '\n':rest -> rest + '\n' : rest -> rest _ -> cs diff --git a/bowtie/test/Test/Shared.hs b/bowtie/test/Test/Shared.hs index 0b22468..a56efc8 100644 --- a/bowtie/test/Test/Shared.hs +++ b/bowtie/test/Test/Shared.hs @@ -1,7 +1,8 @@ module Test.Shared - ( module Test.Quoted.AST - , module Test.Quoted.Expr - ) where + ( module Test.Quoted.AST, + module Test.Quoted.Expr, + ) +where import Test.Quoted.AST import Test.Quoted.Expr diff --git a/spec/src/Bowtie/Example.hs b/spec/src/Bowtie/Example.hs index 0df6da0..90983a3 100644 --- a/spec/src/Bowtie/Example.hs +++ b/spec/src/Bowtie/Example.hs @@ -1,11 +1,12 @@ {-# LANGUAGE TemplateHaskell #-} module Bowtie.Example - ( wellTyped - , illTyped - , validSyntax - , invalidSyntax - ) where + ( wellTyped, + illTyped, + validSyntax, + invalidSyntax, + ) +where import Data.ByteString (ByteString) import Data.FileEmbed @@ -40,13 +41,12 @@ invalidSyntax = process :: [(FilePath, ByteString)] -> [(FilePath, Text)] process = -- Not sure if sorting is necessary-- will file-embed always sort its results? - sortOn fst . (fmap.fmap) f + sortOn fst . (fmap . fmap) f where f :: ByteString -> Text f bts = case decodeUtf8' bts of Left e -> error ("Invalid example: " <> show e) - Right t -> t