diff options
Diffstat (limited to 'src/Haskell/AST.hs')
| -rw-r--r-- | src/Haskell/AST.hs | 60 |
1 files changed, 42 insertions, 18 deletions
diff --git a/src/Haskell/AST.hs b/src/Haskell/AST.hs index f8b5c72..54d19d3 100644 --- a/src/Haskell/AST.hs +++ b/src/Haskell/AST.hs @@ -20,12 +20,12 @@ data Toplevel = TopDef Def data Def = Def Name Expr deriving (Show, Eq) -data Expr = App Expr [Expr] - | Ref Name - | Num Integer - | Tup [Expr] - | Lam [Name] Expr - | Case Expr [(Pat, Expr)] +data Expr = App Expr [Expr] (Maybe Type) + | Ref Name (Maybe Type) + | Num Integer (Maybe Type) + | Tup [Expr] (Maybe Type) + | Lam [Name] Expr (Maybe Type) + | Case Expr [(Pat, Expr)] (Maybe Type) deriving (Show, Eq) data Pat = PatAny @@ -69,12 +69,12 @@ instance Pretty Def where pretty (Def n e) = Node (n ++ " =") [pretty e] instance Pretty Expr where - pretty (App e as) = Bracket "(" ")" "" (map pretty (e:as)) - pretty (Ref n) = Leaf n - pretty (Num n) = Leaf (show n) - pretty (Tup es) = Bracket "(" ")" "," (map pretty es) - pretty (Lam as e) = Bracket "(" ")" "" [Node ("\\" ++ intercalate " " as ++ " ->") [pretty e]] - pretty (Case e arms) = Bracket "(" ")" "" [Node ("case " ++ pprintOneline e ++ " of") [Bracket "{" "}" ";" (map go arms)]] + pretty (App e as _) = Bracket "(" ")" "" (map pretty (e:as)) + pretty (Ref n _) = Leaf n + pretty (Num n _) = Leaf (show n) + pretty (Tup es _) = Bracket "(" ")" "," (map pretty es) + pretty (Lam as e _) = Bracket "(" ")" "" [Node ("\\" ++ intercalate " " as ++ " ->") [pretty e]] + pretty (Case e arms _) = Bracket "(" ")" "" [Node ("case " ++ pprintOneline e ++ " of") [Bracket "{" "}" ";" (map go arms)]] where go (p, e') = Node (pprintOneline p ++ " ->") [pretty e'] instance Pretty Pat where @@ -122,12 +122,36 @@ instance AllRefs Def where allRefs (Def _ e) = allRefs e instance AllRefs Expr where - allRefs (App e es) = nub $ concatMap allRefs (e : es) - allRefs (Ref n) = [n] - allRefs (Num _) = [] - allRefs (Tup es) = nub $ concatMap allRefs es - allRefs (Lam ns e) = allRefs e \\ ns - allRefs (Case e pairs) = nub $ allRefs e ++ concatMap (allRefs . snd) pairs + allRefs (App e es _) = nub $ concatMap allRefs (e : es) + allRefs (Ref n _) = [n] + allRefs (Num _ _) = [] + allRefs (Tup es _) = nub $ concatMap allRefs es + allRefs (Lam ns e _) = allRefs e \\ ns + allRefs (Case e pairs _) = nub $ allRefs e ++ concatMap (allRefs . snd) pairs instance AllRefs Inst where allRefs (Inst _ _ ds) = nub $ concatMap allRefs ds + + +typeOf :: Expr -> Type +typeOf (App _ _ (Just ty)) = ty +typeOf (Ref _ (Just ty)) = ty +typeOf (Num _ (Just ty)) = ty +typeOf (Tup _ (Just ty)) = ty +typeOf (Lam _ _ (Just ty)) = ty +typeOf (Case _ _ (Just ty)) = ty +typeOf e = error $ "Unresolved type in typeOf in expression: " ++ show e + +typeApply :: Type -> Type -> Maybe Type +typeApply (TyFun t1 t2) t3 + | t1 == t3 = Just t2 + | otherwise = Nothing +typeApply _ _ = Nothing + +recurse :: (Pat -> Pat) -> (Expr -> Expr) -> Expr -> Expr +recurse _ f (App e as ty) = App (f e) (map f as) ty +recurse _ _ (Ref n ty) = Ref n ty +recurse _ _ (Num k ty) = Num k ty +recurse _ f (Tup es ty) = Tup (map f es) ty +recurse _ f (Lam ns e ty) = Lam ns (f e) ty +recurse fp f (Case e as ty) = Case (f e) (map (\(p, e') -> (fp p, f e')) as) ty |