executed Hello, World almost exclusively

parser-typechecker/src/Unison/PrettyPrintEnv.hs

@@ -60,3 +60,9 @@ patternName env r cid =
   case terms env (Referent.Con r cid) of
     Just name -> name
     Nothing -> HQ.fromReferent (Referent.Con r cid)
+
+instance Monoid PrettyPrintEnv where
+  mempty = PrettyPrintEnv (const Nothing) (const Nothing)
+  mappend = unionLeft
+instance Semigroup PrettyPrintEnv where
+  (<>) = mappend

parser-typechecker/src/Unison/Reference.hs

@@ -59,7 +59,7 @@ data Id = Id H.Hash Pos Size deriving (Eq,Ord,Generic)
 
 instance Show Id where
   show = addDot . splitSuffix where
-    addDot (h, s) = show h <> maybe "" ("."<>) s
+    addDot (h, s) = (take 5 $ show h) <> maybe "" ("."<>) s
 
 showShort :: Int -> Reference -> String
 showShort numHashChars r =

parser-typechecker/src/Unison/Runtime/IR.hs

@@ -7,10 +7,10 @@
 {-# Language PartialTypeSignatures #-}
 {-# Language StrictData #-}
 {-# Language TupleSections #-}
+{-# Language ViewPatterns #-}
 
 module Unison.Runtime.IR where
 
-import Control.Applicative
 import Data.Foldable
 import Data.Functor (void)
 import Data.IORef
@@ -40,8 +40,14 @@ type ConstructorId = Int
 type Term v = AnnotatedTerm v ()
 
 data CompilationEnv e
-  = CompilationEnv { toIR :: R.Reference -> Maybe (IR e)
-                   , constructorArity :: R.Reference -> Int -> Maybe Int }
+  = CompilationEnv { toIR' :: Map R.Reference (IR e)
+                   , constructorArity' :: Map (R.Reference, Int) Int }
+
+toIR :: CompilationEnv e -> R.Reference -> Maybe (IR e)
+toIR = flip Map.lookup . toIR'
+
+constructorArity :: CompilationEnv e -> R.Reference -> Int -> Maybe Int
+constructorArity e r i = Map.lookup (r,i) $ constructorArity' e
 
 data SymbolC =
   SymbolC { isLazy :: Bool
@@ -188,6 +194,10 @@ compile0 env bound t =
   fvs = freeVars bound t
   go t = case t of
     Term.Nat' n -> Leaf . Val . N $ n
+    Term.Int' n -> Leaf . Val . I $ n
+    Term.Float' n -> Leaf . Val . F $ n
+    Term.Boolean' n -> Leaf . Val . B $ n
+    Term.Text' n -> Leaf . Val . T $ n
     Term.And' x y -> And (ind "and" t x) (go y)
     Term.LamsNamed' vs body -> Leaf . Val $
       Lam (length vs)
@@ -204,6 +214,7 @@ compile0 env bound t =
     Term.Ann' e _ -> go e
     Term.Match' scrutinee cases -> Match (ind "match" t scrutinee) (compileCase <$> cases)
     Term.Var' _ -> Leaf $ ind "var" t t
+    Term.Ref' (toIR env -> Just ir) -> ir
     _ -> error $ "TODO - don't know how to compile " ++ show t
     where
       compileVar _ v [] = unknown v
@@ -220,7 +231,8 @@ compile0 env bound t =
              -> R.Reference -> Int -> IR e
       ctorIR con src r cid = case constructorArity env r cid of
         Nothing -> error $ "the compilation env is missing info about how "
-                        ++ "to compile this constructor: " ++ show (r, cid)
+                        ++ "to compile this constructor: " ++ show (r, cid) ++ "\n" ++ show (constructorArity' env)
+        Just 0 -> con r cid []
         Just arity -> Leaf . Val $ Lam arity (FormClosure $ src r cid) ir
           where
           -- if `arity` is 1, then `Slot 0` is the sole argument.
@@ -395,7 +407,7 @@ instance Show e => Show (Value e) where
   show (N n) = show n
   show (B b) = show b
   show (T t) = show t
-  show (Lam n e ir) = "(Lam " <> show n <> " " <> show e <> " " <> show ir <> ")"
+  show (Lam n e ir) = "(Lam " <> show n <> " " <> show e <> " (" <> show ir <> "))"
   show (Data r cid vs) = "(Data " <> show r <> " " <> show cid <> " " <> show vs <> ")"
   show (Sequence vs) = "[" <> intercalateMap ", " show vs <> "]"
   show (Ref n s _) = "(Ref " <> show n <> " " <> show s <> ")"
@@ -406,12 +418,12 @@ instance Show e => Show (Value e) where
     "(LetRecBomb " <> show b <> " in " <> show (fst <$> bs)<> ")"
 
 compilationEnv0 :: CompilationEnv e
-compilationEnv0 = mempty { toIR = \r -> Map.lookup r builtins }
+compilationEnv0 = CompilationEnv builtins mempty
 
 instance Semigroup (CompilationEnv e) where (<>) = mappend
 
 instance Monoid (CompilationEnv e) where
-  mempty = CompilationEnv (const Nothing) (\_ _ -> Nothing)
+  mempty = CompilationEnv mempty mempty
   mappend c1 c2 = CompilationEnv ir ctor where
-    ir r = toIR c1 r <|> toIR c2 r
-    ctor r cid = constructorArity c1 r cid <|> constructorArity c2 r cid
+    ir = toIR' c1 <> toIR' c2
+    ctor = constructorArity' c1 <> constructorArity' c2

parser-typechecker/src/Unison/Runtime/Rt1.hs

@@ -32,6 +32,9 @@ import Unison.Runtime.IR (pattern CompilationEnv, pattern Req)
 import Unison.Runtime.IR hiding (CompilationEnv, IR, Req, Value, Z)
 import qualified Unison.Runtime.IR as IR
 import Unison.Symbol (Symbol)
+import Unison.TermPrinter (prettyTop)
+import qualified Unison.Util.Pretty as Pretty
+import Debug.Trace
 
 type CompilationEnv = IR.CompilationEnv ExternalFunction
 type IR = IR.IR ExternalFunction
@@ -51,6 +54,7 @@ runtime = Runtime terminate eval
   changeVar term = Term.vmap IR.underlyingSymbol term
   eval :: (MonadIO m, Monoid a) => CL.CodeLookup m Symbol a -> Term.AnnotatedTerm Symbol a -> m (Term Symbol)
   eval cl term = do
+    liftIO . putStrLn $ Pretty.render 80 (prettyTop mempty term)
     cenv <- compilationEnv cl term -- in `m`
     RDone result <- liftIO $
       run cenv (compile cenv $ Term.amap (const ()) term)
@@ -126,6 +130,11 @@ pushMany size values m = do
   length <- foldM pushArg 0 values
   pure ((size + length), m)
 
+
+  -- [s3,s2,s1,s0] [i1,i2,i3]
+  -- [s3,s2,s1,s0,  i1,i2,i3]
+  -- [s3,s2,s1,s0,  i3,i2,i1]
+
 pushManyZ :: Foldable f => Size -> f Z -> Stack -> IO (Size, Stack)
 pushManyZ size zs m = do
   m <- ensureSize (size + length zs) m
@@ -133,8 +142,8 @@ pushManyZ size zs m = do
         val <- at size z m -- variable lookup uses current size
         MV.write m size' val
         pure (size' + 1)
-  length <- foldM pushArg 0 zs
-  pure ((size + length), m)
+  size2 <- foldM pushArg size zs
+  pure (size2, m)
 
 ensureSize :: Size -> Stack -> IO Stack
 ensureSize size m =
@@ -169,20 +178,22 @@ compilationEnv :: Monad m
 compilationEnv env t = do
   let typeDeps = Term.referencedDataDeclarations t
               <> Term.referencedEffectDeclarations t
+  traceM "typeDeps"
+  traceShowM typeDeps
   arityMap <- fmap (Map.fromList . join) . for (toList typeDeps) $ \case
     r@(R.DerivedId id) -> do
       decl <- CL.getTypeDeclaration env id
       case decl of
-        Nothing -> pure []
+        Nothing -> error $ "no type declaration for " <> show id -- pure []
         Just (Left ad) -> pure $
           let arities = DD.constructorArities $ DD.toDataDecl ad
-          in [ ((r, i), arity) | (i, arity) <- arities `zip` [0..] ]
+          in [ ((r, i), arity) | (arity, i) <- arities `zip` [0..] ]
         Just (Right dd) -> pure $
           let arities = DD.constructorArities dd
-          in [ ((r, i), arity) | (i, arity) <- arities `zip` [0..] ]
+          in [ ((r, i), arity) | (arity, i) <- arities `zip` [0..] ]
     _ -> pure []
-  let cenv = CompilationEnv (const Nothing)
-                            (\r cid -> Map.lookup (r,cid) arityMap)
+  let cenv = CompilationEnv mempty arityMap
+
     -- deps = Term.dependencies t
   -- this would rely on haskell laziness for compilation, needs more thought
   --compiledTerms <- fmap (Map.fromList . join) . for (toList deps) $ \case
@@ -196,8 +207,7 @@ compilationEnv env t = do
 
 builtinCompilationEnv :: CompilationEnv
 builtinCompilationEnv =
-  CompilationEnv (flip Map.lookup (builtinsMap <> IR.builtins))
-                 (\_ _ -> Nothing)
+  CompilationEnv (builtinsMap <> IR.builtins) mempty
   where builtins :: [(Text, Int, Size -> Stack -> IO Value)]
         builtins = [
            ("Text.++", 2, \size stack -> do
@@ -232,7 +242,12 @@ run env ir = do
     fresh = atomicModifyIORef' supply (\n -> (n + 1, n))
 
     go :: Size -> Stack -> IR -> IO Result
-    go size m ir = case ir of
+    go size m ir = do
+     stackStuff <- traverse (MV.read m) [0..size-1]
+     traceM $ "stack: " <> show stackStuff
+     traceM $ "ir: " <> show ir
+     traceM ""
+     case ir of
       Leaf (Val v) -> done v
       Leaf slot -> done =<< at size slot m
       If c t f -> atb size c m >>= \case