Add module to sort definitions

language.cabal

@@ -36,6 +36,7 @@ executable language
       Renamer.Renamer
       TypeChecker.TypeChecker
       AnnForall
+      OrderDefs
       TypeChecker.TypeCheckerHm
       TypeChecker.TypeCheckerBidir
       TypeChecker.TypeCheckerIr
@@ -90,6 +91,7 @@ Test-suite language-testsuite
       Grammar.Skel
       Grammar.ErrM
       Grammar.Layout
+      OrderDefs
       Auxiliary
       Monomorphizer.Monomorphizer
       Monomorphizer.MonomorphizerIr

src/Main.hs

@@ -16,29 +16,21 @@ import Grammar.Par (myLexer, pProgram)
 import           Grammar.Print               (Print, printTree)
 import           LambdaLifter                (lambdaLift)
 import           Monomorphizer.Monomorphizer (monomorphize)
+import           OrderDefs                   (orderDefs)
 import           Renamer.Renamer             (rename)
 import           ReportForall                (reportForall)
-import System.Console.GetOpt (
-    ArgDescr (NoArg, ReqArg),
+import           System.Console.GetOpt       (ArgDescr (NoArg, ReqArg),
                                               ArgOrder (RequireOrder),
-    OptDescr (Option),
-    getOpt,
-    usageInfo,
- )
-import System.Directory (
-    createDirectory,
-    doesPathExist,
+                                              OptDescr (Option), getOpt,
+                                              usageInfo)
+import           System.Directory            (createDirectory, doesPathExist,
                                               getDirectoryContents,
                                               removeDirectoryRecursive,
-    setCurrentDirectory,
- )
+                                              setCurrentDirectory)
 import           System.Environment          (getArgs)
-import System.Exit (
-    ExitCode (ExitFailure),
-    exitFailure,
-    exitSuccess,
-    exitWith,
- )
+import           System.Exit                 (ExitCode (ExitFailure),
+                                              exitFailure, exitSuccess,
+                                              exitWith)
 import           System.IO                   (stderr)
 import           System.Process              (spawnCommand, waitForProcess)
 import           TypeChecker.TypeChecker     (TypeChecker (Bi, Hm), typecheck)
@@ -112,7 +104,7 @@ main' opts s =
             file <- readFile s
 
             printToErr "-- Parse Tree -- "
-            parsed <- fromErr . pProgram . resolveLayout True $ myLexer (file ++ prelude)
+            parsed <- fromErr . pProgram . resolveLayout True $ myLexer file -- (file ++ prelude)
             log parsed
 
             printToErr "-- Desugar --"
@@ -125,7 +117,7 @@ main' opts s =
             log renamed
 
             printToErr "\n-- TypeChecker --"
-            typechecked <- fromErr $ typecheck (fromJust opts.typechecker) renamed
+            typechecked <- fromErr $ typecheck (fromJust opts.typechecker) (orderDefs renamed)
             log typechecked
 
             printToErr "\n-- Lambda Lifter --"

src/OrderDefs.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE LambdaCase #-}
+
+module OrderDefs where
+
+import           Control.Monad.State (State, execState, get, modify, when)
+import           Data.Function       (on)
+import           Data.List           (partition, sortBy)
+import           Data.Set            (Set)
+import qualified Data.Set            as Set
+import           Grammar.Abs
+
+orderDefs :: Program -> Program
+orderDefs (Program defs) =
+    Program $ not_binds ++ map DBind (has_sig ++ orderBinds no_sig)
+
+  where
+    (has_sig, no_sig) = partition (\(Bind n _ _) -> elem n sig_names)
+                                   [ b | DBind b <- defs]
+    sig_names = [ n | DSig (Sig n _) <- defs ]
+    not_binds = flip filter defs $ \case DBind _ -> False
+                                         _       -> True
+
+orderBinds ::  [Bind] -> [Bind]
+orderBinds binds = sortBy (on compare countUniqueCalls) binds
+  where
+    bind_names = [ n | Bind n _ _ <- binds]
+
+    countUniqueCalls :: Bind -> Int
+    countUniqueCalls (Bind n _ e) =
+        Set.size $ execState (go e) (Set.singleton n)
+      where
+        go :: Exp -> State (Set LIdent) ()
+        go exp = get >>= \called -> case exp of
+          EVar x -> when (Set.notMember x called && elem x bind_names) $
+                        modify (Set.insert x)
+          EApp e1 e2           -> on (>>) go e1 e2
+          EAdd e1 e2           -> on (>>) go e1 e2
+          ELet (Bind _ _ e) e' -> on (>>) go e e'
+          EAbs _ e             -> go e
+          ECase e bs           -> go e >> mapM_ (\(Branch _ e) -> go e) bs
+          EAnn e _             -> go e
+          EInj _               -> pure ()
+          ELit _               -> pure ()

