fix some warnings and refactor even more

src/Elara/AST/Desugared.hs

@@ -1,9 +1,9 @@
 -- |
---  This is the second main AST stage, which is very similar to the `Elara.AST.Desugared.Expr` AST, with a few key differences:
+-- This is the second main AST stage, which is very similar to the `Elara.AST.Desugared.Expr` AST, with a few key differences:
 --
---    * Lambdas only have 1 argument (ones with multiple arguments are desugared into nested lambdas)
---    * Let bindings have no patterns, they are desugared into lambdas
---    * Def and Let declarations are merged into a single entity
+--   * Lambdas only have 1 argument (ones with multiple arguments are desugared into nested lambdas)
+--   * Let bindings have no patterns, they are desugared into lambdas
+--   * Def and Let declarations are merged into a single entity
 module Elara.AST.Desugared where
 
 import Elara.AST.Generic
@@ -35,6 +35,8 @@ type instance Select "InParens" 'Desugared = DesugaredExpr
 
 type instance Select "BinaryOperator" 'Desugared = (DesugaredBinaryOperator, DesugaredExpr, DesugaredExpr)
 
+type instance Select "TypeApplication" 'Desugared = DesugaredType
+
 -- Selections for 'BinaryOperator'
 type instance Select "SymOp" 'Desugared = MaybeQualified OpName
 
@@ -47,6 +49,8 @@ type instance Select "VarPat" 'Desugared = LowerAlphaName
 
 type instance Select "ConPat" 'Desugared = MaybeQualified TypeName
 
+type instance Select "TypeApplication" 'Desugared = DesugaredType
+
 -- Selections for 'Declaration'
 type instance Select "DeclarationName" 'Desugared = Name
 

src/Elara/AST/Generic/Instances/Pretty.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE ImplicitParams #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
@@ -81,6 +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 "InParens" ast)),
     (Pretty (ASTLocate ast (Select "LetParamName" ast))),
     Pretty letPatterns,
@@ -113,6 +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 "InParens" ast)),
     (Pretty (ASTLocate ast (Select "LetParamName" ast))),
     Pretty letPatterns,
@@ -140,8 +143,10 @@ prettyExpr (Expr (e, t)) = group (flatAlt long short)
     short = align (pretty pe <+> pretty te)
 
 instance
