Inference on most expressions. HM based.

Still have to figure out how to infer type of lambda variables, as well
as how function application on polymorphic should work

src/Renamer/Renamer.hs

@@ -0,0 +1,90 @@
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Renamer.Renamer (rename) where
+
+import           Control.Applicative  (Applicative (liftA2))
+import           Control.Monad.Except (MonadError (throwError))
+import           Control.Monad.RWS    (MonadState, gets, modify)
+import           Control.Monad.State  (StateT, evalStateT)
+import           Data.Set             (Set)
+import qualified Data.Set             as Set
+import           Grammar.Abs
+import           Grammar.ErrM         (Err)
+import           Grammar.Print        (printTree)
+import qualified Renamer.RenamerIr            as R
+
+
+data Cxt = Cxt
+  { uniques    :: [(Ident, R.Unique)]
+  , nextUnique :: R.Unique
+  , sig        :: Set Ident
+  }
+
+initCxt :: Cxt
+initCxt = Cxt
+  { uniques    = []
+  , nextUnique = R.Unique 0
+  , sig        = mempty
+  }
+
+newtype Rn a = Rn { runRn :: StateT Cxt Err a }
+  deriving (Functor, Applicative, Monad, MonadState Cxt, MonadError String)
+
+rename :: Program -> Err R.Program
+rename p = evalStateT (runRn $ renameProgram p) initCxt
+
+renameProgram :: Program -> Rn R.Program
+renameProgram (Program ds (Main e)) = do
+  ds' <- mapM renameDef ds
+  e'  <- renameExp e
+  pure $ R.Program ds' (R.Main e')
+
+renameDef :: Def -> Rn R.Def
+renameDef = \case
+  DExp x t _ xs e -> do
+    newSig x
+    xs' <- mapM newUnique xs
+    e'  <- renameExp e
+    let e'' = foldr ($) e' . zipWith R.EAbs xs' $ fromTree t
+    pure . R.DBind $ R.Bind x t e''
+
+renameExp :: Exp -> Rn R.Exp
+renameExp = \case
+  EId x      -> R.EId <$> findBind x
+  EInt i     -> pure $ R.EInt i
+  EApp e e1  -> liftA2 R.EApp (renameExp e) $ renameExp e1
+  EAdd e e1  -> liftA2 R.EAdd (renameExp e) $ renameExp e1
+  EAbs x t e -> do
+    x' <- newUnique x
+    e' <- renameExp e
+    pure $ R.EAbs x' t e'
+
+findBind :: Ident -> Rn R.Name
+findBind x = lookupUnique x >>= \case
+    Just u  -> pure $ R.Nu u
+    Nothing -> gets (Set.member x . sig) >>= \case
+      False -> throwError ("Unbound variable " ++ printTree x)
+      True  -> pure $ R.Ni x
+
+newUnique :: Ident -> Rn R.Unique
+newUnique x = do
+  u <- gets nextUnique
+  modify $ \env -> env { nextUnique = succ u
+                       , uniques = (x, u) : env.uniques
+                       }
+  pure u
+
+newSig :: Ident -> Rn ()
+newSig x = modify $ \cxt -> cxt { sig = Set.insert x cxt.sig}
+
+lookupUnique :: Ident -> Rn (Maybe R.Unique)
+lookupUnique x = lookup x <$> gets uniques
+
+fromTree :: Type -> [Type]
+fromTree = fromTree' []
+
+fromTree' :: [Type] -> Type -> [Type]
+fromTree' acc = \case
+  TFun t t1 -> acc ++ [t] ++ fromTree t1
+  other     -> other : acc

src/Renamer/RenamerIr.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
+
+module Renamer.RenamerIr where
+
+import           Grammar.Abs   (Ident, Type (..))
+import           Grammar.Print
+
+
+data Program = Program [Def] Main
+  deriving (Eq, Ord, Show, Read)
+
+newtype Main = Main Exp
+  deriving (Eq, Ord, Show, Read)
+
+
+newtype Def = DBind Bind
+  deriving (Eq, Ord, Show, Read)
+
+data Name = Nu Unique | Ni Ident deriving (Ord, Show, Eq, Read)
+
+newtype Unique = Unique Int deriving (Enum, Eq, Read, Ord)
+instance Show Unique where show (Unique i) = "x" ++ show i
+
+data Exp
+    = EId  Name
+    | EInt Integer
+    | EApp Exp Exp
+    | EAdd Exp Exp
+    | EAbs Unique Type Exp
+  deriving (Eq, Ord, Show, Read)
+
+
+data Bind = Bind Ident Type Exp
+  deriving (Eq, Ord, Show, Read)
+
+
+instance Print Program where
+  prt i = \case
+    Program defs main -> prPrec i 0 (concatD [prt 0 defs, prt 0 main])
+
+
+instance Print Def where
+  prt i (DBind b) = prPrec i 0 $ concatD [prt 0 b, doc (showString ";")]
+
+instance Print Bind where
+  prt i = \case
+    Bind x t e -> prPrec i 0 $ concatD
+      [ prt 0 x
+      , doc (showString ":")
+      , prt 0 t
+      , doc (showString "=")
+      , prt 0 e]
+
+instance Print [Def] where
+  prt _ []     = concatD []
+  prt _ (x:xs) = concatD [prt 0 x, prt 0 xs]
+
+
+instance Print Main where
+  prt i = \case
+    Main exp -> prPrec i 0 $ concatD
+     [ doc (showString "main")
+     , doc (showString "=")
+     , prt 0 exp
+     , doc (showString ";")
+     ]
+
+instance Print Exp where
+  prt i = \case
+    EId u -> prPrec i 3 (concatD [prt 0 u])
+    EInt n -> prPrec i 3 (concatD [prt 0 n])
+    EApp e e1 -> prPrec i 2 (concatD [prt 2 e, prt 3 e1])
+    EAdd e e1 -> prPrec i 1 (concatD [prt 1 e, doc (showString "+"), prt 2 e1])
+    EAbs u t e -> prPrec i 0 (concatD [doc (showString "\\"), prt 0 u, doc (showString ":"), prt 0 t, doc (showString "."), prt 0 e])
+
+
+instance Print Name where
+  prt _ = \case
+    Ni i -> prt 0 i
+    Nu u -> prt 0 u
+
+instance Print Unique where
+  prt _ = doc . showString . show