diff --git a/build/Main.class b/build/Main.class index 89d5ba5d..34f42e00 100644 Binary files a/build/Main.class and b/build/Main.class differ diff --git a/build/Prelude.class b/build/Prelude.class index 470cc251..5f177acd 100644 Binary files a/build/Prelude.class and b/build/Prelude.class differ diff --git a/source.elr b/source.elr index 31d0013a..c5214270 100644 --- a/source.elr +++ b/source.elr @@ -1,3 +1,7 @@ import Prelude -let main = 1 A.!. 2 \ No newline at end of file +let add2 = \x -> x + 2 + +let x = add2 1 + +let main = println (toString x) \ No newline at end of file diff --git a/src/Elara/AST/Generic/Instances/DataPlated.hs b/src/Elara/AST/Generic/Instances/DataPlated.hs index fd67da40..ebece1db 100644 --- a/src/Elara/AST/Generic/Instances/DataPlated.hs +++ b/src/Elara/AST/Generic/Instances/DataPlated.hs @@ -59,7 +59,7 @@ instance TypeApplication e1 e2 -> TypeApplication <$> traverseOf traverseExpr f e1 <*> pure e2 If e1 e2 e3 -> If <$> traverseOf traverseExpr f e1 <*> traverseOf traverseExpr f e2 <*> traverseOf traverseExpr f e3 List l -> List <$> traverseOf (each . traverseExpr) f l - Match e m -> Match <$> traverseOf traverseExpr f e <*> traverseOf (each . _2 . traverseExpr) (f) m + Match e m -> Match <$> traverseOf traverseExpr f e <*> traverseOf (each . _2 . traverseExpr) f m LetIn v p e1 e2 -> (LetIn v p <$> traverseOf traverseExpr f e1) <*> traverseOf traverseExpr f e2 Let v p e -> (Let v p <$> traverseOf traverseExpr f e) Block b -> Block <$> traverseOf (each . traverseExpr) f b @@ -70,7 +70,7 @@ instance instance forall a (ast :: a). - ( (Data (Expr ast)) + ( Data (Expr ast) ) => Plated (Expr ast) where @@ -78,7 +78,7 @@ instance instance forall a (ast :: a). - ( (Data (Type ast)) + ( Data (Type ast) ) => Plated (Type ast) where @@ -88,10 +88,10 @@ instance forall a (ast :: a). ( Data (ASTLocate ast (Type' ast)) , Data (ASTLocate ast (Select "TypeVar" ast)) - , Data ((Select "TypeVar" ast)) + , Data (Select "TypeVar" ast) , Data (ASTLocate ast (Select "UserDefinedType" ast)) , Data (ASTLocate ast LowerAlphaName) - , Data ((Select "UserDefinedType" ast)) + , Data (Select "UserDefinedType" ast) , Typeable ast , Typeable a , (Data (Type' ast)) diff --git a/src/Elara/AST/Generic/Instances/Pretty.hs b/src/Elara/AST/Generic/Instances/Pretty.hs index b79af241..64f3cefd 100644 --- a/src/Elara/AST/Generic/Instances/Pretty.hs +++ b/src/Elara/AST/Generic/Instances/Pretty.hs @@ -82,7 +82,7 @@ instance , lambdaPatterns ~ UnwrapList (Select "LambdaPattern" ast) , Pretty (ASTLocate ast (Select "ConRef" ast)) , Pretty (ASTLocate ast (Select "VarRef" ast)) - , Pretty ((Select "TypeApplication" ast)) + , Pretty (Select "TypeApplication" ast) , (Pretty (ASTLocate ast (Select "LetParamName" ast))) , Pretty letPatterns , letPatterns ~ UnwrapList (Select "LetPattern" ast) @@ -115,7 +115,7 @@ prettyExpr :: , lambdaPatterns ~ UnwrapList (Select "LambdaPattern" ast) , Pretty (ASTLocate ast (Select "ConRef" ast)) , Pretty (ASTLocate ast (Select "VarRef" ast)) - , Pretty ((Select "TypeApplication" ast)) + , Pretty (Select "TypeApplication" ast) , (Pretty (ASTLocate ast (Select "LetParamName" ast))) , Pretty letPatterns , (ToList (Select "LetPattern" ast) [letPatterns]) @@ -146,7 +146,7 @@ instance forall ast letPatterns lambdaPatterns. ( Pretty (ASTLocate ast (Select "ConRef" ast)) , Pretty (ASTLocate ast (Select "VarRef" ast)) - , Pretty ((Select "TypeApplication" ast)) + , Pretty (Select "TypeApplication" ast) , (Pretty (ASTLocate ast (Select "LetParamName" ast))) , Pretty letPatterns , letPatterns ~ UnwrapList (Select "LetPattern" ast) @@ -180,7 +180,7 @@ prettyExpr' :: , ?withType :: Bool , Pretty (ASTLocate ast (Select "VarRef" ast)) , Pretty (ASTLocate ast (Select "ConRef" ast)) - , Pretty ((Select "TypeApplication" ast)) + , Pretty (Select "TypeApplication" ast) , (Pretty (ASTLocate ast (Select "LetParamName" ast))) , Pretty letPatterns , (ToList (Select "LetPattern" ast) [letPatterns]) @@ -212,7 +212,7 @@ prettyExpr' (TypeApplication e1 e2) = prettyFunctionCall e1 ("@" <> pretty e2) prettyExpr' (If e1 e2 e3) = prettyIfExpr (prettyExpr e1) (prettyExpr e2) (prettyExpr e3) prettyExpr' (List l) = prettyList (prettyExpr <$> l) prettyExpr' (Match e m) = prettyMatchExpr (prettyExpr e) (prettyMatchBranch . second prettyExpr <$> m) -prettyExpr' (LetIn v p e1 e2) = prettyLetInExpr v (fieldToList @(Select "LetPattern" ast) p :: [letPatterns]) (e1) (e2) +prettyExpr' (LetIn v p e1 e2) = prettyLetInExpr v (fieldToList @(Select "LetPattern" ast) p :: [letPatterns]) e1 e2 prettyExpr' (Let v p e) = prettyLetExpr v (fieldToList @(Select "LetPattern" ast) p :: [letPatterns]) e prettyExpr' (Block b) = prettyBlockExpr (prettyExpr <$> b) prettyExpr' (Tuple t) = prettyTupleExpr (prettyExpr <$> t) diff --git a/src/Elara/AST/Generic/Instances/Simple.hs b/src/Elara/AST/Generic/Instances/Simple.hs index 824f78f7..ede37855 100644 --- a/src/Elara/AST/Generic/Instances/Simple.hs +++ b/src/Elara/AST/Generic/Instances/Simple.hs @@ -26,7 +26,7 @@ deriving instance , (Eq (Select "ExprType" ast)) , (Eq (Select "PatternType" ast)) , (Eq (Select "BinaryOperator" ast)) - , Eq ((Select "TypeApplication" ast)) + , Eq (Select "TypeApplication" ast) , Eq (ASTLocate ast (Expr' ast)) , Eq (ASTLocate ast (Pattern' ast)) , Eq (Type ast) @@ -72,7 +72,7 @@ deriving instance , (Show (ASTLocate ast (Select "LambdaPattern" ast))) , (Show (ASTLocate ast (Select "ConRef" ast))) , (Show (ASTLocate ast (Select "LetParamName" ast))) - , (Show ((Select "TypeApplication" ast))) + , (Show (Select "TypeApplication" ast)) , (Show (ASTLocate ast (BinaryOperator' ast))) , (Show (Select "ExprType" ast)) , (Show (Select "PatternType" ast)) @@ -185,15 +185,15 @@ deriving instance deriving instance forall a (ast :: a). ( Data (ASTLocate ast (Expr' ast)) - , Data ((Select "LetPattern" ast)) - , Data ((Select "PatternType" ast)) - , Data ((Select "BinaryOperator" ast)) + , Data (Select "LetPattern" ast) + , Data (Select "PatternType" ast) + , Data (Select "BinaryOperator" ast) , (Data (Select "ExprType" ast)) , Data (ASTLocate ast (Select "VarRef" ast)) , Data (ASTLocate ast (Select "ConRef" ast)) , Data (ASTLocate ast (Select "LetParamName" ast)) , Data (ASTLocate ast (Select "LambdaPattern" ast)) - , Data ((Select "TypeApplication" ast)) + , Data (Select "TypeApplication" ast) , Data (ASTLocate ast (Pattern' ast)) , Typeable ast , Typeable a @@ -214,10 +214,10 @@ deriving instance forall a (ast :: a). ( Data (ASTLocate ast (Type' ast)) , Data (ASTLocate ast (Select "TypeVar" ast)) - , Data ((Select "TypeVar" ast)) + , Data (Select "TypeVar" ast) , Data (ASTLocate ast (Select "UserDefinedType" ast)) , Data (ASTLocate ast LowerAlphaName) - , Data ((Select "UserDefinedType" ast)) + , Data (Select "UserDefinedType" ast) , Typeable ast , Typeable a ) => diff --git a/src/Elara/AST/Generic/Pattern.hs b/src/Elara/AST/Generic/Pattern.hs index 20898bb0..e1d2113d 100644 --- a/src/Elara/AST/Generic/Pattern.hs +++ b/src/Elara/AST/Generic/Pattern.hs @@ -4,12 +4,12 @@ module Elara.AST.Generic.Pattern where import Elara.AST.Generic -pattern FunctionCall' :: ((ASTLocate ast1 (Expr' ast1)) ~ Expr' ast2) => Expr ast2 -> Expr ast2 -> Expr ast1 +pattern FunctionCall' :: (ASTLocate ast1 (Expr' ast1) ~ Expr' ast2) => Expr ast2 -> Expr ast2 -> Expr ast1 pattern FunctionCall' a b <- Expr (FunctionCall a b, _) functionCall :: forall a {a1} {a2} {ast1 :: a1} {ast2 :: a2}. - ((ASTLocate ast1 (Expr' ast1)) ~ Expr' ast2, Select "ExprType" ast1 ~ Maybe a) => + (ASTLocate ast1 (Expr' ast1) ~ Expr' ast2, Select "ExprType" ast1 ~ Maybe a) => Expr ast2 -> Expr ast2 -> Expr ast1 @@ -17,10 +17,10 @@ functionCall a b = Expr (FunctionCall a b, Nothing) var :: forall {a1} {a2} {ast1 :: a1} {ast2 :: a2} {a3}. - ( (ASTLocate ast1 (Expr' ast1)) ~ Expr' ast2 + ( ASTLocate ast1 (Expr' ast1) ~ Expr' ast2 , Select "ExprType" ast1 ~ Maybe a3 ) => - (ASTLocate ast2 (Select "VarRef" ast2)) -> + ASTLocate ast2 (Select "VarRef" ast2) -> Expr ast1 var a = Expr (Var a, Nothing) diff --git a/src/Elara/AST/Generic/Types.hs b/src/Elara/AST/Generic/Types.hs index 954a141e..f265b5be 100644 --- a/src/Elara/AST/Generic/Types.hs +++ b/src/Elara/AST/Generic/Types.hs @@ -70,7 +70,7 @@ data Expr' (ast :: a) (ASTLocate ast (Select "LambdaPattern" ast)) (Expr ast) | FunctionCall (Expr ast) (Expr ast) - | TypeApplication (Expr ast) ((Select "TypeApplication" ast)) + | TypeApplication (Expr ast) (Select "TypeApplication" ast) | If (Expr ast) (Expr ast) (Expr ast) | BinaryOperator !(Select "BinaryOperator" ast) | List [Expr ast] diff --git a/src/Elara/AST/Pretty.hs b/src/Elara/AST/Pretty.hs index 06843144..5633bf5d 100644 --- a/src/Elara/AST/Pretty.hs +++ b/src/Elara/AST/Pretty.hs @@ -90,14 +90,13 @@ prettyLetInExpr :: Expr ast -> Doc AnsiStyle prettyLetInExpr v ps e1 e2 = - ( "let" + "let" <+> pretty v <+> hsep (pretty <$> ps) <+> "=" <+> blockParensIf (?contextFree && shouldBrace e1) (pretty e1) <+> "in" <+> blockParensIf (?contextFree && shouldBrace e2) (pretty e2) - ) shouldBrace :: forall astK (ast :: astK). (RUnlocate ast) => Expr ast -> Bool shouldBrace x = case (x ^. _Unwrapped . _1 . to (rUnlocate @astK @ast)) :: Expr' ast of diff --git a/src/Elara/CoreToCore.hs b/src/Elara/CoreToCore.hs index 5ab298ca..82cd69f2 100644 --- a/src/Elara/CoreToCore.hs +++ b/src/Elara/CoreToCore.hs @@ -14,7 +14,7 @@ type CoreExprPass = CoreExpr -> CoreExpr constantFold :: CoreExprPass constantFold = transform f where - f (App (App (Var (Id (Global' (Qualified "+" (ModuleName ("Prelude" :| [])))) _)) (Lit (Int a))) (Lit (Int b))) = Lit (Int ((a + b))) + f (App (App (Var (Id (Global' (Qualified "+" (ModuleName ("Prelude" :| [])))) _)) (Lit (Int a))) (Lit (Int b))) = Lit (Int (a + b)) f other = other -- | Performs beta reduction on the Core AST to reduce redundant lambdas diff --git a/src/Elara/Emit/Expr.hs b/src/Elara/Emit/Expr.hs index 96000e5e..ec3b0ed4 100644 --- a/src/Elara/Emit/Expr.hs +++ b/src/Elara/Emit/Expr.hs @@ -22,12 +22,19 @@ generateInstructions (Var (JVMLocal 1)) = pure [ALoad1] generateInstructions (Var (JVMLocal 2)) = pure [ALoad2] generateInstructions (Var (JVMLocal 3)) = pure [ALoad3] generateInstructions (Lit s) = generateLitInstructions s -generateInstructions (Var (Normal (Id (Global (Identity v)) _))) +generateInstructions (Var (Normal (Id (Global' v) _))) | v == fetchPrimitiveName = error "elaraPrimitive without argument" -generateInstructions (App ((Var (Normal (Id (Global (Identity v)) _)))) (Lit (String primName))) +generateInstructions (App ((Var (Normal (Id (Global' v) _)))) (Lit (String primName))) | v == fetchPrimitiveName = generatePrimInstructions primName generateInstructions (App (TyApp (Var (Normal (Id (Global (Identity v)) _))) _) (Lit (String primName))) | v == fetchPrimitiveName = generatePrimInstructions primName +generateInstructions (Var (Normal (Id (Global' (Qualified n mn)) t))) = + pure + [ GetStatic + (ClassInfoType $ createModuleName mn) + (translateOperatorName n) + (generateFieldType t) + ] generateInstructions (App f x) = generateAppInstructions f x generateInstructions other = error $ "Not implemented: " <> showPretty other diff --git a/src/Elara/Emit/Lambda.hs b/src/Elara/Emit/Lambda.hs index 293c71da..437a955a 100644 --- a/src/Elara/Emit/Lambda.hs +++ b/src/Elara/Emit/Lambda.hs @@ -65,8 +65,7 @@ createLambda params returnType thisClassName body = do ( MethodRef (ClassInfoType thisClassName) lambdaMethodName - ( lambdaMethodDescriptor - ) + lambdaMethodDescriptor ) ) , BMMethodArg lambdaMethodDescriptor diff --git a/src/Elara/Emit/Method.hs b/src/Elara/Emit/Method.hs index 384b0aa6..a908ee99 100644 --- a/src/Elara/Emit/Method.hs +++ b/src/Elara/Emit/Method.hs @@ -18,14 +18,14 @@ type NamedMethodDescriptor = ([(Unique Text, FieldType)], FieldType) transformMethodParameters :: [UnlocatedVarRef Text] -> CoreExpr -> Expr JVMBinder transformMethodParameters params body = - let jvm = toJVMExpr body in foldr (\(name, idx) e -> replaceVar' (name) (JVMLocal idx) e) jvm (zip (params) [0 ..]) + let jvm = toJVMExpr body in foldr (\(name, idx) e -> replaceVar' name (JVMLocal idx) e) jvm (zip params [0 ..]) {- | Create a method in the current class, with the given name, descriptor, and body This handles the calculation of messiness like max stack and locals -} createMethod :: (Monad m) => NamedMethodDescriptor -> Text -> CoreExpr -> ClassBuilderT m () createMethod descriptor name body = do - let body' = transformMethodParameters ((Local . Identity . fst) <$> fst descriptor) body + let body' = transformMethodParameters (Local . Identity . fst <$> fst descriptor) body code <- generateInstructions body' let maxStack = analyseMaxStack code @@ -37,7 +37,7 @@ createMethod descriptor name body = do [ Code $ CodeAttributeData maxStack - (2 {- TODO -}) + 2 {- TODO -} code [] [] @@ -50,10 +50,10 @@ analyseMaxStack instructions = maximum $ scanl (+) 0 (stackChange <$> instructio stackChange (InvokeDynamic{}) = 1 stackChange (InvokeStatic{}) = 1 stackChange (InvokeVirtual{}) = 1 - stackChange (AConstNull) = 1 - stackChange (ALoad0) = 1 - stackChange (AReturn) = -1 - stackChange (AThrow) = -1 + stackChange AConstNull = 1 + stackChange ALoad0 = 1 + stackChange AReturn = -1 + stackChange AThrow = -1 stackChange (CheckCast _) = 0 stackChange (LDC _) = 1 stackChange (GetStatic{}) = 1 diff --git a/src/Elara/Lexer/Utils.hs b/src/Elara/Lexer/Utils.hs index b8c29973..7a712fea 100644 --- a/src/Elara/Lexer/Utils.hs +++ b/src/Elara/Lexer/Utils.hs @@ -250,7 +250,7 @@ splitQualName t = do -- >>> ["Prelude", "T", ""] = ("Prelude.T", ".") -- >>> ["A", "!", ""] = ("A", "!.") let isAlphaNumeric = T.all (\c -> isAlpha c || isDigit c) - (modPart, namePart) = span (liftA2 (&&) (isAlphaNumeric) (not . T.null)) (fromList xs) + (modPart, namePart) = span (liftA2 (&&) isAlphaNumeric (not . T.null)) (fromList xs) in if null namePart then -- TODO: this isn't very efficient (ModuleName $ fromList (init (fromList modPart)), last (fromList modPart)) diff --git a/src/Elara/Parse/Expression.hs b/src/Elara/Parse/Expression.hs index 4fda30e7..ca7a0332 100644 --- a/src/Elara/Parse/Expression.hs +++ b/src/Elara/Parse/Expression.hs @@ -21,7 +21,7 @@ import Text.Megaparsec (MonadParsec (eof), customFailure, sepEndBy, try, ()) import Prelude hiding (Op) locatedExpr :: Parser FrontendExpr' -> Parser FrontendExpr -locatedExpr = fmap (\x -> Expr (x, Nothing)) . (located) +locatedExpr = fmap (\x -> Expr (x, Nothing)) . located exprParser :: Parser FrontendExpr exprParser = @@ -137,7 +137,7 @@ match = locatedExpr $ do token_ TokenWith cases <- - (try (toList <$> block identity one matchCase)) + try (toList <$> block identity one matchCase) <|> (token_ TokenLeftBrace *> token_ TokenRightBrace $> []) -- allow empty match blocks pure $ Match expr cases where @@ -158,10 +158,10 @@ lambda = locatedExpr $ do let emptyLambdaLoc = spanningRegion' (args ^. sourceRegion :| [bsLoc ^. sourceRegion, arrLoc ^. sourceRegion]) let failEmptyBody = - ( eof + eof *> customFailure (EmptyLambda emptyLambdaLoc) - ) + res <- failEmptyBody <|> exprBlock element pure (Lambda args res) @@ -182,10 +182,10 @@ letPreamble :: Parser (Located VarName, [FrontendPattern], FrontendExpr) letPreamble = do token_ TokenLet name <- located unqualifiedVarName - patterns <- many (patParser) + patterns <- many patParser token_ TokenEquals - e <- (exprBlock (element)) + e <- exprBlock element pure (name, patterns, e) letInExpression :: Parser FrontendExpr -- TODO merge this, Declaration.valueDecl, and letInExpression into 1 tidier thing diff --git a/src/Elara/Parse/Indents.hs b/src/Elara/Parse/Indents.hs index 111c3028..6f46539a 100644 --- a/src/Elara/Parse/Indents.hs +++ b/src/Elara/Parse/Indents.hs @@ -19,7 +19,7 @@ dedentToken :: Parser () dedentToken = token_ TokenDedent <|> token_ TokenRightBrace block :: (NonEmpty a -> b) -> (a -> b) -> Parser a -> Parser b -block mergeFunction single exprParser = (try singleBlock <|> wholeBlock) +block mergeFunction single exprParser = try singleBlock <|> wholeBlock where singleBlock = single <$> exprParser wholeBlock = do diff --git a/src/Elara/Parse/Pattern.hs b/src/Elara/Parse/Pattern.hs index e1804cec..07b16587 100644 --- a/src/Elara/Parse/Pattern.hs +++ b/src/Elara/Parse/Pattern.hs @@ -16,7 +16,7 @@ patParser :: Parser FrontendPattern patParser = choice [ try literalPattern - , (inParens apat) + , inParens apat , varPattern , zeroArgConstructorPattern , wildcardPattern diff --git a/src/Elara/TypeInfer.hs b/src/Elara/TypeInfer.hs index c0f34084..65cd9a4b 100644 --- a/src/Elara/TypeInfer.hs +++ b/src/Elara/TypeInfer.hs @@ -217,7 +217,7 @@ completeExpression ctx (Expr (y', t)) = do traverseOf unlocated ( \case - TypeApplication f t' -> TypeApplication f <$> (complete ctx') t' + TypeApplication f t' -> TypeApplication f <$> complete ctx' t' o -> pure o ) y' diff --git a/src/Elara/TypeInfer/Infer.hs b/src/Elara/TypeInfer/Infer.hs index eb03bd2a..822d854f 100644 --- a/src/Elara/TypeInfer/Infer.hs +++ b/src/Elara/TypeInfer/Infer.hs @@ -1258,7 +1258,7 @@ infer (Syntax.Expr (Located location e0, _)) = case e0 of ( Expr ( Located primRegion - (TypeApplication _A ((Syntax.typeOf typedArgument))) + (TypeApplication _A (Syntax.typeOf typedArgument)) , resultType ) ) @@ -1272,14 +1272,14 @@ infer (Syntax.Expr (Located location e0, _)) = case e0 of | isVar input -> pure $ FunctionCall - ( Expr (Located primRegion (TypeApplication _A ((Syntax.typeOf typedArgument))), resultType) + ( Expr (Located primRegion (TypeApplication _A (Syntax.typeOf typedArgument)), resultType) ) typedArgument Type.Function{output} | isVar output -> pure $ FunctionCall - ( Expr (Located primRegion (TypeApplication _A ((Type.stripForAll resultType))), resultType) + ( Expr (Located primRegion (TypeApplication _A (Type.stripForAll resultType)), resultType) ) typedArgument _ -> do diff --git a/test/Parse/Expressions.hs b/test/Parse/Expressions.hs index 01079e7d..85b69528 100644 --- a/test/Parse/Expressions.hs +++ b/test/Parse/Expressions.hs @@ -26,20 +26,17 @@ weirdEdgeCases = describe "Parses some weird edge cases correctly" $ do `shouldParseExpr` Expr ( FunctionCall ( Expr - ( ( ( Lambda - [Pattern (VarPattern (LowerAlphaName "x"), Nothing)] - ( Expr - ( BinaryOperator - ( ( MkBinaryOperator (SymOp "+") - , Expr (Var (MaybeQualified "x" Nothing), Nothing) - , Expr (Int 2, Nothing) - ) - ) - , Nothing + ( Lambda + [Pattern (VarPattern (LowerAlphaName "x"), Nothing)] + ( Expr + ( BinaryOperator + ( MkBinaryOperator (SymOp "+") + , Expr (Var (MaybeQualified "x" Nothing), Nothing) + , Expr (Int 2, Nothing) ) + , Nothing ) ) - ) , Nothing ) )