convert let bindings to function applications for run time

letsToApp completed, but not wired in

working lambdaLift

fixing formatting

hlint

formatting

Author: sfultong

app/Repl.hs

@@ -28,11 +28,10 @@ import System.Exit (exitSuccess)
 import qualified System.IO.Strict as Strict
 import Telomare
 import Telomare.Eval (EvalError (..), compileUnitTestNoAbort)
-import Telomare.Parser (TelomareParser,
-                        parseAssignment,
-                        parseLongExpr, parsePrelude)
-import Telomare.Possible (evalPartial', deferB)
-import Telomare.PossibleData (CompiledExpr, setEnvB, pairB, zeroB)
+import Telomare.Parser (TelomareParser, parseAssignment, parseLongExpr,
+                        parsePrelude)
+import Telomare.Possible (deferB, evalPartial')
+import Telomare.PossibleData (CompiledExpr, pairB, setEnvB, zeroB)
 import Telomare.Resolver (process)
 import Telomare.RunTime (fastInterpretEval, simpleEval)
 import Telomare.TypeChecker (inferType)
@@ -119,7 +118,7 @@ printLastExpr eval bindings = do
         case compile' =<< process (DummyLoc :< LetUPF bindings' upt) of
           Left err -> putStrLn err
           Right iexpr' -> case eval iexpr' of
-              Left e -> putStrLn $ "error: " <> show e
+              Left e      -> putStrLn $ "error: " <> show e
               Right expr' -> print . PrettyIExpr $ expr'
   case res of
     Left err -> print err

src/Debug.hs

@@ -16,7 +16,7 @@ hPutStrLn file "test"
 -- hFlush file
 hClose file
 -}