src/TypeChecker/TypeCheckerBidir.hs

@@ -11,7 +11,7 @@ import           Control.Applicative       (Applicative (liftA2), (<|>))
 import           Control.Monad.Except      (ExceptT, MonadError (throwError),
                                             forM, runExceptT, unless, zipWithM,
                                             zipWithM_)
-import           Control.Monad.Extra       (fromMaybeM)
+import           Control.Monad.Extra       (fromMaybeM, ifM)
 import           Control.Monad.State       (MonadState, State, evalState, gets,
                                             modify)
 import           Data.Coerce               (coerce)
@@ -57,6 +57,7 @@ data Cxt = Cxt
     , binds       :: Map LIdent Exp  -- ^ Top-level binds x : e
     , next_tevar  :: Int             -- ^ Counter to distinguish ά
     , data_injs   :: Map UIdent Type -- ^ Data injections (constructors) K/inj : A
+    , currentBind :: LIdent          -- ^ Used for recursive functions
     } deriving (Show, Eq)
 
 newtype Tc a = Tc { runTc :: ExceptT String (State Cxt) a }
@@ -77,6 +78,7 @@ initCxt defs = Cxt
                                         | DData (Data _ injs) <- defs
                                         , Inj name t <- injs
                                         ]
+            , currentBind = ""
             }
   where
     unboundedTVars = uncurry (Set.\\)  . go (mempty, mempty)
@@ -102,6 +104,7 @@ typecheckBinds cxt = flip evalState cxt
 
 typecheckBind :: Bind -> Tc (T.Bind' Type)
 typecheckBind (Bind name vars rhs) = do
+    modify $ \cxt -> cxt { currentBind = name }
     bind'@(T.Bind (name, typ) _ _) <- lookupSig name >>= \case
         Just t  -> do
             (rhs', _) <- check (foldr EAbs rhs vars) t
@@ -297,14 +300,16 @@ checkPattern patt t_patt = case patt of
 infer :: Exp -> Tc (T.ExpT' Type)
 infer (ELit lit) = apply (T.ELit lit, litType lit)
 
---  Γ ∋ (x : A)         Γ ∌ (x : A)
---  ------------- Var   --------------------- Var'
+--  Γ ∋ (x : A)         Γ ⊢ rec(x)
+--  ------------- Var   --------------------- VarRec
 --  Γ ⊢ x ↓ A ⊣ Γ       Γ ⊢ x ↓ ά ⊣ Γ,(x : ά)
 infer (EVar x) = do
-    a <- fromMaybeM extend $ liftA2 (<|>) (lookupEnv x) (lookupSig x)
+    a <- ifM (gets $ (x==) . currentBind) varRec var
     apply (T.EVar (coerce x), a)
   where
-    extend = do
+    var = maybeToRightM "Can't infer" =<<
+          liftA2 (<|>) (lookupEnv x) (lookupSig x)
+    varRec = do
         alpha <- TEVar <$> fresh
         insertEnv (EnvVar x alpha)
         pure alpha