mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-25 09:17:27 +03:00
node compiling with ABT representation
This commit is contained in:
Paul Chiusano
parent
d3baeaf46c
commit
24e3a2cb71
340
node/src/Node.hs
340
node/src/Node.hs
@ -1,5 +1,5 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
module Main where
|
||||
|
||||
@ -28,168 +28,186 @@ import qualified Unison.Reference as R
|
||||
import qualified Unison.Symbol as Symbol
|
||||
import qualified Unison.Term as Term
|
||||
import qualified Unison.Type as Type
|
||||
import qualified Unison.Var as Var
|
||||
|
||||
numeric2 :: Term -> (Double -> Double -> Double) -> I.Primop (N.Noted IO)
|
||||
numeric2 sym f = I.Primop 2 $ \xs -> case xs of
|
||||
[x,y] -> do
|
||||
xr <- whnf x
|
||||
yr <- whnf y
|
||||
pure $ case (xr, yr) of
|
||||
(Term.Lit (Term.Number x), Term.Lit (Term.Number y)) -> Term.Lit (Term.Number (f x y))
|
||||
(x,y) -> sym `Term.App` x `Term.App` y
|
||||
_ -> error "unpossible"
|
||||
infixr 7 -->
|
||||
(-->) :: Type -> Type -> Type
|
||||
(-->) = Type.arrow
|
||||
|
||||
string2 :: Term -> (Text -> Text -> Text) -> I.Primop (N.Noted IO)
|
||||
string2 sym f = I.Primop 2 $ \xs -> case xs of
|
||||
[x,y] -> do
|
||||
xr <- whnf x
|
||||
yr <- whnf y
|
||||
pure $ case (xr, yr) of
|
||||
(Term.Lit (Term.Text x), Term.Lit (Term.Text y)) -> Term.Lit (Term.Text (f x y))
|
||||
(x,y) -> sym `Term.App` x `Term.App` y
|
||||
_ -> error "unpossible"
|
||||
makeNode :: Store IO -> IO (Node IO R.Reference Type Term)
|
||||
makeNode store =
|
||||
let
|
||||
builtins =
|
||||
[ let r = R.Builtin "()"
|
||||
in (r, Nothing, unitT, prefix "()")
|
||||
|
||||
builtins :: [(R.Reference, Maybe (I.Primop (N.Noted IO)), Type, Metadata R.Reference)]
|
||||
builtins =
|
||||
[ let r = R.Builtin "()"
|
||||
in (r, Nothing, unitT, prefix "()")
|
||||
, let r = R.Builtin "Color.rgba"
|
||||
in (r, strict r 4, num --> num --> num --> num --> colorT, prefix "rgba")
|
||||
|
||||
, let r = R.Builtin "Color.rgba"
|
||||
in (r, strict r 4, num `arr` (num `arr` (num `arr` (num `arr` colorT))), prefix "rgba")
|
||||
, let r = R.Builtin "Fixity.Prefix"
|
||||
in (r, Nothing, fixityT, prefix "Prefix")
|
||||
, let r = R.Builtin "Fixity.InfixL"
|
||||
in (r, Nothing, fixityT, prefix "InfixL")
|
||||
, let r = R.Builtin "Fixity.InfixR"
|
||||
in (r, Nothing, fixityT, prefix "InfixR")
|
||||
|
||||
, let r = R.Builtin "Fixity.Prefix"
|
||||
in (r, Nothing, fixityT, prefix "Prefix")
|
||||
, let r = R.Builtin "Fixity.InfixL"
|
||||
in (r, Nothing, fixityT, prefix "InfixL")
|
||||
, let r = R.Builtin "Fixity.InfixR"
|
||||
in (r, Nothing, fixityT, prefix "InfixR")
|
||||
, let r = R.Builtin "Metadata.metadata"
|
||||
in (r, strict r 2, vec symbolT --> str --> metadataT, prefix "metadata")
|
||||
|
||||
, let r = R.Builtin "Metadata.metadata"
|
||||
in (r, strict r 2, vec symbolT `arr` (str `arr` metadataT), prefix "metadata")
|
||||
, let r = R.Builtin "Number.plus"
|
||||
in (r, Just (numeric2 (Term.ref r) (+)), numOpTyp, opl 4 "+")
|
||||
, let r = R.Builtin "Number.minus"
|
||||
in (r, Just (numeric2 (Term.ref r) (-)), numOpTyp, opl 4 "-")
|
||||
, let r = R.Builtin "Number.times"
|
||||
in (r, Just (numeric2 (Term.ref r) (*)), numOpTyp, opl 5 "*")
|
||||
, let r = R.Builtin "Number.divide"
|
||||
in (r, Just (numeric2 (Term.ref r) (/)), numOpTyp, opl 5 "/")
|
||||
|
||||
, let r = R.Builtin "Number.plus"
|
||||
in (r, Just (numeric2 (Term.Ref r) (+)), numOpTyp, opl 4 "+")
|
||||
, let r = R.Builtin "Number.minus"
|
||||
in (r, Just (numeric2 (Term.Ref r) (-)), numOpTyp, opl 4 "-")
|
||||
, let r = R.Builtin "Number.times"
|
||||
in (r, Just (numeric2 (Term.Ref r) (*)), numOpTyp, opl 5 "*")
|
||||
, let r = R.Builtin "Number.divide"
|
||||
in (r, Just (numeric2 (Term.Ref r) (/)), numOpTyp, opl 5 "/")
|
||||
, let r = R.Builtin "Symbol.Symbol"
|
||||
in (r, Nothing, str --> fixityT --> num --> symbolT, prefix "Symbol")
|
||||
|
||||
, let r = R.Builtin "Symbol.Symbol"
|
||||
in (r, Nothing, str `arr` (fixityT `arr` (num `arr` symbolT)), prefix "Symbol")
|
||||
, let r = R.Builtin "Text.concatenate"
|
||||
in (r, Just (string2 (Term.ref r) mappend), strOpTyp, prefixes ["concatenate", "Text"])
|
||||
, let r = R.Builtin "Text.left"
|
||||
in (r, Nothing, alignmentT, prefixes ["left", "Text"])
|
||||
, let r = R.Builtin "Text.right"
|
||||
in (r, Nothing, alignmentT, prefixes ["right", "Text"])
|
||||
, let r = R.Builtin "Text.center"
|
||||
in (r, Nothing, alignmentT, prefixes ["center", "Text"])
|
||||
, let r = R.Builtin "Text.justify"
|
||||
in (r, Nothing, alignmentT, prefixes ["justify", "Text"])
|
||||
|
||||
, let r = R.Builtin "Text.concatenate"
|
||||
in (r, Just (string2 (Term.Ref r) mappend), strOpTyp, prefixes ["concatenate", "Text"])
|
||||
, let r = R.Builtin "Text.left"
|
||||
in (r, Nothing, alignmentT, prefixes ["left", "Text"])
|
||||
, let r = R.Builtin "Text.right"
|
||||
in (r, Nothing, alignmentT, prefixes ["right", "Text"])
|
||||
, let r = R.Builtin "Text.center"
|
||||
in (r, Nothing, alignmentT, prefixes ["center", "Text"])
|
||||
, let r = R.Builtin "Text.justify"
|
||||
in (r, Nothing, alignmentT, prefixes ["justify", "Text"])
|
||||
, let r = R.Builtin "Vector.append"
|
||||
op [last,init] = do
|
||||
initr <- whnf init
|
||||
pure $ case initr of
|
||||
Term.Vector' init -> Term.vector' (Vector.snoc init last)
|
||||
init -> Term.ref r `Term.app` last `Term.app` init
|
||||
op _ = fail "Vector.append unpossible"
|
||||
in (r, Just (I.Primop 2 op), Type.forall' ["a"] $ v' "a" --> vec (v' "a") --> vec (v' "a"), prefix "append")
|
||||
, let r = R.Builtin "Vector.concatenate"
|
||||
op [a,b] = do
|
||||
ar <- whnf a
|
||||
br <- whnf b
|
||||
pure $ case (ar,br) of
|
||||
(Term.Vector' a, Term.Vector' b) -> Term.vector' (a `mappend` b)
|
||||
(a,b) -> Term.ref r `Term.app` a `Term.app` b
|
||||
op _ = fail "Vector.concatenate unpossible"
|
||||
in (r, Just (I.Primop 2 op), Type.forall' ["a"] $ vec (v' "a") --> vec (v' "a") --> vec (v' "a"), prefix "concatenate")
|
||||
, let r = R.Builtin "Vector.empty"
|
||||
op [] = pure $ Term.vector mempty
|
||||
op _ = fail "Vector.empty unpossible"
|
||||
in (r, Just (I.Primop 0 op), Type.forall' ["a"] (vec (v' "a")), prefix "empty")
|
||||
, let r = R.Builtin "Vector.map"
|
||||
op [f,vec] = do
|
||||
vecr <- whnf vec
|
||||
pure $ case vecr of
|
||||
Term.Vector' vs -> Term.vector' (fmap (Term.app f) vs)
|
||||
_ -> Term.ref r `Term.app` vecr
|
||||
op _ = fail "Vector.map unpossible"
|
||||
in (r, Just (I.Primop 2 op), Type.forall' ["a","b"] $ (v' "a" --> v' "b") --> vec (v' "a") --> vec (v' "b"), prefix "map")
|
||||
, let r = R.Builtin "Vector.prepend"
|
||||
op [hd,tl] = do
|
||||
tlr <- whnf tl
|
||||
pure $ case tlr of
|
||||
Term.Vector' tl -> Term.vector' (Vector.cons hd tl)
|
||||
tl -> Term.ref r `Term.app` hd `Term.app` tl
|
||||
op _ = fail "Vector.prepend unpossible"
|
||||
in (r, Just (I.Primop 2 op), Type.forall' ["a"] $ v' "a" --> vec (v' "a") --> vec (v' "a"), prefix "prepend")
|
||||
, let r = R.Builtin "Vector.single"
|
||||
op [hd] = pure $ Term.vector (pure hd)
|
||||
op _ = fail "Vector.single unpossible"
|
||||
in (r, Just (I.Primop 1 op), Type.forall' ["a"] $ v' "a" --> vec (v' "a"), prefix "single")
|
||||
|
||||
, let r = R.Builtin "Vector.append"
|
||||
op [last,init] = do
|
||||
initr <- whnf init
|
||||
pure $ case initr of
|
||||
Term.Vector init -> Term.Vector (Vector.snoc init last)
|
||||
init -> Term.Ref r `Term.App` last `Term.App` init
|
||||
op _ = fail "Vector.append unpossible"
|
||||
in (r, Just (I.Primop 2 op), Type.forall1 $ \a -> a `arr` (vec a `arr` vec a), prefix "append")
|
||||
, let r = R.Builtin "Vector.concatenate"
|
||||
op [a,b] = do
|
||||
ar <- whnf a
|
||||
br <- whnf b
|
||||
pure $ case (ar,br) of
|
||||
(Term.Vector a, Term.Vector b) -> Term.Vector (a `mappend` b)
|
||||
(a,b) -> Term.Ref r `Term.App` a `Term.App` b
|
||||
op _ = fail "Vector.concatenate unpossible"
|
||||
in (r, Just (I.Primop 2 op), Type.forall1 $ \a -> vec a `arr` (vec a `arr` vec a), prefix "concatenate")
|
||||
, let r = R.Builtin "Vector.empty"
|
||||
op [] = pure $ Term.Vector mempty
|
||||
op _ = fail "Vector.empty unpossible"
|
||||
in (r, Just (I.Primop 0 op), Type.forall1 vec, prefix "empty")
|
||||
, let r = R.Builtin "Vector.map"
|
||||
op [f,vec] = do
|
||||
vecr <- whnf vec
|
||||
pure $ case vecr of
|
||||
Term.Vector vs -> Term.Vector (fmap (Term.App f) vs)
|
||||
_ -> Term.Ref r `Term.App` vecr
|
||||
op _ = fail "Vector.map unpossible"
|
||||
in (r, Just (I.Primop 2 op), Type.forall2 $ \a b -> (a `arr` b) `arr` (vec a `arr` vec b), prefix "map")
|
||||
, let r = R.Builtin "Vector.prepend"
|
||||
op [hd,tl] = do
|
||||
tlr <- whnf tl
|
||||
pure $ case tlr of
|
||||
Term.Vector tl -> Term.Vector (Vector.cons hd tl)
|
||||
tl -> Term.Ref r `Term.App` hd `Term.App` tl
|
||||
op _ = fail "Vector.prepend unpossible"
|
||||
in (r, Just (I.Primop 2 op), Type.forall1 $ \a -> a `arr` (vec a `arr` vec a), prefix "prepend")
|
||||
, let r = R.Builtin "Vector.single"
|
||||
op [hd] = pure $ Term.Vector (pure hd)
|
||||
op _ = fail "Vector.single unpossible"
|
||||
in (r, Just (I.Primop 1 op), Type.forall1 $ \a -> a `arr` vec a, prefix "single")
|
||||
, let r = R.Builtin "View.cell"
|
||||
in (r, strict r 2, Type.forall' ["a"] $ view (v' "a") --> v' "a" --> cellT, prefix "cell")
|
||||
, let r = R.Builtin "View.color"
|
||||
in (r, Nothing, colorT --> view cellT, prefix "color")
|
||||
, let r = R.Builtin "View.declare"
|
||||
in (r, strict r 1, Type.forall' ["a"] $ str --> v' "a" --> cellT, prefix "declare")
|
||||
, let r = R.Builtin "View.embed"
|
||||
in (r, Nothing, view cellT, prefix "embed")
|
||||
, let r = R.Builtin "View.fit-width"
|
||||
in (r, strict r 1, Type.forall' ["a"] $ distanceT --> view (v' "a"), prefix "fit-width")
|
||||
, let r = R.Builtin "View.function1"
|
||||
in ( r
|
||||
, Nothing
|
||||
, Type.forall' ["a","b"] $ (cellT --> cellT) --> view (v' "a" --> v' "b")
|
||||
, prefix "function1" )
|
||||
, let r = R.Builtin "View.hide"
|
||||
in (r, Nothing, Type.forall' ["a"] $ view (v' "a"), prefix "hide")
|
||||
, let r = R.Builtin "View.horizontal"
|
||||
in (r, Nothing, view (vec cellT), prefix "horizontal")
|
||||
, let r = R.Builtin "View.reactive"
|
||||
in (r, Nothing, Type.forall' ["a"] $ view (v' "a"), prefix "reactive")
|
||||
, let r = R.Builtin "View.source"
|
||||
in (r, Nothing, Type.forall' ["a"] $ view (v' "a"), prefix "source")
|
||||
, let r = R.Builtin "View.spacer"
|
||||
in (r, strict r 1, distanceT --> num --> view unitT, prefix "spacer")
|
||||
, let r = R.Builtin "View.swatch"
|
||||
in (r, Nothing, view colorT, prefix "swatch")
|
||||
, let r = R.Builtin "View.text"
|
||||
in (r, strict r 1, styleT --> view str, prefix "text")
|
||||
, let r = R.Builtin "View.textbox"
|
||||
in (r, strict r 2, alignmentT `arr` (distanceT `arr` (styleT `arr` view str)), prefix "textbox")
|
||||
, let r = R.Builtin "View.vertical"
|
||||
in (r, Nothing, view (vec cellT), prefix "vertical")
|
||||
, let r = R.Builtin "View.view"
|
||||
in (r, strict r 1, Type.forall' ["a"] $ view (v' "a") --> v' "a" --> v' "a", prefix "view")
|
||||
]
|
||||
|
||||
, let r = R.Builtin "View.cell"
|
||||
in (r, strict r 2, Type.forall1 $ \a -> view a `arr` (a `arr` cellT), prefix "cell")
|
||||
, let r = R.Builtin "View.color"
|
||||
in (r, Nothing, colorT `arr` view cellT, prefix "color")
|
||||
, let r = R.Builtin "View.declare"
|
||||
in (r, strict r 1, Type.forall1 $ \a -> str `arr` (a `arr` cellT), prefix "declare")
|
||||
, let r = R.Builtin "View.embed"
|
||||
in (r, Nothing, view cellT, prefix "embed")
|
||||
, let r = R.Builtin "View.fit-width"
|
||||
in (r, strict r 1, Type.forall1 $ \a -> distanceT `arr` view a, prefix "fit-width")
|
||||
, let r = R.Builtin "View.function1"
|
||||
in ( r
|
||||
, Nothing
|
||||
, Type.forall2 $ \a b -> (cellT `arr` cellT) `arr` view (a `arr` b)
|
||||
, prefix "function1" )
|
||||
, let r = R.Builtin "View.hide"
|
||||
in (r, Nothing, Type.forall1 view, prefix "hide")
|
||||
, let r = R.Builtin "View.horizontal"
|
||||
in (r, Nothing, view (vec cellT), prefix "horizontal")
|
||||
, let r = R.Builtin "View.reactive"
|
||||
in (r, Nothing, Type.forall1 view, prefix "reactive")
|
||||
, let r = R.Builtin "View.source"
|
||||
in (r, Nothing, Type.forall1 view, prefix "source")
|
||||
, let r = R.Builtin "View.spacer"
|
||||
in (r, strict r 1, distanceT `arr` (num `arr` view unitT), prefix "spacer")
|
||||
, let r = R.Builtin "View.swatch"
|
||||
in (r, Nothing, view colorT, prefix "swatch")
|
||||
, let r = R.Builtin "View.text"
|
||||
in (r, strict r 1, styleT `arr` view str, prefix "text")
|
||||
, let r = R.Builtin "View.textbox"
|
||||
in (r, strict r 2, alignmentT `arr` (distanceT `arr` (styleT `arr` view str)), prefix "textbox")
|
||||
, let r = R.Builtin "View.vertical"
|
||||
in (r, Nothing, view (vec cellT), prefix "vertical")
|
||||
, let r = R.Builtin "View.view"
|
||||
in (r, strict r 1, Type.forall1 $ \a -> view a `arr` (a `arr` a), prefix "view")
|
||||
]
|
||||
where
|
||||
fixityT = Type.Unit (Type.Ref (R.Builtin "Fixity"))
|
||||
symbolT = Type.Unit (Type.Ref (R.Builtin "Symbol"))
|
||||
alignmentT = Type.Unit (Type.Ref (R.Builtin "Alignment"))
|
||||
metadataT = Type.Unit (Type.Ref (R.Builtin "Metadata"))
|
||||
arr = Type.Arrow
|
||||
cellT = Type.Unit (Type.Ref (R.Builtin "Cell"))
|
||||
colorT = Type.Unit (Type.Ref (R.Builtin "Color"))
|
||||
distanceT = Type.Unit Type.Distance
|
||||
num = Type.Unit Type.Number
|
||||
numOpTyp = num `arr` (num `arr` num)
|
||||
styleT = Type.Unit (Type.Ref (R.Builtin "Text.Style"))
|
||||
str = Type.Unit Type.Text
|
||||
eval :: Eval (N.Noted IO)
|
||||
eval = I.eval (M.fromList [ (k,v) | (k,Just v,_,_) <- builtins ])
|
||||
|
||||
readTerm :: Hash -> N.Noted IO Term
|
||||
readTerm h = Store.readTerm store h
|
||||
|
||||
whnf :: Term -> N.Noted IO Term
|
||||
whnf = Eval.whnf eval readTerm
|
||||
|
||||
node :: Node IO R.Reference Type Term
|
||||
node = C.node eval store
|
||||
|
||||
v' = Type.v'
|
||||
fixityT = Type.ref (R.Builtin "Fixity")
|
||||
symbolT = Type.ref (R.Builtin "Symbol")
|
||||
alignmentT = Type.ref (R.Builtin "Alignment")
|
||||
metadataT = Type.ref (R.Builtin "Metadata")
|
||||
arr = Type.arrow
|
||||
cellT = Type.ref (R.Builtin "Cell")
|
||||
colorT = Type.ref (R.Builtin "Color")
|
||||
distanceT = Type.lit Type.Distance
|
||||
num = Type.lit Type.Number
|
||||
numOpTyp = num --> num --> num
|
||||
styleT = Type.ref (R.Builtin "Text.Style")
|
||||
str = Type.lit Type.Text
|
||||
strOpTyp = str `arr` (str `arr` str)
|
||||
unitT = Type.Unit (Type.Ref (R.Builtin "Unit"))
|
||||
vec a = Type.App (Type.Unit Type.Vector) a
|
||||
view a = Type.App (Type.Unit (Type.Ref (R.Builtin "View"))) a
|
||||
unitT = Type.ref (R.Builtin "Unit")
|
||||
vec a = Type.app (Type.lit Type.Vector) a
|
||||
view a = Type.app (Type.ref (R.Builtin "View")) a
|
||||
strict r n = Just (I.Primop n f)
|
||||
where f args = reapply <$> traverse whnf (take n args)
|
||||
where reapply args' = Term.Ref r `apps` args' `apps` drop n args
|
||||
apps f args = foldl Term.App f args
|
||||
where reapply args' = Term.ref r `apps` args' `apps` drop n args
|
||||
apps f args = foldl Term.app f args
|
||||
|
||||
numeric2 :: Term -> (Double -> Double -> Double) -> I.Primop (N.Noted IO)
|
||||
numeric2 sym f = I.Primop 2 $ \xs -> case xs of
|
||||
[x,y] -> g <$> whnf x <*> whnf y
|
||||
where g (Term.Number' x) (Term.Number' y) = Term.lit (Term.Number (f x y))
|
||||
g x y = sym `Term.app` x `Term.app` y
|
||||
_ -> error "unpossible"
|
||||
|
||||
string2 :: Term -> (Text -> Text -> Text) -> I.Primop (N.Noted IO)
|
||||
string2 sym f = I.Primop 2 $ \xs -> case xs of
|
||||
[x,y] -> g <$> whnf x <*> whnf y
|
||||
where g (Term.Text' x) (Term.Text' y) = Term.lit (Term.Text (f x y))
|
||||
g x y = sym `Term.app` x `Term.app` y
|
||||
_ -> error "unpossible"
|
||||
|
||||
in N.run $ do
|
||||
_ <- Node.createTerm node (Term.lam' ["a"] (Term.var' "a")) (prefix "identity")
|
||||
mapM_ (\(r,_,t,md) -> Node.updateMetadata node r md *> Store.annotateTerm store r t)
|
||||
builtins
|
||||
pure node
|
||||
|
||||
opl :: Int -> Text -> Metadata k
|
||||
opl n s = Metadata Metadata.Term
|
||||
@ -206,28 +224,8 @@ prefixes s = Metadata Metadata.Term
|
||||
[]
|
||||
Nothing
|
||||
|
||||
builtinMetadatas :: Node IO R.Reference Type Term -> N.Noted IO ()
|
||||
builtinMetadatas node = do
|
||||
_ <- Node.createTerm node (Term.Lam (Term.Var Var.bound1)) (prefix "identity")
|
||||
mapM_ (\(r,_,t,md) -> Node.updateMetadata node r md *> Store.annotateTerm store r t)
|
||||
builtins
|
||||
|
||||
store :: Store IO
|
||||
store = Store.store "store"
|
||||
|
||||
eval :: Eval (N.Noted IO)
|
||||
eval = I.eval (M.fromList [ (k,v) | (k,Just v,_,_) <- builtins ])
|
||||
|
||||
readTerm :: Hash -> N.Noted IO Term
|
||||
readTerm h = Store.readTerm store h
|
||||
|
||||
whnf :: Term -> N.Noted IO Term
|
||||
whnf = Eval.whnf eval readTerm
|
||||
|
||||
node :: Node IO R.Reference Type Term
|
||||
node = C.node eval store
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
N.run (builtinMetadatas node)
|
||||
store <- Store.store "store"
|
||||
node <- makeNode store
|
||||
S.server 8080 node
|
||||
|
||||
@ -67,6 +67,8 @@ type Term = ABT.Term F
|
||||
|
||||
pattern Var' v <- ABT.Var' v
|
||||
pattern Lit' l <- (ABT.out -> ABT.Tm (Lit l))
|
||||
pattern Number' n <- Lit' (Number n)
|
||||
pattern Text' s <- Lit' (Text s)
|
||||
pattern Blank' <- (ABT.out -> ABT.Tm Blank)
|
||||
pattern Ref' r <- (ABT.out -> ABT.Tm (Ref r))
|
||||
pattern App' f x <- (ABT.out -> ABT.Tm (App f x))
|
||||
@ -85,6 +87,9 @@ freshIn = ABT.freshIn
|
||||
var :: ABT.V -> Term
|
||||
var = ABT.var
|
||||
|
||||
var' :: Text -> Term
|
||||
var' = var . ABT.v'
|
||||
|
||||
ref :: Reference -> Term
|
||||
ref r = ABT.tm (Ref r)
|
||||
|
||||
@ -109,6 +114,9 @@ vector' es = ABT.tm (Vector es)
|
||||
lam :: ABT.V -> Term -> Term
|
||||
lam v body = ABT.tm (Lam (ABT.abs v body))
|
||||
|
||||
lam' :: [Text] -> Term -> Term
|
||||
lam' vs body = foldr lam body (map ABT.v' vs)
|
||||
|
||||
-- | Smart constructor for let rec blocks. Each binding in the block may
|
||||
-- reference any other binding in the block in its body (including itself),
|
||||
-- and the output expression may also reference any binding in the block.
|
||||
|
||||
@ -16,6 +16,7 @@ import Data.Bytes.Serial
|
||||
import Data.Foldable (Foldable)
|
||||
import Data.Functor.Classes (Eq1(..),Show1(..))
|
||||
import Data.Set (Set)
|
||||
import Data.Text (Text)
|
||||
import Data.Traversable (Traversable)
|
||||
import GHC.Generics
|
||||
import Unison.Note (Noted)
|
||||
@ -95,6 +96,9 @@ matchUniversal _ _ = False
|
||||
lit :: Literal -> Type
|
||||
lit l = ABT.tm (Lit l)
|
||||
|
||||
ref :: R.Reference -> Type
|
||||
ref = lit . Ref
|
||||
|
||||
app :: Type -> Type -> Type
|
||||
app f arg = ABT.tm (App f arg)
|
||||
|
||||
@ -113,6 +117,12 @@ existential v = ABT.tm (Existential (ABT.var v))
|
||||
universal :: ABT.V -> Type
|
||||
universal v = ABT.tm (Universal (ABT.var v))
|
||||
|
||||
v' :: Text -> Type
|
||||
v' s = universal (ABT.v' s)
|
||||
|
||||
forall' :: [Text] -> Type -> Type
|
||||
forall' vs body = foldr forall body (map ABT.v' vs)
|
||||
|
||||
constrain :: Type -> () -> Type
|
||||
constrain t u = ABT.tm (Constrain t u)
|
||||
|
||||
|
||||
@ -1,38 +0,0 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Unison.Var where
|
||||
|
||||
import Control.Applicative
|
||||
import Data.Aeson
|
||||
|
||||
newtype Var = I Int deriving (Eq,Ord)
|
||||
|
||||
instance Show Var where
|
||||
show (I i) | i <= 0 = "t" ++ show (abs i)
|
||||
show (I i) | otherwise = "x" ++ show i
|
||||
|
||||
succ :: Var -> Var
|
||||
succ (I i) = I (i + 1)
|
||||
|
||||
decr :: Var -> Var
|
||||
decr (I i) = I (i - 1)
|
||||
|
||||
minv :: Var -> Var -> Var
|
||||
minv (I i) (I j) = I (min i j)
|
||||
|
||||
nest :: Var -> Var -> Var
|
||||
nest (I i) (I j) = I (i + j)
|
||||
|
||||
bound1 :: Var
|
||||
bound1 = I 1
|
||||
|
||||
instance FromJSON Var where
|
||||
parseJSON j = I <$> parseJSON j
|
||||
|
||||
instance ToJSON Var where
|
||||
toJSON (I i) = toJSON i
|
||||
@ -66,7 +66,6 @@ library
|
||||
Unison.Type
|
||||
Unison.Typechecker
|
||||
Unison.Typechecker.Context
|
||||
Unison.Var
|
||||
|
||||
build-depends:
|
||||
aeson >= 0.7.0.6,
|
||||
|
||||
Loading…
Reference in New Issue
Block a user