+  forall ast letPatterns lambdaPatterns.
   ( Pretty (ASTLocate ast (Select "ConRef" ast)),
     Pretty (ASTLocate ast (Select "VarRef" ast)),
+    Pretty ((Select "TypeApplication" ast)),
     (Pretty (Select "InParens" ast)),
     (Pretty (ASTLocate ast (Select "LetParamName" ast))),
     Pretty letPatterns,
@@ -173,8 +178,9 @@ prettyExpr' ::
     letPatterns ~ UnwrapList (Select "LetPattern" ast),
     ?contextFree :: Bool,
     ?withType :: Bool,
-    Pretty (ASTLocate ast (Select "ConRef" ast)),
     Pretty (ASTLocate ast (Select "VarRef" ast)),
+    Pretty (ASTLocate ast (Select "ConRef" ast)),
+    Pretty ((Select "TypeApplication" ast)),
     (Pretty (Select "InParens" ast)),
     (Pretty (ASTLocate ast (Select "LetParamName" ast))),
     Pretty letPatterns,
@@ -276,3 +282,28 @@ instance
     ListType a -> "[" <+> pretty a <+> "]"
     where
       prettyFields = hsep . punctuate "," . map (\(name, value) -> pretty name <+> ":" <+> pretty value) . toList
+
+-- type CommonPrettyExprConstraints ast lambdaPatterns letPatterns =
+--     ( lambdaPatterns ~ UnwrapList (Select "LambdaPattern" ast)
+--     , letPatterns ~ UnwrapList (Select "LetPattern" ast)
+--     , Pretty letPatterns
+--     , Pretty lambdaPatterns
+--     , Pretty (ASTLocate ast (Select "ConRef" ast))
+--     , Pretty (ASTLocate ast (Type' ast))
+--     , Pretty (ASTLocate ast (Select "VarRef" ast))
+--     , Pretty (ASTLocate ast (Select "TypeApplication" ast))
+--     , Pretty (Select "InParens" ast)
+--     , (Pretty (ASTLocate ast (Select "LetParamName" ast)))
+--     , (Pretty (UnwrapMaybe (Select "ExprType" ast)))
+--     , (Pretty (UnwrapMaybe (Select "PatternType" ast)))
+--     , (Pretty (ASTLocate ast (BinaryOperator' ast)))
+--     , (Pretty (CleanupLocated (ASTLocate' ast (Pattern' ast))))
+--     , (Pretty (Select "ExprType" ast))
+--     , (ToList (Select "LetPattern" ast) [letPatterns])
+--     , (ToList (ASTLocate ast (Select "LambdaPattern" ast)) [lambdaPatterns])
+--     , (ToMaybe (Select "ExprType" ast) (Maybe (UnwrapMaybe (Select "ExprType" ast))))
+--     , (ToMaybe (Select "PatternType" ast) (Maybe (UnwrapMaybe (Select "PatternType" ast))))
+--     , (StripLocation (ASTLocate ast (Expr' ast)) (Expr' ast))
+--     , (DataConAs (Select "BinaryOperator" ast) (BinaryOperator ast, Expr ast, Expr ast))
+--     , (ToList (Select "LetPattern" ast) [letPatterns])
+--     )

src/Elara/AST/Generic/Instances/Simple.hs

@@ -27,8 +27,10 @@ deriving instance
     (Eq (Select "ExprType" ast)),
     (Eq (Select "PatternType" ast)),
     (Eq (Select "BinaryOperator" ast)),
+    Eq ((Select "TypeApplication" ast)),
     Eq (ASTLocate ast (Expr' ast)),
-    Eq (ASTLocate ast (Pattern' ast))
+    Eq (ASTLocate ast (Pattern' ast)),
+    Eq (Type ast)
   ) =>
   Eq (Expr' ast)
 
@@ -71,13 +73,15 @@ 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 (ASTLocate ast (BinaryOperator' ast))),
     (Show (Select "InParens" ast)),
     (Show (Select "ExprType" ast)),
     (Show (Select "PatternType" ast)),
     Show (Select "BinaryOperator" ast),
     Show (ASTLocate ast (Expr' ast)),
-    Show (ASTLocate ast (Pattern' ast))
+    Show (ASTLocate ast (Pattern' ast)),
+    Show (Type ast)
   ) =>
   Show (Expr' ast)
 
@@ -192,6 +196,7 @@ deriving instance
     Data (ASTLocate ast (Select "ConRef" ast)),
     Data (ASTLocate ast (Select "LetParamName" ast)),
     Data (ASTLocate ast (Select "LambdaPattern" ast)),
+    Data ((Select "TypeApplication" ast)),
     Data (ASTLocate ast (Pattern' ast)),
     Typeable ast,
     Typeable a

src/Elara/AST/Generic/Instances/StripLocation.hs

@@ -16,52 +16,22 @@ instance
     ASTLocate' ast2 ~ Unlocated,
     (StripLocation (Select "LambdaPattern" ast1) (Select "LambdaPattern" ast2)),
     (StripLocation (Select "LetPattern" ast1) (Select "LetPattern" ast2)),
+    StripLocation (Select "TypeApplication" ast1) (Select "TypeApplication" ast2),
     (ApplyAsFunctorish (Select "ExprType" ast1) (Select "ExprType" ast2) (Type ast1) (Type ast2)),
     (ApplyAsFunctorish (Select "PatternType" ast1) (Select "PatternType" ast2) (Type ast1) (Type ast2)),
-    ( StripLocation
-        (Select "Infixed" ast1)
-        (Select "Infixed" ast2)
-    ),
-    ( StripLocation
-        (CleanupLocated (Located (Select "SymOp" ast1)))
-        (Select "SymOp" ast2)
-    ),
-    ( StripLocation
-        (CleanupLocated (Located (Select "TypeVar" ast1)))
-        (Select "TypeVar" ast2)
-    ),
-    ( StripLocation
-        (CleanupLocated (Located (Select "VarRef" ast1)))
-        (Select "VarRef" ast2)
-    ),
-    ( StripLocation
-        (CleanupLocated (Located (Select "VarPat" ast1)))
-        (Select "VarPat" ast2)
-    ),
-    ( StripLocation
-        (CleanupLocated (Located (Select "ConPat" ast1)))
-        (Select "ConPat" ast2)
-    ),
-    ( StripLocation
-        (CleanupLocated (Located (Select "ConRef" ast1)))
-        (Select "ConRef" ast2)
-    ),
-    ( StripLocation
-        (CleanupLocated (Located (Select "LambdaPattern" ast1)))
-        (Select "LambdaPattern" ast1)
-    ),
-    ( StripLocation
-        (CleanupLocated (Located (Select "LetParamName" ast1)))
-        (Select "LetParamName" ast2)
-    ),
-    ( DataConAs
-        (Select "BinaryOperator" ast1)
-        (BinaryOperator ast1, Expr ast1, Expr ast1)
-    ),
-    ( DataConAs
-        (Select "BinaryOperator" ast2)
-        (BinaryOperator ast2, Expr ast2, Expr ast2)
-    ),
+    (StripLocation (Select "Infixed" ast1) (Select "Infixed" ast2)),
+    (StripLocation (CleanupLocated (Located (Select "SymOp" ast1))) (Select "SymOp" ast2)),
+    (StripLocation (CleanupLocated (Located (Select "TypeVar" ast1))) (Select "TypeVar" ast2)),
+    (StripLocation (CleanupLocated (Located (Select "VarRef" ast1))) (Select "VarRef" ast2)),
+    (StripLocation (CleanupLocated (Located (Select "VarPat" ast1))) (Select "VarPat" ast2)),
+    (StripLocation (CleanupLocated (Located (Select "ConPat" ast1))) (Select "ConPat" ast2)),
+    (StripLocation (CleanupLocated (Located (Select "ConRef" ast1))) (Select "ConRef" ast2)),
+    (StripLocation (CleanupLocated (Located (Select "LambdaPattern" ast1))) (Select "LambdaPattern" ast1)),
+    (StripLocation (CleanupLocated (Located (Select "LetParamName" ast1))) (Select "LetParamName" ast2)),
+    (StripLocation (CleanupLocated (Located (Select "TypeApplication" ast1))) (Select "TypeApplication" ast1)),
+    (StripLocation (CleanupLocated (Located (Select "UserDefinedType" ast1))) (Select "UserDefinedType" ast2)),
+    (DataConAs (Select "BinaryOperator" ast1) (BinaryOperator ast1, Expr ast1, Expr ast1)),
+    (DataConAs (Select "BinaryOperator" ast2) (BinaryOperator ast2, Expr ast2, Expr ast2)),
     (DataConAs (Select "InParens" ast1) (Expr ast1)),
     (DataConAs (Select "InParens" ast2) (Expr ast2))
   ) =>
@@ -74,11 +44,10 @@ stripExprLocation ::
   ( ASTLocate' ast1 ~ Located,
     ASTLocate' ast2 ~ Unlocated,
     StripLocation (Select "LambdaPattern" ast1) (Select "LambdaPattern" ast2),
+    StripLocation (Select "TypeApplication" ast1) (Select "TypeApplication" ast2),
     StripLocation (Select "LetPattern" ast1) (Select "LetPattern" ast2),
     ApplyAsFunctorish (Select "ExprType" ast1) (Select "ExprType" ast2) (Type ast1) (Type ast2),
-    ( DataConAs
-        (Select "BinaryOperator" ast1)
-        (BinaryOperator ast1, Expr ast1, Expr ast1)
+    ( DataConAs (Select "BinaryOperator" ast1) (BinaryOperator ast1, Expr ast1, Expr ast1)
     ),
     _
   ) =>
@@ -108,10 +77,12 @@ stripExprLocation (Expr (e :: ASTLocate ast1 (Expr' ast1), t)) =
               ps'
        in Lambda ps'' (stripExprLocation e)
     stripExprLocation' (FunctionCall e1 e2) = FunctionCall (stripExprLocation e1) (stripExprLocation e2)
-    stripExprLocation' (TypeApplication e1 e2) =
-      TypeApplication
-        (stripExprLocation e1)
-        (applyAsFunctorish @(Select "ExprType" ast1) @(Select "ExprType" ast2) @(Type ast1) @(Type ast2) stripTypeLocation e2)
+    stripExprLocation' (TypeApplication e1 t1) =
+      let t1' = stripLocation t1
+          t1'' = stripLocation @(Select "TypeApplication" ast1) @(Select "TypeApplication" ast2) t1'
+       in TypeApplication
+            (stripExprLocation e1)
+            t1''
     stripExprLocation' (If e1 e2 e3) = If (stripExprLocation e1) (stripExprLocation e2) (stripExprLocation e3)
     stripExprLocation' (BinaryOperator b) =
       let (op, e1, e2) = dataConAs @(Select "BinaryOperator" ast1) @(BinaryOperator ast1, Expr ast1, Expr ast1) b
@@ -155,7 +126,8 @@ instance
     ( StripLocation
         (CleanupLocated (Located (Select "ConPat" ast1)))
         (Select "ConPat" ast2)
-    )
+    ),
+    (StripLocation (CleanupLocated (Located (Select "UserDefinedType" ast1))) (Select "UserDefinedType" ast2))
   ) =>
   StripLocation (Pattern ast1) (Pattern ast2)
   where
@@ -192,9 +164,7 @@ instance
   forall (ast1 :: LocatedAST) (ast2 :: UnlocatedAST).
   ( ASTLocate' ast1 ~ Located,
     ASTLocate' ast2 ~ Unlocated,
-    ( StripLocation
-        (Select "Infixed" ast1)
-        (Select "Infixed" ast2)
+    ( StripLocation (Select "Infixed" ast1) (Select "Infixed" ast2)
     ),
     ( StripLocation
         (CleanupLocated (Located (Select "SymOp" ast1)))
@@ -239,3 +209,7 @@ stripTypeLocation (Type (t :: ASTLocate ast1 (Type' ast1))) =
     stripTypeLocation' (FunctionType a b) = FunctionType (stripTypeLocation a) (stripTypeLocation b)
     stripTypeLocation' UnitType = UnitType
     stripTypeLocation' (TypeConstructorApplication a b) = TypeConstructorApplication (stripTypeLocation a) (stripTypeLocation b)
+    stripTypeLocation' (ListType a) = ListType (stripTypeLocation a)
+    stripTypeLocation' (TupleType a) = TupleType (stripTypeLocation <$> a)
+    stripTypeLocation' (UserDefinedType n) = UserDefinedType (stripLocation n)
+    stripTypeLocation' (RecordType r) = RecordType (bimapF stripLocation stripTypeLocation r)

src/Elara/AST/Generic/Types.hs

@@ -69,7 +69,7 @@ data Expr' (ast :: a)
       (ASTLocate ast (Select "LambdaPattern" ast))
       (Expr ast)
   | FunctionCall (Expr ast) (Expr ast)
-  | TypeApplication (Expr ast) (Select "ExprType" ast)
+  | TypeApplication (Expr ast) ((Select "TypeApplication" ast))
   | If (Expr ast) (Expr ast) (Expr ast)
   | BinaryOperator !(Select "BinaryOperator" ast)
   | List [Expr ast]

src/Elara/AST/Module.hs

@@ -19,7 +19,6 @@ import Elara.AST.Region (Located, unlocated)
 import Elara.Data.Pretty
 import Elara.Data.Pretty.Styles qualified as Style
 import Elara.Data.TopologicalGraph
-import Print (debugPretty)
 import Unsafe.Coerce
 import Prelude hiding (Text)
 
@@ -57,6 +56,7 @@ data Exposition ast
   | ExposedTypeAndAllConstructors (FullASTQual ast TypeName) -- exposing Foo(..)
   deriving (Generic)
 
+traverseModule :: (_) => (a4 -> f (Declaration ast)) -> s1 -> f t
 traverseModule traverseDecl =
   traverseOf
     (_Unwrapped . unlocated)
@@ -116,19 +116,14 @@ traverseModuleRevTopologically traverseDecl =
     )
 
 instance
-  ( Pretty (ASTLocate ast ModuleName),
-    Pretty (ASTLocate ast (Import' ast)),
-    Pretty (ASTLocate ast (Exposing ast)),
-    Pretty (ASTLocate ast (Module' ast))
+  ( Pretty (ASTLocate ast (Module' ast))
   ) =>
   Pretty (Module ast)
   where
   pretty (Module m) = pretty m
 
 instance
   ( Pretty (ASTLocate ast ModuleName),
-    Pretty (ASTLocate ast (Import' ast)),
-    Pretty (ASTLocate ast (Exposing ast)),
     Pretty (Exposing ast),
     Pretty (Import ast),
     Pretty (Declaration ast)

src/Elara/AST/Renamed.hs

@@ -42,6 +42,8 @@ type instance Select "VarPat" 'Renamed = Unique LowerAlphaName
 
 type instance Select "ConPat" 'Renamed = Qualified TypeName
 
+type instance Select "TypeApplication" 'Renamed = RenamedType
+
 -- Selections for 'DeclarationBody'
 type instance Select "ValuePatterns" 'Renamed = NoFieldValue
 

src/Elara/AST/Shunted.hs

@@ -52,6 +52,8 @@ type instance Select "VarPat" 'Shunted = Unique LowerAlphaName
 
 type instance Select "ConPat" 'Shunted = Qualified TypeName
 
+type instance Select "TypeApplication" 'Shunted = ShuntedType
+
 -- Selections for 'DeclarationBody'
 type instance Select "ValuePatterns" 'Shunted = NoFieldValue
 

src/Elara/AST/Typed.hs

@@ -6,8 +6,6 @@
 -- - Everything has a type!
 module Elara.AST.Typed where
 
-import Control.Lens (Plated)
-import Data.Data (Data)
 import Elara.AST.Generic (ASTLocate', ASTQual, Select)
 import Elara.AST.Generic qualified as Generic
 import Elara.AST.Generic.Common
@@ -49,6 +47,8 @@ type instance Select "VarPat" 'Typed = Unique VarName
 
 type instance Select "ConPat" 'Typed = Qualified TypeName
 
+type instance Select "TypeApplication" Typed = Type SourceRegion
+
 -- Selections for 'DeclarationBody'
 type instance Select "ValuePatterns" 'Typed = NoFieldValue
 

src/Elara/Rename.hs

@@ -234,7 +234,7 @@ addDeclarationToContext _ decl = do
 
   case decl ^. _Unwrapped . unlocated . field @"body" . _Unwrapped . unlocated of
     -- Add all the constructor names to field' context
-    TypeDeclaration _ (Located _ (ADT constructors)) -> todo
+    TypeDeclaration _ (Located _ (ADT _)) -> todo
     --     traverseOf_ (each . _1 . unlocated) (\tn -> modify $ over (the @"typeNames") $ Map.insert tn (global tn)) constructors
     _ -> pass
 
@@ -356,6 +356,10 @@ renameExpr (Expr le) =
       e1' <- renameExpr e1
       e2' <- renameExpr e2
       pure $ FunctionCall e1' e2'
+    renameExpr' (TypeApplication e1 t1) = do
+      e1' <- renameExpr e1
+      t1' <- traverseOf (_Unwrapped . unlocated) (renameType False) t1
+      pure $ TypeApplication e1' t1'
     renameExpr' (If e1 e2 e3) = do
       e1' <- renameExpr e1
       e2' <- renameExpr e2
@@ -477,7 +481,7 @@ patternToMatch pat body = do
 -- This is a little bit special because patterns have to be converted to match expressions
 --
 -- For example,
---   @\(a, b) -> a@  becomes @\ab_ -> match ab_ with (a, b) -> a@
+--  @\(a, b) -> a@  becomes @\ab_ -> match ab_ with (a, b) -> a@
 renameLambda :: (Rename r) => DesugaredPattern -> DesugaredExpr -> Sem r RenamedExpr'
 renameLambda p e = do
   (arg, match) <- patternToMatch p e

src/Elara/TypeInfer.hs

@@ -220,7 +220,7 @@ completeExpression ctx e@(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'