mirror of
https://github.com/github/semantic.git
synced 2024-12-25 16:02:43 +03:00
Use separate functor & recursive types.
This commit is contained in:
Rob Rix
parent
a6cd4debe6
commit
f0fae35ec9
@ -28,34 +28,34 @@ import Prelude hiding (fail)
|
||||
eval :: (Carrier sig m, Member Naming sig, Member (Reader Loc) sig, MonadFail m) => Analysis address value m -> (Core Name -> m value) -> Core Name -> m value
|
||||
eval Analysis{..} eval = \case
|
||||
Var n -> lookupEnv' n >>= deref' n
|
||||
Core (Let n) -> alloc n >>= bind n >> unit
|
||||
Core (a :>> b) -> eval a >> eval b
|
||||
Core (Lam b) -> do
|
||||
Let n -> alloc n >>= bind n >> unit
|
||||
a :>> b -> eval a >> eval b
|
||||
Lam b -> do
|
||||
n <- Gen <$> gensym "lam"
|
||||
abstract eval n (instantiate (pure n) b)
|
||||
Core (f :$ a) -> do
|
||||
f :$ a -> do
|
||||
f' <- eval f
|
||||
a' <- eval a
|
||||
apply eval f' a'
|
||||
Core Unit -> unit
|
||||
Core (Bool b) -> bool b
|
||||
Core (If c t e) -> do
|
||||
Unit -> unit
|
||||
Bool b -> bool b
|
||||
If c t e -> do
|
||||
c' <- eval c >>= asBool
|
||||
if c' then eval t else eval e
|
||||
Core (String s) -> string s
|
||||
Core (Load p) -> do
|
||||
String s -> string s
|
||||
Load p -> do
|
||||
path <- eval p >>= asString
|
||||
lookupEnv' (Path path) >>= deref' (Path path)
|
||||
Core (Edge e a) -> ref a >>= edge e >> unit
|
||||
Core Frame -> frame
|
||||
Core (a :. b) -> do
|
||||
Edge e a -> ref a >>= edge e >> unit
|
||||
Frame -> frame
|
||||
a :. b -> do
|
||||
a' <- ref a
|
||||
a' ... eval b
|
||||
Core (a := b) -> do
|
||||
a := b -> do
|
||||
b' <- eval b
|
||||
addr <- ref a
|
||||
b' <$ assign addr b'
|
||||
Core (Ann loc c) -> local (const loc) (eval c)
|
||||
Ann loc c -> local (const loc) (eval c)
|
||||
where freeVariable s = fail ("free variable: " <> s)
|
||||
uninitialized s = fail ("uninitialized variable: " <> s)
|
||||
invalidRef s = fail ("invalid ref: " <> s)
|
||||
@ -65,138 +65,138 @@ eval Analysis{..} eval = \case
|
||||
|
||||
ref = \case
|
||||
Var n -> lookupEnv' n
|
||||
Core (Let n) -> do
|
||||
Let n -> do
|
||||
addr <- alloc n
|
||||
addr <$ bind n addr
|
||||
Core (If c t e) -> do
|
||||
If c t e -> do
|
||||
c' <- eval c >>= asBool
|
||||
if c' then ref t else ref e
|
||||
Core (a :. b) -> do
|
||||
a :. b -> do
|
||||
a' <- ref a
|
||||
a' ... ref b
|
||||
Core (Ann loc c) -> local (const loc) (ref c)
|
||||
Ann loc c -> local (const loc) (ref c)
|
||||
c -> invalidRef (show c)
|
||||
|
||||
|
||||
prog1 :: File (Core Name)
|
||||
prog1 = fromBody . lam foo $ block
|
||||
[ let' bar .= pure foo
|
||||
, if' (pure bar)
|
||||
(Core.bool False)
|
||||
(Core.bool True)
|
||||
[ Let bar := pure foo
|
||||
, If (pure bar)
|
||||
(Bool False)
|
||||
(Bool True)
|
||||
]
|
||||
where (foo, bar) = (User "foo", User "bar")
|
||||
|
||||
prog2 :: File (Core Name)
|
||||
prog2 = fromBody $ fileBody prog1 $$ Core.bool True
|
||||
prog2 = fromBody $ fileBody prog1 :$ Bool True
|
||||
|
||||
prog3 :: File (Core Name)
|
||||
prog3 = fromBody $ lams [foo, bar, quux]
|
||||
(if' (pure quux)
|
||||
(If (pure quux)
|
||||
(pure bar)
|
||||
(pure foo))
|
||||
where (foo, bar, quux) = (User "foo", User "bar", User "quux")
|
||||
|
||||
prog4 :: File (Core Name)
|
||||
prog4 = fromBody
|
||||
$ let' foo .= Core.bool True
|
||||
<> if' (pure foo)
|
||||
(Core.bool True)
|
||||
(Core.bool False)
|
||||
$ Let foo := Bool True
|
||||
<> If (pure foo)
|
||||
(Bool True)
|
||||
(Bool False)
|
||||
where foo = User "foo"
|
||||
|
||||
prog5 :: File (Core Name)
|
||||
prog5 = fromBody $ block
|
||||
[ let' (User "mkPoint") .= lam (User "_x") (lam (User "_y") (block
|
||||
[ let' (User "x") .= pure (User "_x")
|
||||
, let' (User "y") .= pure (User "_y")]))
|
||||
, let' (User "point") .= pure (User "mkPoint") $$ Core.bool True $$ Core.bool False
|
||||
, pure (User "point") Core.... pure (User "x")
|
||||
, pure (User "point") Core.... pure (User "y") .= pure (User "point") Core.... pure (User "x")
|
||||
[ Let (User "mkPoint") := lam (User "_x") (lam (User "_y") (block
|
||||
[ Let (User "x") := pure (User "_x")
|
||||
, Let (User "y") := pure (User "_y")]))
|
||||
, Let (User "point") := pure (User "mkPoint") :$ Bool True :$ Bool False
|
||||
, pure (User "point") :. pure (User "x")
|
||||
, pure (User "point") :. pure (User "y") := pure (User "point") :. pure (User "x")
|
||||
]
|
||||
|
||||
prog6 :: [File (Core Name)]
|
||||
prog6 =
|
||||
[ File (Loc "dep" (locSpan (fromJust here))) $ block
|
||||
[ let' (Path "dep") .= Core.frame
|
||||
, pure (Path "dep") Core.... block
|
||||
[ let' (User "var") .= Core.bool True
|
||||
[ Let (Path "dep") := Frame
|
||||
, pure (Path "dep") :. block
|
||||
[ Let (User "var") := Bool True
|
||||
]
|
||||
]
|
||||
, File (Loc "main" (locSpan (fromJust here))) $ block
|
||||
[ load (pure (Path "dep"))
|
||||
, let' (User "thing") .= pure (Path "dep") Core.... pure (User "var")
|
||||
[ Load (pure (Path "dep"))
|
||||
, Let (User "thing") := pure (Path "dep") :. pure (User "var")
|
||||
]
|
||||
]
|
||||
|
||||
ruby :: File (Core Name)
|
||||
ruby = fromBody . ann . block $
|
||||
[ ann (let' (User "Class") .= Core.frame)
|
||||
, ann (pure (User "Class") Core....
|
||||
(ann (let' (User "new") .= lam (User "self") (block
|
||||
[ ann (let' (User "instance") .= Core.frame)
|
||||
, ann (pure (User "instance") Core.... Core.edge Import (pure (User "self")))
|
||||
, ann (pure (User "instance") $$$ "initialize")
|
||||
[ ann (Let (User "Class") := Frame)
|
||||
, ann (pure (User "Class") :.
|
||||
(ann (Let (User "new") := lam (User "self") (block
|
||||
[ ann (Let (User "instance") := Frame)
|
||||
, ann (pure (User "instance") :. Edge Import (pure (User "self")))
|
||||
, ann (pure (User "instance") $$ "initialize")
|
||||
]))))
|
||||
|
||||
, ann (let' (User "(Object)") .= Core.frame)
|
||||
, ann (pure (User "(Object)") Core.... ann (Core.edge Import (pure (User "Class"))))
|
||||
, ann (let' (User "Object") .= Core.frame)
|
||||
, ann (pure (User "Object") Core.... block
|
||||
[ ann (Core.edge Import (pure (User "(Object)")))
|
||||
, ann (let' (User "nil?") .= lam (User "_") false)
|
||||
, ann (let' (User "initialize") .= lam (User "self") (pure (User "self")))
|
||||
, ann (let' __semantic_truthy .= lam (User "_") (Core.bool True))
|
||||
, ann (Let (User "(Object)") := Frame)
|
||||
, ann (pure (User "(Object)") :. ann (Edge Import (pure (User "Class"))))
|
||||
, ann (Let (User "Object") := Frame)
|
||||
, ann (pure (User "Object") :. block
|
||||
[ ann (Edge Import (pure (User "(Object)")))
|
||||
, ann (Let (User "nil?") := lam (User "_") false)
|
||||
, ann (Let (User "initialize") := lam (User "self") (pure (User "self")))
|
||||
, ann (Let __semantic_truthy := lam (User "_") (Bool True))
|
||||
])
|
||||
|
||||
, ann (pure (User "Class") Core.... Core.edge Import (pure (User "Object")))
|
||||
, ann (pure (User "Class") :. Edge Import (pure (User "Object")))
|
||||
|
||||
, ann (let' (User "(NilClass)") .= Core.frame)
|
||||
, ann (pure (User "(NilClass)") Core.... block
|
||||
[ ann (Core.edge Import (pure (User "Class")))
|
||||
, ann (Core.edge Import (pure (User "(Object)")))
|
||||
, ann (Let (User "(NilClass)") := Frame)
|
||||
, ann (pure (User "(NilClass)") :. block
|
||||
[ ann (Edge Import (pure (User "Class")))
|
||||
, ann (Edge Import (pure (User "(Object)")))
|
||||
])
|
||||
, ann (let' (User "NilClass") .= Core.frame)
|
||||
, ann (pure (User "NilClass") Core.... block
|
||||
[ ann (Core.edge Import (pure (User "(NilClass)")))
|
||||
, ann (Core.edge Import (pure (User "Object")))
|
||||
, ann (let' (User "nil?") .= lam (User "_") true)
|
||||
, ann (let' __semantic_truthy .= lam (User "_") (Core.bool False))
|
||||
, ann (Let (User "NilClass") := Frame)
|
||||
, ann (pure (User "NilClass") :. block
|
||||
[ ann (Edge Import (pure (User "(NilClass)")))
|
||||
, ann (Edge Import (pure (User "Object")))
|
||||
, ann (Let (User "nil?") := lam (User "_") true)
|
||||
, ann (Let __semantic_truthy := lam (User "_") (Bool False))
|
||||
])
|
||||
|
||||
, ann (let' (User "(TrueClass)") .= Core.frame)
|
||||
, ann (pure (User "(TrueClass)") Core.... block
|
||||
[ ann (Core.edge Import (pure (User "Class")))
|
||||
, ann (Core.edge Import (pure (User "(Object)")))
|
||||
, ann (Let (User "(TrueClass)") := Frame)
|
||||
, ann (pure (User "(TrueClass)") :. block
|
||||
[ ann (Edge Import (pure (User "Class")))
|
||||
, ann (Edge Import (pure (User "(Object)")))
|
||||
])
|
||||
, ann (let' (User "TrueClass") .= Core.frame)
|
||||
, ann (pure (User "TrueClass") Core.... block
|
||||
[ ann (Core.edge Import (pure (User "(TrueClass)")))
|
||||
, ann (Core.edge Import (pure (User "Object")))
|
||||
, ann (Let (User "TrueClass") := Frame)
|
||||
, ann (pure (User "TrueClass") :. block
|
||||
[ ann (Edge Import (pure (User "(TrueClass)")))
|
||||
, ann (Edge Import (pure (User "Object")))
|
||||
])
|
||||
|
||||
, ann (let' (User "(FalseClass)") .= Core.frame)
|
||||
, ann (pure (User "(FalseClass)") Core.... block
|
||||
[ ann (Core.edge Import (pure (User "Class")))
|
||||
, ann (Core.edge Import (pure (User "(Object)")))
|
||||
, ann (Let (User "(FalseClass)") := Frame)
|
||||
, ann (pure (User "(FalseClass)") :. block
|
||||
[ ann (Edge Import (pure (User "Class")))
|
||||
, ann (Edge Import (pure (User "(Object)")))
|
||||
])
|
||||
, ann (let' (User "FalseClass") .= Core.frame)
|
||||
, ann (pure (User "FalseClass") Core.... block
|
||||
[ ann (Core.edge Import (pure (User "(FalseClass)")))
|
||||
, ann (Core.edge Import (pure (User "Object")))
|
||||
, ann (let' __semantic_truthy .= lam (User "_") (Core.bool False))
|
||||
, ann (Let (User "FalseClass") := Frame)
|
||||
, ann (pure (User "FalseClass") :. block
|
||||
[ ann (Edge Import (pure (User "(FalseClass)")))
|
||||
, ann (Edge Import (pure (User "Object")))
|
||||
, ann (Let __semantic_truthy := lam (User "_") (Bool False))
|
||||
])
|
||||
|
||||
, ann (let' (User "nil") .= pure (User "NilClass") $$$ "new")
|
||||
, ann (let' (User "true") .= pure (User "TrueClass") $$$ "new")
|
||||
, ann (let' (User "false") .= pure (User "FalseClass") $$$ "new")
|
||||
, ann (Let (User "nil") := pure (User "NilClass") $$ "new")
|
||||
, ann (Let (User "true") := pure (User "TrueClass") $$ "new")
|
||||
, ann (Let (User "false") := pure (User "FalseClass") $$ "new")
|
||||
|
||||
, ann (let' (User "require") .= lam (User "path") (Core.load (pure (User "path"))))
|
||||
, ann (Let (User "require") := lam (User "path") (Load (pure (User "path"))))
|
||||
]
|
||||
where -- _nil = pure (User "nil")
|
||||
true = pure (User "true")
|
||||
false = pure (User "false")
|
||||
self $$$ method = annWith callStack $ lam (User "_x") (pure (User "_x") Core.... pure (User method) $$ pure (User "_x")) $$ self
|
||||
self $$ method = annWith callStack $ lam (User "_x") (pure (User "_x") :. pure (User method) :$ pure (User "_x")) :$ self
|
||||
|
||||
__semantic_truthy = User "__semantic_truthy"
|
||||
|
||||
|
||||
@ -1,29 +1,20 @@
|
||||
{-# LANGUAGE DeriveTraversable, FlexibleContexts, LambdaCase, OverloadedStrings, QuantifiedConstraints, RankNTypes, ScopedTypeVariables, StandaloneDeriving,
|
||||
TypeFamilies, TypeOperators #-}
|
||||
{-# LANGUAGE DeriveTraversable, FlexibleContexts, LambdaCase, OverloadedStrings, QuantifiedConstraints, RankNTypes,
|
||||
ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators #-}
|
||||
module Data.Core
|
||||
( Core(..)
|
||||
, project
|
||||
, embed
|
||||
, CoreF(..)
|
||||
, Edge(..)
|
||||
, let'
|
||||
, block
|
||||
, lam
|
||||
, lams
|
||||
, unlam
|
||||
, unseq
|
||||
, unseqs
|
||||
, ($$)
|
||||
, ($$*)
|
||||
, unapply
|
||||
, unapplies
|
||||
, unit
|
||||
, bool
|
||||
, if'
|
||||
, string
|
||||
, load
|
||||
, edge
|
||||
, frame
|
||||
, (...)
|
||||
, (.=)
|
||||
, ann
|
||||
, annWith
|
||||
, gfold
|
||||
@ -50,35 +41,26 @@ data Edge = Lexical | Import
|
||||
|
||||
data Core a
|
||||
= Var a
|
||||
| Core (CoreF Core a)
|
||||
deriving (Eq, Foldable, Functor, Ord, Show, Traversable)
|
||||
|
||||
data CoreF f a
|
||||
= Let Name
|
||||
| Let Name
|
||||
-- | Sequencing without binding; analogous to '>>' or '*>'.
|
||||
| f a :>> f a
|
||||
| Lam (f (Incr (f a)))
|
||||
| Core a :>> Core a
|
||||
| Lam (Core (Incr (Core a)))
|
||||
-- | Function application; analogous to '$'.
|
||||
| f a :$ f a
|
||||
| Core a :$ Core a
|
||||
| Unit
|
||||
| Bool Bool
|
||||
| If (f a) (f a) (f a)
|
||||
| If (Core a) (Core a) (Core a)
|
||||
| String Text
|
||||
-- | Load the specified file (by path).
|
||||
| Load (f a)
|
||||
| Edge Edge (f a)
|
||||
| Load (Core a)
|
||||
| Edge Edge (Core a)
|
||||
-- | Allocation of a new frame.
|
||||
| Frame
|
||||
| f a :. f a
|
||||
| Core a :. Core a
|
||||
-- | Assignment of a value to the reference returned by the lhs.
|
||||
| f a := f a
|
||||
| Ann Loc (f a)
|
||||
deriving (Foldable, Functor, Traversable)
|
||||
|
||||
deriving instance (Eq a, forall x . Eq x => Eq (f x)) => Eq (CoreF f a)
|
||||
deriving instance (Ord a, forall x . Eq x => Eq (f x)
|
||||
, forall x . Ord x => Ord (f x)) => Ord (CoreF f a)
|
||||
deriving instance (Show a, forall x . Show x => Show (f x)) => Show (CoreF f a)
|
||||
| Core a := Core a
|
||||
| Ann Loc (Core a)
|
||||
deriving (Eq, Foldable, Functor, Ord, Show, Traversable)
|
||||
|
||||
infixl 2 :$
|
||||
infixr 1 :>>
|
||||
@ -86,37 +68,102 @@ infix 3 :=
|
||||
infixl 4 :.
|
||||
|
||||
instance Semigroup (Core a) where
|
||||
a <> b = Core (a :>> b)
|
||||
(<>) = (:>>)
|
||||
|
||||
instance Applicative Core where
|
||||
pure = Var
|
||||
(<*>) = ap
|
||||
|
||||
instance Monad Core where
|
||||
a >>= f = gfold id let' (<>) (Core . Lam) ($$) unit bool if' string load edge frame (...) (.=) (fmap Core . Ann) pure (f <$> a)
|
||||
a >>= f = gfold id Let (:>>) Lam (:$) Unit Bool If String Load Edge Frame (:.) (:=) Ann pure (f <$> a)
|
||||
|
||||
|
||||
let' :: Name -> Core a
|
||||
let' = Core . Let
|
||||
project :: Core a -> Either a (CoreF Core a)
|
||||
project (Var a) = Left a
|
||||
project (Let n) = Right (LetF n)
|
||||
project (a :>> b) = Right (a :>>$ b)
|
||||
project (Lam b) = Right (LamF b)
|
||||
project (f :$ a) = Right (f :$$ a)
|
||||
project Unit = Right UnitF
|
||||
project (Bool b) = Right (BoolF b)
|
||||
project (If c t e) = Right (IfF c t e)
|
||||
project (String s) = Right (StringF s)
|
||||
project (Load b) = Right (LoadF b)
|
||||
project (Edge e b) = Right (EdgeF e b)
|
||||
project Frame = Right FrameF
|
||||
project (a :. b) = Right (a :.$ b)
|
||||
project (a := b) = Right (a :=$ b)
|
||||
project (Ann l b) = Right (AnnF l b)
|
||||
|
||||
embed :: Either a (CoreF Core a) -> Core a
|
||||
embed = either Var $ \case
|
||||
LetF n -> Let n
|
||||
a :>>$ b -> a :>> b
|
||||
LamF b -> Lam b
|
||||
f :$$ a -> f :$ a
|
||||
UnitF -> Unit
|
||||
BoolF b -> Bool b
|
||||
IfF c t e -> If c t e
|
||||
StringF s -> String s
|
||||
LoadF b -> Load b
|
||||
EdgeF e b -> Edge e b
|
||||
FrameF -> Frame
|
||||
a :.$ b -> a :. b
|
||||
a :=$ b -> a := b
|
||||
AnnF l b -> Ann l b
|
||||
|
||||
|
||||
data CoreF f a
|
||||
= LetF Name
|
||||
-- | Sequencing without binding; analogous to '>>' or '*>'.
|
||||
| f a :>>$ f a
|
||||
| LamF (f (Incr (f a)))
|
||||
-- | Function application; analogous to '$'.
|
||||
| f a :$$ f a
|
||||
| UnitF
|
||||
| BoolF Bool
|
||||
| IfF (f a) (f a) (f a)
|
||||
| StringF Text
|
||||
-- | Load the specified file (by path).
|
||||
| LoadF (f a)
|
||||
| EdgeF Edge (f a)
|
||||
-- | Allocation of a new frame.
|
||||
| FrameF
|
||||
| f a :.$ f a
|
||||
-- | Assignment of a value to the reference returned by the lhs.
|
||||
| f a :=$ f a
|
||||
| AnnF Loc (f a)
|
||||
deriving (Foldable, Functor, Traversable)
|
||||
|
||||
deriving instance (Eq a, forall x . Eq x => Eq (f x)) => Eq (CoreF f a)
|
||||
deriving instance (Ord a, forall x . Eq x => Eq (f x)
|
||||
, forall x . Ord x => Ord (f x)) => Ord (CoreF f a)
|
||||
deriving instance (Show a, forall x . Show x => Show (f x)) => Show (CoreF f a)
|
||||
|
||||
infixl 2 :$$
|
||||
infixr 1 :>>$
|
||||
infix 3 :=$
|
||||
infixl 4 :.$
|
||||
|
||||
|
||||
block :: Foldable t => t (Core a) -> Core a
|
||||
block cs
|
||||
| null cs = unit
|
||||
| null cs = Unit
|
||||
| otherwise = foldr1 (<>) cs
|
||||
|
||||
lam :: Eq a => a -> Core a -> Core a
|
||||
lam n b = Core (Lam (bind n b))
|
||||
lam n b = Lam (bind n b)
|
||||
|
||||
lams :: (Eq a, Foldable t) => t a -> Core a -> Core a
|
||||
lams names body = foldr lam body names
|
||||
|
||||
unlam :: Alternative m => a -> Core a -> m (a, Core a)
|
||||
unlam n (Core (Lam b)) = pure (n, instantiate (pure n) b)
|
||||
unlam _ _ = empty
|
||||
unlam n (Lam b) = pure (n, instantiate (pure n) b)
|
||||
unlam _ _ = empty
|
||||
|
||||
unseq :: Alternative m => Core a -> m (Core a, Core a)
|
||||
unseq (Core (a :>> b)) = pure (a, b)
|
||||
unseq _ = empty
|
||||
unseq (a :>> b) = pure (a, b)
|
||||
unseq _ = empty
|
||||
|
||||
unseqs :: Core a -> NonEmpty (Core a)
|
||||
unseqs = go
|
||||
@ -124,62 +171,26 @@ unseqs = go
|
||||
Just (l, r) -> go l <> go r
|
||||
Nothing -> t :| []
|
||||
|
||||
($$) :: Core a -> Core a -> Core a
|
||||
f $$ a = Core (f :$ a)
|
||||
|
||||
infixl 2 $$
|
||||
|
||||
-- | Application of a function to a sequence of arguments.
|
||||
($$*) :: Foldable t => Core a -> t (Core a) -> Core a
|
||||
($$*) = foldl' ($$)
|
||||
($$*) = foldl' (:$)
|
||||
|
||||
infixl 9 $$*
|
||||
|
||||
unapply :: Alternative m => Core a -> m (Core a, Core a)
|
||||
unapply (Core (f :$ a)) = pure (f, a)
|
||||
unapply _ = empty
|
||||
unapply (f :$ a) = pure (f, a)
|
||||
unapply _ = empty
|
||||
|
||||
unapplies :: Core a -> (Core a, Stack (Core a))
|
||||
unapplies core = case unapply core of
|
||||
Just (f, a) -> (:> a) <$> unapplies f
|
||||
Nothing -> (core, Nil)
|
||||
|
||||
unit :: Core a
|
||||
unit = Core Unit
|
||||
|
||||
bool :: Bool -> Core a
|
||||
bool = Core . Bool
|
||||
|
||||
if' :: Core a -> Core a -> Core a -> Core a
|
||||
if' c t e = Core (If c t e)
|
||||
|
||||
string :: Text -> Core a
|
||||
string = Core . String
|
||||
|
||||
load :: Core a -> Core a
|
||||
load = Core . Load
|
||||
|
||||
edge :: Edge -> Core a -> Core a
|
||||
edge e b = Core (Edge e b)
|
||||
|
||||
frame :: Core a
|
||||
frame = Core Frame
|
||||
|
||||
(...) :: Core a -> Core a -> Core a
|
||||
a ... b = Core (a :. b)
|
||||
|
||||
infixl 4 ...
|
||||
|
||||
(.=) :: Core a -> Core a -> Core a
|
||||
a .= b = Core (a := b)
|
||||
|
||||
infix 3 .=
|
||||
|
||||
ann :: HasCallStack => Core a -> Core a
|
||||
ann = annWith callStack
|
||||
|
||||
annWith :: CallStack -> Core a -> Core a
|
||||
annWith callStack c = maybe c (flip (fmap Core . Ann) c) (stackLoc callStack)
|
||||
annWith callStack c = maybe c (flip Ann c) (stackLoc callStack)
|
||||
|
||||
|
||||
gfold :: forall m n b
|
||||
@ -205,20 +216,20 @@ gfold var let' seq' lam app unit bool if' string load edge frame dot assign ann
|
||||
where go :: Core (m x) -> n x
|
||||
go = \case
|
||||
Var a -> var a
|
||||
Core (Let a) -> let' a
|
||||
Core (a :>> b) -> go a `seq'` go b
|
||||
Core (Lam b) -> lam (go (k . fmap go <$> b))
|
||||
Core (f :$ a) -> go f `app` go a
|
||||
Core Unit -> unit
|
||||
Core (Bool b) -> bool b
|
||||
Core (If c t e) -> if' (go c) (go t) (go e)
|
||||
Core (String s) -> string s
|
||||
Core (Load t) -> load (go t)
|
||||
Core (Edge e t) -> edge e (go t)
|
||||
Core Frame -> frame
|
||||
Core (a :. b) -> go a `dot` go b
|
||||
Core (a := b) -> go a `assign` go b
|
||||
Core (Ann loc t) -> ann loc (go t)
|
||||
Let a -> let' a
|
||||
a :>> b -> go a `seq'` go b
|
||||
Lam b -> lam (go (k . fmap go <$> b))
|
||||
f :$ a -> go f `app` go a
|
||||
Unit -> unit
|
||||
Bool b -> bool b
|
||||
If c t e -> if' (go c) (go t) (go e)
|
||||
String s -> string s
|
||||
Load t -> load (go t)
|
||||
Edge e t -> edge e (go t)
|
||||
Frame -> frame
|
||||
a :. b -> go a `dot` go b
|
||||
a := b -> go a `assign` go b
|
||||
Ann loc t -> ann loc (go t)
|
||||
|
||||
efold :: forall l m n z b
|
||||
. ( forall a b . Coercible a b => Coercible (n a) (n b)
|
||||
@ -246,23 +257,23 @@ efold :: forall l m n z b
|
||||
efold var let' seq' lam app unit bool if' string load edge frame dot assign ann k = eiter var alg
|
||||
where alg :: forall x l' c z' . Functor c => (forall l'' z'' x . (l'' x -> m (z'' x)) -> c (l'' x) -> n (z'' x)) -> (l' x -> m (z' x)) -> CoreF c (l' x) -> n (z' x)
|
||||
alg go h = \case
|
||||
Let a -> let' a
|
||||
a :>> b -> go h a `seq'` go h b
|
||||
Lam b -> lam (coerce (go
|
||||
(coerce (k . fmap (go h))
|
||||
:: ((Incr :.: c :.: l') x -> m ((Incr :.: n :.: z') x)))
|
||||
(fmap coerce b))) -- FIXME: can we avoid this fmap and just coerce harder?
|
||||
a :$ b -> go h a `app` go h b
|
||||
Unit -> unit
|
||||
Bool b -> bool b
|
||||
If c t e -> if' (go h c) (go h t) (go h e)
|
||||
String s -> string s
|
||||
Load t -> load (go h t)
|
||||
Edge e t -> edge e (go h t)
|
||||
Frame -> frame
|
||||
a :. b -> go h a `dot` go h b
|
||||
a := b -> go h a `assign` go h b
|
||||
Ann loc t -> ann loc (go h t)
|
||||
LetF a -> let' a
|
||||
a :>>$ b -> go h a `seq'` go h b
|
||||
LamF b -> lam (coerce (go
|
||||
(coerce (k . fmap (go h))
|
||||
:: ((Incr :.: c :.: l') x -> m ((Incr :.: n :.: z') x)))
|
||||
(fmap coerce b))) -- FIXME: can we avoid this fmap and just coerce harder?
|
||||
a :$$ b -> go h a `app` go h b
|
||||
UnitF -> unit
|
||||
BoolF b -> bool b
|
||||
IfF c t e -> if' (go h c) (go h t) (go h e)
|
||||
StringF s -> string s
|
||||
LoadF t -> load (go h t)
|
||||
EdgeF e t -> edge e (go h t)
|
||||
FrameF -> frame
|
||||
a :.$ b -> go h a `dot` go h b
|
||||
a :=$ b -> go h a `assign` go h b
|
||||
AnnF loc t -> ann loc (go h t)
|
||||
|
||||
-- | Efficient Mendler-style iteration.
|
||||
eiter :: forall l m n z b
|
||||
@ -273,9 +284,9 @@ eiter :: forall l m n z b
|
||||
-> n (z b)
|
||||
eiter var alg = go
|
||||
where go :: forall l' z' x . (l' x -> m (z' x)) -> Core (l' x) -> n (z' x)
|
||||
go h = \case
|
||||
Var a -> var (h a)
|
||||
Core b -> alg go h b
|
||||
go h c = case project c of
|
||||
Left a -> var (h a)
|
||||
Right b -> alg go h b
|
||||
|
||||
kfold :: (a -> b)
|
||||
-> (Name -> b)
|
||||
|
||||
@ -10,8 +10,7 @@ module Data.Core.Parser
|
||||
|
||||
import Control.Applicative
|
||||
import qualified Data.Char as Char
|
||||
import Data.Core hiding (edge, string)
|
||||
import qualified Data.Core as Core
|
||||
import Data.Core
|
||||
import Data.Name
|
||||
import Data.Semigroup
|
||||
import Data.String
|
||||
@ -50,8 +49,8 @@ core = expr
|
||||
|
||||
expr :: (TokenParsing m, Monad m) => m (Core Name)
|
||||
expr = atom `chainl1` go where
|
||||
go = choice [ (...) <$ dot
|
||||
, ($$) <$ notFollowedBy dot
|
||||
go = choice [ (:.) <$ dot
|
||||
, (:$) <$ notFollowedBy dot
|
||||
]
|
||||
|
||||
atom :: (TokenParsing m, Monad m) => m (Core Name)
|
||||
@ -69,24 +68,24 @@ comp :: (TokenParsing m, Monad m) => m (Core Name)
|
||||
comp = braces (sconcat <$> sepEndByNonEmpty expr semi) <?> "compound statement"
|
||||
|
||||
ifthenelse :: (TokenParsing m, Monad m) => m (Core Name)
|
||||
ifthenelse = if'
|
||||
ifthenelse = If
|
||||
<$ reserved "if" <*> core
|
||||
<* reserved "then" <*> core
|
||||
<* reserved "else" <*> core
|
||||
<?> "if-then-else statement"
|
||||
|
||||
assign :: (TokenParsing m, Monad m) => m (Core Name)
|
||||
assign = fmap Core . (:=) <$> try (lvalue <* symbolic '=') <*> core <?> "assignment"
|
||||
assign = (:=) <$> try (lvalue <* symbolic '=') <*> core <?> "assignment"
|
||||
|
||||
edge :: (TokenParsing m, Monad m) => m (Core Name)
|
||||
edge = kw <*> expr where kw = choice [ Core.edge Lexical <$ reserved "lexical"
|
||||
, Core.edge Import <$ reserved "import"
|
||||
, Core.load <$ reserved "load"
|
||||
edge = kw <*> expr where kw = choice [ Edge Lexical <$ reserved "lexical"
|
||||
, Edge Import <$ reserved "import"
|
||||
, Load <$ reserved "load"
|
||||
]
|
||||
|
||||
lvalue :: (TokenParsing m, Monad m) => m (Core Name)
|
||||
lvalue = choice
|
||||
[ let' <$ reserved "let" <*> name
|
||||
[ Let <$ reserved "let" <*> name
|
||||
, ident
|
||||
, parens expr
|
||||
]
|
||||
@ -100,10 +99,10 @@ name = choice [regular, strpath] <?> "name" where
|
||||
|
||||
lit :: (TokenParsing m, Monad m) => m (Core Name)
|
||||
lit = let x `given` n = x <$ reserved n in choice
|
||||
[ Core.bool True `given` "#true"
|
||||
, Core.bool False `given` "#false"
|
||||
, Core.unit `given` "#unit"
|
||||
, Core.frame `given` "#frame"
|
||||
[ Bool True `given` "#true"
|
||||
, Bool False `given` "#false"
|
||||
, Unit `given` "#unit"
|
||||
, Frame `given` "#frame"
|
||||
, lambda
|
||||
] <?> "literal"
|
||||
|
||||
|
||||
@ -116,8 +116,8 @@ prettify :: (Member Naming sig, Member (Reader Prec) sig, Member (Reader Style)
|
||||
-> m AnsiDoc
|
||||
prettify = \case
|
||||
Var a -> pure $ name a
|
||||
Core (Let a) -> pure $ keyword "let" <+> name a
|
||||
Core (a :>> b) -> do
|
||||
Let a -> pure $ keyword "let" <+> name a
|
||||
a :>> b -> do
|
||||
prec <- ask @Prec
|
||||
fore <- with 12 (prettify a)
|
||||
aft <- with 12 (prettify b)
|
||||
@ -129,41 +129,41 @@ prettify = \case
|
||||
|
||||
pure . Pretty.align $ encloseIf (12 > prec) open close (Pretty.align body)
|
||||
|
||||
Core (Lam f) -> inParens 11 $ do
|
||||
Lam f -> inParens 11 $ do
|
||||
x <- Gen <$> gensym ""
|
||||
body <- prettify (instantiate (pure x) f)
|
||||
lam <- lambda
|
||||
arr <- arrow
|
||||
pure (lam <> name x <+> arr <+> body)
|
||||
|
||||
Core Frame -> pure $ primitive "frame"
|
||||
Core Unit -> pure $ primitive "unit"
|
||||
Core (Bool b) -> pure $ primitive (if b then "true" else "false")
|
||||
Core (String s) -> pure . strlit $ Pretty.viaShow s
|
||||
Frame -> pure $ primitive "frame"
|
||||
Unit -> pure $ primitive "unit"
|
||||
Bool b -> pure $ primitive (if b then "true" else "false")
|
||||
String s -> pure . strlit $ Pretty.viaShow s
|
||||
|
||||
Core (f :$ x) -> inParens 11 $ (<+>) <$> prettify f <*> prettify x
|
||||
f :$ x -> inParens 11 $ (<+>) <$> prettify f <*> prettify x
|
||||
|
||||
Core (If con tru fal) -> do
|
||||
If con tru fal -> do
|
||||
con' <- "if" `appending` prettify con
|
||||
tru' <- "then" `appending` prettify tru
|
||||
fal' <- "else" `appending` prettify fal
|
||||
pure $ Pretty.sep [con', tru', fal']
|
||||
|
||||
Core (Load p) -> "load" `appending` prettify p
|
||||
Core (Edge Lexical n) -> "lexical" `appending` prettify n
|
||||
Core (Edge Import n) -> "import" `appending` prettify n
|
||||
Core (item :. body) -> inParens 5 $ do
|
||||
Load p -> "load" `appending` prettify p
|
||||
Edge Lexical n -> "lexical" `appending` prettify n
|
||||
Edge Import n -> "import" `appending` prettify n
|
||||
item :. body -> inParens 5 $ do
|
||||
f <- prettify item
|
||||
g <- prettify body
|
||||
pure (f <> symbol "." <> g)
|
||||
|
||||
Core (lhs := rhs) -> inParens 4 $ do
|
||||
lhs := rhs -> inParens 4 $ do
|
||||
f <- prettify lhs
|
||||
g <- prettify rhs
|
||||
pure (f <+> symbol "=" <+> g)
|
||||
|
||||
-- Annotations are not pretty-printed, as it lowers the signal/noise ratio too profoundly.
|
||||
Core (Ann _ c) -> prettify c
|
||||
Ann _ c -> prettify c
|
||||
|
||||
appending :: Functor f => AnsiDoc -> f AnsiDoc -> f AnsiDoc
|
||||
appending k item = (keyword k <+>) <$> item
|
||||
|
||||
Loading…
Reference in New Issue
Block a user