fixed bug in Term.dependencies function and some cleanup of front-end

editor/src/Unison/Editor.elm

@@ -19,7 +19,6 @@ import Keyboard
 import Result
 import Signal
 import Unison.Action as Action
-import Unison.Explorer as Explorer
 import Unison.EditableTerm as EditableTerm
 import Unison.SearchboxParser as SearchboxParser
 import Unison.Hash (Hash)

editor/src/Unison/Explorer.elm

@@ -1,101 +0,0 @@
-module Unison.Explorer where
-
-import Debug
-import Elmz.Layout (Layout,Pt,Region,Containment(Inside,Outside))
-import Elmz.Layout as Layout
-import Elmz.Maybe
-import Elmz.Movement as Movement
-import Elmz.Selection1D
-import Elmz.Signal as Signals
-import Graphics.Element (Element)
-import Graphics.Element as E
-import Graphics.Input as Input
-import Graphics.Input.Field as Field
-import Keyboard
-import List
-import List ((::))
-import Maybe
-import Mouse
-import Result
-import Set
-import Signal
-import String
-import Time
-import Unison.Styles as Styles
-import Window
-
-type alias Model = Maybe
-  { isKeyboardOpen : Bool
-  , prompt : String
-  , input : Field.Content
-  , above : Element
-  , completions : List Element
-  , below : Element }
-
-type alias Action = Model -> Model
-
-zero : Model
-zero = Just
-  { isKeyboardOpen = False
-  , prompt = ""
-  , input = Field.noContent
-  , above = E.empty -- todo: fill with sweet animated GIF
-  , completions = []
-  , below = E.empty }
-
-setPrompt : String -> Action
-setPrompt s = Maybe.map (\m -> { m | prompt <- s })
-
-getInputOr : Field.Content -> Model -> Field.Content
-getInputOr default model = case model of
-  Nothing -> default
-  Just model -> model.input
-
-setInput : Field.Content -> Action
-setInput content = Maybe.map (\m -> { m | input <- content })
-
-openKeyboard : Action
-openKeyboard = Maybe.map (\m -> { m | isKeyboardOpen <- True })
-
-setAbove : Element -> Action
-setAbove e = Maybe.map (\m -> { m | above <- e })
-
-setCompletions : List Element -> Action
-setCompletions e = Maybe.map (\m -> { m | completions <- e })
-
-setBelow : Element -> Action
-setBelow e = Maybe.map (\m -> { m | below <- e })
-
-type alias Sink a = a -> Signal.Message
-
-view : Pt -> Sink Field.Content -> Model -> Layout (Result Containment Int)
-view origin searchbox model = case model of
-  Nothing -> Layout.empty (Result.Err Outside)
-  Just s ->
-    let ok = not (List.isEmpty s.completions)
-        statusColor = Styles.statusColor ok
-        fld = Field.field (Styles.autocomplete ok) searchbox s.prompt s.input
-        completions =
-          let fit e = E.width ((E.widthOf s.above - 12) `max`
-                               E.widthOf e `max`
-                               (E.widthOf s.below - 12))
-                              e
-          in List.indexedMap (\i e -> Layout.embed (Result.Ok i) (fit e)) s.completions
-        inside = Result.Err Inside
-        bottom = Styles.explorerOutline statusColor <|
-          Layout.vertical inside
-            [ Layout.embed inside s.above
-            , Styles.explorerCells inside completions
-            , Layout.embed inside s.below ]
-        box = Layout.vertical inside
-          [ Layout.embed inside (E.flow E.right [E.spacer 9 1, Styles.carotUp 6 statusColor])
-          , Layout.embed inside (E.width (Layout.widthOf bottom) fld)
-          , Layout.embed inside (E.spacer 1 6)
-          , bottom ]
-        boxTopLeft = origin
-        h = boxTopLeft.y + Layout.heightOf box + 50
-    in Layout.container (Result.Err Outside)
-                        (boxTopLeft.x + Layout.widthOf box)
-                        h
-                        boxTopLeft
-                        box

editor/src/Unison/Symbol.elm

