module FreeC.IR.Syntax.Expr where
import Control.Monad ( (>=>) )
import FreeC.IR.SrcSpan
import FreeC.IR.Syntax.Name
import FreeC.IR.Syntax.Type
import FreeC.IR.Syntax.TypeScheme
import FreeC.Pretty
data Expr
=
Con { exprSrcSpan :: SrcSpan
, exprConName :: ConName
, exprTypeScheme :: Maybe TypeScheme
}
| Var { exprSrcSpan :: SrcSpan
, exprVarName :: VarName
, exprTypeScheme :: Maybe TypeScheme
}
| App { exprSrcSpan :: SrcSpan
, exprAppLhs :: Expr
, exprAppRhs :: Expr
, exprTypeScheme :: Maybe TypeScheme
}
| TypeAppExpr { exprSrcSpan :: SrcSpan
, exprTypeAppLhs :: Expr
, exprTypeAppRhs :: Type
, exprTypeScheme :: Maybe TypeScheme
}
| If { exprSrcSpan :: SrcSpan
, ifExprCond :: Expr
, ifExprThen :: Expr
, ifExprElse :: Expr
, exprTypeScheme :: Maybe TypeScheme
}
| Case { exprSrcSpan :: SrcSpan
, caseExprScrutinee :: Expr
, caseExprAlts :: [Alt]
, exprTypeScheme :: Maybe TypeScheme
}
| Undefined { exprSrcSpan :: SrcSpan, exprTypeScheme :: Maybe TypeScheme }
| ErrorExpr { exprSrcSpan :: SrcSpan
, errorExprMsg :: String
, exprTypeScheme :: Maybe TypeScheme
}
| Trace { exprSrcSpan :: SrcSpan
, traceMsg :: String
, traceExpr :: Expr
, exprTypeScheme :: Maybe TypeScheme
}
| IntLiteral { exprSrcSpan :: SrcSpan
, intLiteralValue :: Integer
, exprTypeScheme :: Maybe TypeScheme
}
| Lambda { exprSrcSpan :: SrcSpan
, lambdaExprArgs :: [VarPat]
, lambdaExprRhs :: Expr
, exprTypeScheme :: Maybe TypeScheme
}
| Let { exprSrcSpan :: SrcSpan
, letExprBinds :: [Bind]
, letExprIn :: Expr
, exprTypeScheme :: Maybe TypeScheme
}
deriving ( Eq, Show )
exprType :: Expr -> Maybe Type
exprType = exprTypeScheme >=> \(TypeScheme _ typeArgs typeExpr) ->
if null typeArgs then Just typeExpr else Nothing
untypedCon :: SrcSpan -> ConName -> Expr
untypedCon srcSpan conName = Con srcSpan conName Nothing
untypedVar :: SrcSpan -> ConName -> Expr
untypedVar srcSpan varName = Var srcSpan varName Nothing
untypedApp :: SrcSpan -> Expr -> Expr -> Expr
untypedApp srcSpan e1 e2 = App srcSpan e1 e2 appType
where
appType :: Maybe TypeScheme
appType = exprTypeScheme e1 >>= maybeFuncResTypeScheme
maybeFuncResTypeScheme :: TypeScheme -> Maybe TypeScheme
maybeFuncResTypeScheme (TypeScheme srcSpan' typeArgs typeExpr)
= TypeScheme srcSpan' typeArgs <$> maybeFuncResType typeExpr
maybeFuncResType :: Type -> Maybe Type
maybeFuncResType (FuncType _ _ resType) = Just resType
maybeFuncResType _ = Nothing
untypedTypeAppExpr :: SrcSpan -> Expr -> Type -> Expr
untypedTypeAppExpr srcSpan expr typeExpr = TypeAppExpr srcSpan expr typeExpr
(exprTypeScheme expr)
app :: SrcSpan -> Expr -> [Expr] -> Expr
app = foldl . untypedApp
varApp :: SrcSpan
-> VarName
-> [Expr]
-> Expr
varApp srcSpan = app srcSpan . untypedVar srcSpan
conApp :: SrcSpan
-> ConName
-> [Expr]
-> Expr
conApp srcSpan = app srcSpan . untypedCon srcSpan
visibleTypeApp :: SrcSpan -> Expr -> [Type] -> Expr
visibleTypeApp = foldl . untypedTypeAppExpr
getFuncName :: Expr -> Maybe VarName
getFuncName (Var _ varName _) = Just varName
getFuncName (App _ lhs _ _) = getFuncName lhs
getFuncName _ = Nothing
instance Pretty Expr where
pretty = prettyExprPred 0
prettyExprPred :: Int -> Expr -> Doc
prettyExprPred n expr = case exprTypeScheme expr of
Nothing -> prettyExprPred' n expr
Just typeScheme | n == 0 -> prettyExpr
| otherwise -> parens prettyExpr
where
prettyExpr :: Doc
prettyExpr
= prettyExprPred' 1 expr <+> colon <> colon <+> pretty typeScheme
prettyExprPred' :: Int -> Expr -> Doc
prettyExprPred' n expr@(Case _ scrutinee alts _)
| n <= 1 = prettyString "case"
<+> prettyExprPred 1 scrutinee
<+> prettyString "of"
<+> braces
(space <> prettySeparated (semi <> space) (map pretty alts) <> space)
| otherwise = parens (prettyExprPred' 1 expr)
prettyExprPred' 0 (If _ e1 e2 e3 _) = prettyString "if"
<+> prettyExprPred 1 e1
<+> prettyString "then"
<+> prettyExprPred 0 e2
<+> prettyString "else"
<+> prettyExprPred 0 e3
prettyExprPred' 0 (Lambda _ args expr _) = backslash <> hsep (map pretty args)
<+> prettyString "->"
<+> prettyExprPred 0 expr
prettyExprPred' 0 (Let _ bs e _) = prettyString "let"
<+> braces (space <> prettySeparated (semi <> space) (map pretty bs) <> space)
<+> prettyString "in"
<+> prettyExprPred 0 e
prettyExprPred' _ expr@(If _ _ _ _ _) = parens (prettyExprPred' 0 expr)
prettyExprPred' _ expr@(Lambda _ _ _ _) = parens (prettyExprPred' 0 expr)
prettyExprPred' _ expr@(Let _ _ _ _) = parens (prettyExprPred' 0 expr)
prettyExprPred' n (TypeAppExpr _ (ErrorExpr _ msg _) t _)
| n <= 1 = prettyString "error"
<+> char '@' <> prettyTypePred 2 t
<+> prettyString (show msg)
prettyExprPred' n (TypeAppExpr _ (Trace _ msg e _) t _)
| n <= 1 = prettyString "trace"
<+> char '@' <> prettyTypePred 2 t
<+> prettyString (show msg)
<+> prettyExprPred' 2 e
prettyExprPred' n expr@(App _ e1 e2 _)
| n <= 1 = prettyExprPred 1 e1 <+> prettyExprPred 2 e2
| otherwise = parens (prettyExprPred' 1 expr)
prettyExprPred' n expr@(TypeAppExpr _ e t _)
| n <= 1 = prettyExprPred 1 e <+> char '@' <> prettyTypePred 2 t
| otherwise = parens (prettyExprPred' 1 expr)
prettyExprPred' n expr@(ErrorExpr _ msg _)
| n <= 1 = prettyString "error" <+> prettyString (show msg)
| otherwise = parens (prettyExprPred' 1 expr)
prettyExprPred' n expr@(Trace _ msg e _)
| n <= 1
= prettyString "trace" <+> prettyString (show msg) <+> prettyExprPred' 2 e
| otherwise = parens (prettyExprPred' 1 expr)
prettyExprPred' _ (Con _ name _) = pretty name
prettyExprPred' _ (Var _ name _) = pretty name
prettyExprPred' _ (IntLiteral _ i _) = integer i
prettyExprPred' _ (Undefined _ _) = prettyString "undefined"
data Alt = Alt { altSrcSpan :: SrcSpan
, altConPat :: ConPat
, altVarPats :: [VarPat]
, altRhs :: Expr
}
deriving ( Eq, Show )
instance Pretty Alt where
pretty (Alt _ conPat varPats expr) = pretty conPat
<+> hsep (map pretty varPats)
<+> prettyString "->"
<+> pretty expr
data ConPat = ConPat { conPatSrcSpan :: SrcSpan, conPatName :: ConName }
deriving ( Eq, Show )
conPatToExpr :: ConPat -> Expr
conPatToExpr (ConPat srcSpan conName) = Con srcSpan conName Nothing
instance Pretty ConPat where
pretty (ConPat _ conName) = pretty conName
data VarPat = VarPat { varPatSrcSpan :: SrcSpan
, varPatIdent :: String
, varPatType :: Maybe Type
, varPatIsStrict :: Bool
}
deriving ( Eq, Show )
instance HasDeclIdent VarPat where
declIdent varPat = DeclIdent (varPatSrcSpan varPat)
(UnQual (Ident (varPatIdent varPat)))
varPatName :: VarPat -> Name
varPatName = Ident . varPatIdent
varPatQName :: VarPat -> QName
varPatQName = UnQual . varPatName
varPatToExpr :: VarPat -> Expr
varPatToExpr (VarPat srcSpan varName _ _) = Var srcSpan (UnQual (Ident varName))
Nothing
toVarPat :: String -> VarPat
toVarPat ident = VarPat NoSrcSpan ident Nothing False
instance Pretty VarPat where
pretty (VarPat _ varName Nothing False) = pretty varName
pretty (VarPat _ varName Nothing True) = char '!' <> pretty varName
pretty (VarPat _ varName (Just varType) False) = parens
(pretty varName <+> colon <> colon <+> pretty varType)
pretty (VarPat _ varName (Just varType) True) = char '!'
<> parens (pretty varName <+> colon <> colon <+> pretty varType)
data Bind
= Bind { bindSrcSpan :: SrcSpan, bindVarPat :: VarPat, bindExpr :: Expr }
deriving ( Eq, Show )
instance HasDeclIdent Bind where
declIdent = declIdent . bindVarPat
instance Pretty Bind where
pretty (Bind _ varPat expr)
= pretty varPat <+> prettyString "=" <+> pretty expr