-data DebugState = DebugState Int
+newtype DebugState = DebugState Int
 
 debugState :: IORef DebugState
 {-# NOINLINE debugState #-}

src/PrettyPrint.hs

@@ -6,15 +6,14 @@ module PrettyPrint where
 import Control.Monad.State (State)
 import Data.Map (Map)
 import Naturals (NExpr (..), NExprs (..), NResult)
-import Telomare (FragExpr (..), FragExprF (..), FragExprUR (..),
+import Telomare (DataType (..), FragExpr (..), FragExprF (..), FragExprUR (..),
                  FragExprURSansAnnotation (FragExprURSA, unFragExprURSA),
-                 FragIndex (..), IExpr (..), LocTag, PartialType (..),
-                 RecursionSimulationPieces (..), IExprF (..), DataType (..),
-                 Term3 (..), Term4 (..), forget, forgetAnnotationFragExprUR,
-                 indentWithOneChild', indentWithTwoChildren', rootFrag,
-                 Pattern (..), UnprocessedParsedTerm (..),
-                 UnprocessedParsedTermF (..), isNum, g2i
-                )
+                 FragIndex (..), IExpr (..), IExprF (..), LamType (..), LocTag,
+                 ParserTermF (..), PartialType (..), Pattern (..),
+                 RecursionSimulationPieces (..), Term1, Term3 (..), Term4 (..),
+                 UnprocessedParsedTerm (..), UnprocessedParsedTermF (..),
+                 forget, forgetAnnotationFragExprUR, g2i, indentWithChildren',
+                 indentWithOneChild', indentWithTwoChildren', isNum, rootFrag)
 
 import qualified Control.Comonad.Trans.Cofree as CofreeT (CofreeF (..))
 import qualified Control.Monad.State as State
@@ -180,6 +179,24 @@ instance PrettyPrintable Term4 where
       TraceFragF -> pure "T"
       AuxFragF _ -> error "prettyPrint term4 - should be no auxfrag here"
 
+instance {-# OVERLAPPING #-} PrettyPrintable Term1 where
+  showP = cata fa where
+    fa (_ CofreeT.:< x) = case x of
+      TZeroF                   -> pure "0"
+      TPairF a b               -> indentWithTwoChildren' "(" a b
+      TVarF v                  -> pure v
+      TAppF c i                -> indentWithTwoChildren' "($)" c i
+      TCheckF cf i             -> indentWithTwoChildren' ":" cf i
+      TITEF i t e              -> indentWithChildren' "ITE" [i,t,e]
+      TLeftF x                 -> indentWithOneChild' "L" x
+      TRightF x                -> indentWithOneChild' "R" x
+      TTraceF x                -> indentWithOneChild' "T" x
+      THashF x                 -> indentWithOneChild' "#" x
+      TChurchF n               -> pure $ "$" <> show n
+      TLamF (Open v) x         -> indentWithOneChild' ("\\" <> v) x
+      TLamF (Closed v) x       -> indentWithOneChild' ("[\\" <> v) x
+      TLimitedRecursionF t r b -> indentWithChildren' "TRB" [t,r,b]
+
 showTypeDebugInfo :: TypeDebugInfo -> String
 showTypeDebugInfo (TypeDebugInfo (Term3 m) lookup rootType) =
   let termMap = forgetAnnotationFragExprUR <$> m

src/Telomare.hs

@@ -30,16 +30,16 @@ import Data.Functor.Classes (Eq1 (..), Eq2 (..), Show1 (..), Show2 (..), eq1)
 import Data.Functor.Foldable (Base, Corecursive (embed),
                               Recursive (cata, project))
 import Data.Functor.Foldable.TH (MakeBaseFunctor (makeBaseFunctor))
+import Data.GenValidity (GenValid)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Ord.Deriving (deriveOrd1)
 import qualified Data.Set as Set
+import Data.Validity (Validity)
 import Data.Void (Void)
 import Debug.Trace (trace, traceShow, traceShowId)
 import GHC.Generics (Generic)
 import Text.Show.Deriving (deriveShow1)
-import Data.Validity (Validity)
-import Data.GenValidity (GenValid)
 
 {- top level TODO list
  - change AbortFrag form to something more convenient
@@ -126,12 +126,20 @@ data LamType l
   | Closed l
   deriving (Eq, Show, Ord)
 
+{-
+data FunRef v r
+  = NamedRef v
+  | ExplicitRef r
+  deriving (Eq, Show, Ord, Functor, Foldable, Traversable)
+-}
+
 -- | Parser AST
 data ParserTerm l v
   = TZero
   | TPair (ParserTerm l v) (ParserTerm l v)
   | TVar v
   | TApp (ParserTerm l v) (ParserTerm l v)
+--  | TPartApp (ParserTerm l v) (ParserTerm l v)
   | TCheck (ParserTerm l v) (ParserTerm l v)
   | TITE (ParserTerm l v) (ParserTerm l v) (ParserTerm l v)
   | TLeft (ParserTerm l v)
@@ -140,8 +148,11 @@ data ParserTerm l v
   | THash (ParserTerm l v)
   | TChurch Int
   | TLam (LamType l) (ParserTerm l v)
+  --  | TLam [ParserTerm l v] (ParserTerm l v)
+  --  | TLam l [FunRef v (ParserTerm l v)] (ParserTerm l v)
   | TLimitedRecursion (ParserTerm l v) (ParserTerm l v) (ParserTerm l v)
   deriving (Eq, Ord, Functor, Foldable, Traversable)
+--   deriving (Eq, Ord)
 makeBaseFunctor ''ParserTerm -- Functorial version ParserTermF
 deriving instance (Show l, Show v, Show a) => Show (ParserTermF l v a)
 deriving instance (Show l, Show v) => Show1 (ParserTermF l v)
@@ -152,6 +163,7 @@ instance Eq l => Eq2 (ParserTermF l) where
   liftEq2 eqv eqa (TPairF x1 y1) (TPairF x2 y2) = eqa x1 x2 && eqa y1 y2
   liftEq2 eqv eqa (TVarF v1) (TVarF v2) = eqv v1 v2
   liftEq2 eqv eqa (TAppF x1 y1) (TAppF x2 y2) = eqa x1 x2 && eqa y1 y2
+--  liftEq2 eqv eqa (TPartAppF x1 y1) (TPartAppF x2 y2) = eqa x1 x2 && eqa y1 y2
   liftEq2 eqv eqa (TCheckF x1 y1) (TCheckF x2 y2) = eqa x1 x2 && eqa y1 y2
   liftEq2 eqv eqa (TITEF c1 t1 e1) (TITEF c2 t2 e2) = eqa c1 c2 && eqa t1 t2 && eqa e1 e2
   liftEq2 eqv eqa (TLeftF x1) (TLeftF x2) = eqa x1 x2
@@ -160,6 +172,7 @@ instance Eq l => Eq2 (ParserTermF l) where
   liftEq2 eqv eqa (THashF x1) (THashF x2) = eqa x1 x2
   liftEq2 eqv eqa (TChurchF n1) (TChurchF n2) = n1 == n2
   liftEq2 eqv eqa (TLamF l1 x1) (TLamF l2 x2) = l1 == l2 && eqa x1 x2
+  -- liftEq2 eqv eqa (TLamF v1 x1) (TLamF v2 x2) = and (zipWith eqa v1 v2) && eqa x1 x2
   liftEq2 eqv eqa (TLimitedRecursionF a1 b1 c1) (TLimitedRecursionF a2 b2 c2) =
     eqa a1 a2 && eqa b1 b2 && eqa c1 c2
   liftEq2 _ _ _ _ = False