@@ -12,7 +12,8 @@ type alias Symbol = { freshId : Int, name : String, fixity : Fixity, precedence
 type alias Key = String
 
 toKey : Symbol -> Key
-toKey = toString
+toKey s = if s.freshId == 0 then s.name
+          else s.name ++ toString s.freshId
 
 anonymous : Symbol
 anonymous = Symbol 0 "anonymous" Prefix 9

editor/src/Unison/Type.elm

@@ -47,8 +47,8 @@ key env cur =
       Lit lit -> case lit of
         Ref r -> Metadata.firstName (Reference.toKey r) (env.metadata r)
         _ -> toString lit
-      Universal v -> "t"++toString v
-      Existential v -> "t"++toString v++"'"
+      Universal v -> Symbol.toKey v
+      Existential v -> "'" ++ Symbol.toKey v
       Arrow i o -> paren 0 prec (go False (prec+1) i ++ " → " ++ go top prec o)
       App x y -> paren 9 prec (go top 9 x ++ " " ++ go top 10 y)
       Forall v body ->

node/src/Main.hs

@@ -1,42 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Main where
 
-import Control.Monad
+import Unison.Note
 import Unison.Term as E
 import Unison.Type as T
 import Unison.Typechecker as Typechecker
-import Unison.Note as N
-import Unison.Var as V
+import Unison.Reference as R
 
-identity :: E.Term
-identity = E.unscope (E.lam E.var)
+builtin s = E.ref (R.Builtin s)
 
-constant :: E.Term
-constant = E.unscope (E.lam (E.lam (E.weaken E.var)))
+expr = lam' ["a"] $ var' "a"
+expr2 = builtin "Color.rgba"
 
-apply :: E.Term
-apply = E.unscope (E.lam (E.lam (E.weaken E.var `E.app` E.var)))
-
--- type Any = forall r . (forall a . a -> r) -> r
-anyT :: Type
-anyT = forall1 $ \r -> (forall1 $ \a -> a `T.Arrow` r) `T.Arrow` r
-
--- (x4 x3 → (x2 x1 → x2) x1 (x4 x1 : Number))
-expr :: E.Term
-expr = identityAnn
-
-identityAnn = E.Ann identity (forall1 $ \x -> T.Arrow x x)
-
-showType :: Either N.Note T.Type -> String
+showType :: Either Note T.Type -> String
 showType (Left err) = show err
 showType (Right a) = show a
 
-idType :: Type
-idType = forall1 $ \x -> x
-
-substIdType :: Type -> Type
-substIdType (Forall v t) = subst t v (T.Universal (V.decr V.bound1))
-
 main :: IO ()
--- main = putStrLn . show $ (idType, substIdType idType)
--- main = putStrLn . showCtx . snd $ extendUniversal C.empty
-main = putStrLn . showType $ Typechecker.synthesize' expr
+-- main = putStrLn . showType $ Typechecker.synthesize' expr
+main = putStrLn . show $ dependencies' expr2

node/src/Unison/ABT.hs

@@ -141,13 +141,14 @@ visit f t = case f t of
     Abs x e -> abs x <$> visit f e
     Tm body -> tm <$> traverse (visit f) body
 
--- | Apply an effectful function to an ABT tree bottom up, sequencing the results.
-fold :: (Traversable f, Applicative g) => (f (Term f) -> g (f (Term f))) -> Term f -> g (Term f)
-fold f t = case out t of
+-- | Apply an effectful function to an ABT tree top down, sequencing the results.
+visit' :: (Traversable f, Applicative g, Monad g)
+       => (f (Term f) -> g (f (Term f))) -> Term f -> g (Term f)
+visit' f t = case out t of
   Var _ -> pure t
-  Cycle body -> cycle <$> fold f body
-  Abs x e -> abs x <$> fold f e
-  Tm body -> tm <$> traverse (fold f) body
+  Cycle body -> cycle <$> visit' f body
+  Abs x e -> abs x <$> visit' f e
+  Tm body -> f body >>= \body -> tm <$> traverse (visit' f) body
 
 -- | A single step 'focusing' action, returns the subtree and a function
 -- to replace that subtree

node/src/Unison/Node/Implementation.hs

@@ -25,6 +25,17 @@ import qualified Unison.Hash as Hash
 import qualified Unison.Metadata as Metadata
 import qualified Unison.Node.Store as Store
 
+-- debugging stuff
+import Debug.Trace
+import qualified Data.Foldable as Foldable
+import Data.Foldable (Foldable)
+
+watch :: Show a => String -> a -> a
+watch msg a = trace (msg ++ ": " ++ show a) a
+
+watches :: (Foldable f, Show a) => String -> f a -> f a
+watches msg as = trace (msg ++ ":\n" ++ intercalate "\n" (map show (Foldable.toList as)) ++ "\n.") as
+
 node :: (Applicative f, Monad f) => Eval (Noted f) -> Store f -> Node f Reference.Reference Type Term
 node eval store =
   let

node/src/Unison/Term.hs

@@ -23,6 +23,7 @@ import Data.Text (Text)
 import Data.Traversable (Traversable)
 import Data.Vector (Vector, (!?))
 import GHC.Generics
+import Text.Show
 import Unison.Hash (Hash)
 import Unison.Reference (Reference)
 import qualified Control.Monad.Writer.Strict as Writer
@@ -43,7 +44,7 @@ data Literal
   = Number Double
   | Text Text
   | Distance Distance.Distance
-  deriving (Eq,Ord,Show,Generic)
+  deriving (Eq,Ord,Generic)
 
 -- | Base functor for terms in the Unison language
 data F a
@@ -58,7 +59,7 @@ data F a
   -- variables as there are bindings
   | LetRec [a] a
   | Let a a
-  deriving (Eq,Foldable,Functor,Generic1,Show,Traversable)
+  deriving (Eq,Foldable,Functor,Generic1,Traversable)
 
 -- | Terms are represented as ABTs over the base functor F.
 type Term = ABT.Term F
@@ -159,7 +160,7 @@ unLet t = fixup (go t) where
   fixup bst = Just bst
 
 dependencies' :: Term -> Set Reference
-dependencies' t = Set.fromList . Writer.execWriter $ ABT.fold f t
+dependencies' t = Set.fromList . Writer.execWriter $ ABT.visit' f t
   where f t@(Ref r) = Writer.tell [r] *> pure t
         f t = pure t
 
@@ -167,7 +168,7 @@ dependencies :: Term -> Set Hash
 dependencies e = Set.fromList [ h | Reference.Derived h <- Set.toList (dependencies' e) ]
 
 countBlanks :: Term -> Int
-countBlanks t = Monoid.getSum . Writer.execWriter $ ABT.fold f t
+countBlanks t = Monoid.getSum . Writer.execWriter $ ABT.visit' f t
   where f Blank = Writer.tell (Monoid.Sum 1) *> pure Blank
         f t = pure t
 
@@ -284,3 +285,22 @@ instance Digest.Digestable1 F where
     Let b a -> Put.putWord8 8 *> serialize (hash b) *> serialize (hash a)
 
 deriveJSON defaultOptions ''PathElement
+
+instance Show Literal where
+  show (Text t) = show t
+  show (Number n) = show n
+  show (Distance d) = show d
+
+instance Show a => Show (F a) where
+  showsPrec p fa = go p fa where
+    go _ (Lit l) = showsPrec 0 l
+    go p (Ann t k) =
+      showParen (p > 1) $ showsPrec 0 t <> s":" <> showsPrec 0 k
+    go p (App f x) =
+      showParen (p > 9) $ showsPrec 9 f <> s" " <> showsPrec 10 x
+    go p (Lam body) = showParen (p > 0) (showsPrec 0 body)
+    go p (Vector vs) = showListWith (showsPrec 0) (Vector.toList vs)
+    go p Blank = s"_"
+    go p (Ref r) = showsPrec 0 r
+    (<>) = (.)
+    s = showString

node/src/Unison/Type.hs

@@ -21,6 +21,7 @@ import Data.Traversable (Traversable)
 import GHC.Generics
 import Unison.Note (Noted)
 import qualified Data.Bytes.Put as Put
+import qualified Data.Set as Set
 import qualified Unison.ABT as ABT
 import qualified Unison.Digest as Digest
 import qualified Unison.JSON as J
@@ -126,6 +127,10 @@ forall' vs body = foldr forall body (map ABT.v' vs)
 constrain :: Type -> () -> Type
 constrain t u = ABT.tm (Constrain t u)
 
+-- | Bind all free variables with an outer `forall`.
+generalize :: Type -> Type
+generalize t = foldr forall t $ Set.toList (ABT.freeVars t)
+
 instance Digest.Digestable1 F where
   digest1 _ hash e = case e of
     Lit l -> Put.putWord8 0 *> serialize l

node/src/Unison/Typechecker.hs

@@ -42,7 +42,7 @@ admissibleTypeAt :: Applicative f
 admissibleTypeAt synth loc t =
   let
     f = Term.freshIn t (ABT.v' "s")
-    shake (Type.Arrow' (Type.Arrow' _ tsub) _) = tsub
+    shake (Type.Arrow' (Type.Arrow' _ tsub) _) = Type.generalize tsub
     shake (Type.Forall' _ t) = shake t
     shake _ = error "impossible, f had better be a function"
   in case Term.lam f <$> Term.modify (Term.app (Term.var f)) loc t of
@@ -55,7 +55,7 @@ typeAt synth [] t = Note.scoped ("typeOf: " ++ show t) $ synthesize synth t
 typeAt synth loc t = Note.scoped ("typeOf@"++show loc ++ " " ++ show t) $
   let
     f = Term.freshIn t (ABT.v' "t")
-    shake (Type.Arrow' (Type.Arrow' tsub _) _) = tsub
+    shake (Type.Arrow' (Type.Arrow' tsub _) _) = Type.generalize tsub
     shake (Type.Forall' _ t) = shake t
     shake _ = error "impossible, f had better be a function"
   in case Term.lam f <$> Term.modify (Term.app (Term.var f)) loc t of