mirror of
https://github.com/github/semantic.git
synced 2024-12-24 23:42:31 +03:00
Split Core into a higher-order functor and its fixpoint.
This commit is contained in:
Rob Rix
parent
2c8e8dcf3c
commit
1247dffb8b
@ -27,35 +27,35 @@ 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
|
||||
Let n -> alloc n >>= bind n >> unit
|
||||
a :>> b -> eval a >> eval b
|
||||
Lam b -> do
|
||||
Core (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
|
||||
n <- Gen <$> gensym "lam"
|
||||
abstract eval n (instantiate (pure n) b)
|
||||
f :$ a -> do
|
||||
Core (f :$ a) -> do
|
||||
f' <- eval f
|
||||
a' <- eval a
|
||||
apply eval f' a'
|
||||
Unit -> unit
|
||||
Bool b -> bool b
|
||||
If c t e -> do
|
||||
Core Unit -> unit
|
||||
Core (Bool b) -> bool b
|
||||
Core (If c t e) -> do
|
||||
c' <- eval c >>= asBool
|
||||
if c' then eval t else eval e
|
||||
String s -> string s
|
||||
Load p -> do
|
||||
Core (String s) -> string s
|
||||
Core (Load p) -> do
|
||||
path <- eval p >>= asString
|
||||
lookupEnv' (Path path) >>= deref' (Path path)
|
||||
Edge e a -> ref a >>= edge e >> unit
|
||||
Frame -> frame
|
||||
a :. b -> do
|
||||
Core (Edge e a) -> ref a >>= edge e >> unit
|
||||
Core Frame -> frame
|
||||
Core (a :. b) -> do
|
||||
a' <- ref a
|
||||
a' ... eval b
|
||||
a := b -> do
|
||||
Core (a := b) -> do
|
||||
b' <- eval b
|
||||
addr <- ref a
|
||||
b' <$ assign addr b'
|
||||
Ann loc c -> local (const loc) (eval c)
|
||||
Core (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)
|
||||
@ -64,137 +64,139 @@ eval Analysis{..} eval = \case
|
||||
deref' n = deref >=> maybe (uninitialized (show n)) pure
|
||||
|
||||
ref = \case
|
||||
Var n -> lookupEnv' n
|
||||
Let n -> do
|
||||
Core (Var n) -> lookupEnv' n
|
||||
Core (Let n) -> do
|
||||
addr <- alloc n
|
||||
addr <$ bind n addr
|
||||
If c t e -> do
|
||||
Core (If c t e) -> do
|
||||
c' <- eval c >>= asBool
|
||||
if c' then ref t else ref e
|
||||
a :. b -> do
|
||||
Core (a :. b) -> do
|
||||
a' <- ref a
|
||||
a' ... ref b
|
||||
Ann loc c -> local (const loc) (ref c)
|
||||
Core (Ann loc c) -> local (const loc) (ref c)
|
||||
c -> invalidRef (show c)
|
||||
|
||||
|
||||
prog1 :: File (Core Name)
|
||||
prog1 = fromBody $ lam foo
|
||||
( Let bar := Var foo
|
||||
:>> If (Var bar)
|
||||
(Bool False)
|
||||
(Bool True))
|
||||
prog1 = fromBody . lam foo $ block
|
||||
[ let' bar .= pure foo
|
||||
, if' (pure bar)
|
||||
(Core.bool False)
|
||||
(Core.bool True)
|
||||
]
|
||||
where (foo, bar) = (User "foo", User "bar")
|
||||
|
||||
prog2 :: File (Core Name)
|
||||
prog2 = fromBody $ fileBody prog1 :$ Bool True
|
||||
prog2 = fromBody $ fileBody prog1 $$ Core.bool True
|
||||
|
||||
prog3 :: File (Core Name)
|
||||
prog3 = fromBody $ lams [foo, bar, quux]
|
||||
(If (Var quux)
|
||||
(Var bar)
|
||||
(Var foo))
|
||||
(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 := Bool True
|
||||
:>> If (Var foo)
|
||||
(Bool True)
|
||||
(Bool False)
|
||||
$ let' foo .= Core.bool True
|
||||
>>> if' (pure foo)
|
||||
(Core.bool True)
|
||||
(Core.bool False)
|
||||
where foo = User "foo"
|
||||
|
||||
prog5 :: File (Core Name)
|
||||
prog5 = fromBody
|
||||
$ Let (User "mkPoint") := lam (User "_x") (lam (User "_y")
|
||||
( Let (User "x") := Var (User "_x")
|
||||
:>> Let (User "y") := Var (User "_y")))
|
||||
:>> Let (User "point") := Var (User "mkPoint") :$ Bool True :$ Bool False
|
||||
:>> Var (User "point") :. Var (User "x")
|
||||
:>> Var (User "point") :. Var (User "y") := Var (User "point") :. Var (User "x")
|
||||
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")
|
||||
]
|
||||
|
||||
prog6 :: [File (Core Name)]
|
||||
prog6 =
|
||||
[ File (Loc "dep" (locSpan (fromJust here))) $ block
|
||||
[ Let (Path "dep") := Frame
|
||||
, Var (Path "dep") :. block
|
||||
[ Let (User "var") := Bool True
|
||||
[ let' (Path "dep") .= Core.frame
|
||||
, pure (Path "dep") Core.... block
|
||||
[ let' (User "var") .= Core.bool True
|
||||
]
|
||||
]
|
||||
, File (Loc "main" (locSpan (fromJust here))) $ block
|
||||
[ Load (Var (Path "dep"))
|
||||
, Let (User "thing") := Var (Path "dep") :. Var (User "var")
|
||||
[ load (pure (Path "dep"))
|
||||
, let' (User "thing") .= pure (Path "dep") Core.... pure (User "var")
|
||||
]
|
||||
]
|
||||
|
||||
ruby :: File (Core Name)
|
||||
ruby = fromBody . ann . block $
|
||||
[ ann (Let (User "Class") := Frame)
|
||||
, ann (Var (User "Class") :.
|
||||
(ann (Let (User "new") := lam (User "self") (block
|
||||
[ ann (Let (User "instance") := Frame)
|
||||
, ann (Var (User "instance") :. Edge Import (Var (User "self")))
|
||||
, ann (Var (User "instance") $$ "initialize")
|
||||
[ 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 "(Object)") := Frame)
|
||||
, ann (Var (User "(Object)") :. ann (Edge Import (Var (User "Class"))))
|
||||
, ann (Let (User "Object") := Frame)
|
||||
, ann (Var (User "Object") :. block
|
||||
[ ann (Edge Import (Var (User "(Object)")))
|
||||
, ann (Let (User "nil?") := lam (User "_") false)
|
||||
, ann (Let (User "initialize") := lam (User "self") (Var (User "self")))
|
||||
, ann (Let __semantic_truthy := lam (User "_") (Bool True))
|
||||
, 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 (Var (User "Class") :. Edge Import (Var (User "Object")))
|
||||
, ann (pure (User "Class") Core.... Core.edge Import (pure (User "Object")))
|
||||
|
||||
, ann (Let (User "(NilClass)") := Frame)
|
||||
, ann (Var (User "(NilClass)") :. block
|
||||
[ ann (Edge Import (Var (User "Class")))
|
||||
, ann (Edge Import (Var (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 (Var (User "NilClass") :. block
|
||||
[ ann (Edge Import (Var (User "(NilClass)")))
|
||||
, ann (Edge Import (Var (User "Object")))
|
||||
, ann (Let (User "nil?") := lam (User "_") true)
|
||||
, ann (Let __semantic_truthy := lam (User "_") (Bool False))
|
||||
, 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 "(TrueClass)") := Frame)
|
||||
, ann (Var (User "(TrueClass)") :. block
|
||||
[ ann (Edge Import (Var (User "Class")))
|
||||
, ann (Edge Import (Var (User "(Object)")))
|
||||
, 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 (Var (User "TrueClass") :. block
|
||||
[ ann (Edge Import (Var (User "(TrueClass)")))
|
||||
, ann (Edge Import (Var (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 "(FalseClass)") := Frame)
|
||||
, ann (Var (User "(FalseClass)") :. block
|
||||
[ ann (Edge Import (Var (User "Class")))
|
||||
, ann (Edge Import (Var (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 (Var (User "FalseClass") :. block
|
||||
[ ann (Edge Import (Var (User "(FalseClass)")))
|
||||
, ann (Edge Import (Var (User "Object")))
|
||||
, ann (Let __semantic_truthy := lam (User "_") (Bool False))
|
||||
, 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 "nil") := Var (User "NilClass") $$ "new")
|
||||
, ann (Let (User "true") := Var (User "TrueClass") $$ "new")
|
||||
, ann (Let (User "false") := Var (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") (Load (Var (User "path"))))
|
||||
, ann (let' (User "require") .= lam (User "path") (Core.load (pure (User "path"))))
|
||||
]
|
||||
where _nil = Var (User "nil")
|
||||
true = Var (User "true")
|
||||
false = Var (User "false")
|
||||
self $$ method = annWith callStack $ lam (User "_x") (Var (User "_x") :. Var (User method) :$ Var (User "_x")) :$ self
|
||||
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
|
||||
|
||||
__semantic_truthy = User "__semantic_truthy"
|
||||
|
||||
|
||||
@ -1,17 +1,29 @@
|
||||
{-# LANGUAGE DeriveTraversable, FlexibleContexts, LambdaCase, OverloadedStrings, RankNTypes, ScopedTypeVariables,
|
||||
{-# LANGUAGE DeriveTraversable, FlexibleContexts, LambdaCase, OverloadedStrings, QuantifiedConstraints, RankNTypes, ScopedTypeVariables, StandaloneDeriving,
|
||||
TypeFamilies #-}
|
||||
module Data.Core
|
||||
( Core(..)
|
||||
, CoreF(..)
|
||||
, Edge(..)
|
||||
, let'
|
||||
, (>>>)
|
||||
, block
|
||||
, lam
|
||||
, lams
|
||||
, unlam
|
||||
, unseq
|
||||
, unseqs
|
||||
, ($$)
|
||||
, ($$*)
|
||||
, unapply
|
||||
, unapplies
|
||||
, block
|
||||
, unit
|
||||
, bool
|
||||
, if'
|
||||
, load
|
||||
, edge
|
||||
, frame
|
||||
, (...)
|
||||
, (.=)
|
||||
, ann
|
||||
, annWith
|
||||
, gfold
|
||||
@ -33,28 +45,36 @@ import GHC.Stack
|
||||
data Edge = Lexical | Import
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data Core a
|
||||
newtype Core a = Core { unCore :: CoreF Core a }
|
||||
deriving (Eq, Foldable, Functor, Ord, Show, Traversable)
|
||||
|
||||
data CoreF f a
|
||||
= Var a
|
||||
| Let Name
|
||||
-- | Sequencing without binding; analogous to '>>' or '*>'.
|
||||
| Core a :>> Core a
|
||||
| Lam (Core (Incr (Core a)))
|
||||
| f a :>> f a
|
||||
| Lam (f (Incr (f a)))
|
||||
-- | Function application; analogous to '$'.
|
||||
| Core a :$ Core a
|
||||
| f a :$ f a
|
||||
| Unit
|
||||
| Bool Bool
|
||||
| If (Core a) (Core a) (Core a)
|
||||
| If (f a) (f a) (f a)
|
||||
| String Text
|
||||
-- | Load the specified file (by path).
|
||||
| Load (Core a)
|
||||
| Edge Edge (Core a)
|
||||
| Load (f a)
|
||||
| Edge Edge (f a)
|
||||
-- | Allocation of a new frame.
|
||||
| Frame
|
||||
| Core a :. Core a
|
||||
| f a :. f a
|
||||
-- | Assignment of a value to the reference returned by the lhs.
|
||||
| Core a := Core a
|
||||
| Ann Loc (Core a)
|
||||
deriving (Eq, Foldable, Functor, Ord, Show, Traversable)
|
||||
| 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)
|
||||
|
||||
infixl 2 :$
|
||||
infixr 1 :>>
|
||||
@ -62,29 +82,42 @@ infix 3 :=
|
||||
infixl 4 :.
|
||||
|
||||
instance Semigroup (Core a) where
|
||||
(<>) = (:>>)
|
||||
(<>) = fmap Core . (:>>)
|
||||
|
||||
instance Applicative Core where
|
||||
pure = Var
|
||||
pure = Core . Var
|
||||
(<*>) = ap
|
||||
|
||||
instance Monad Core where
|
||||
a >>= f = gfold id Let (:>>) Lam (:$) Unit Bool If String Load Edge Frame (:.) (:=) Ann pure (f <$> a)
|
||||
a >>= f = gfold id (Core . Let) (fmap Core . (:>>)) (Core . Lam) (fmap Core . (:$)) (Core Unit) (Core . Bool) (\ c t e -> Core (If c t e)) (Core . String) (Core . Load) (fmap Core . Edge) (Core Frame) (fmap Core . (:.)) (fmap Core . (:=)) (fmap Core . Ann) pure (f <$> a)
|
||||
|
||||
|
||||
let' :: Name -> Core a
|
||||
let' = Core . Let
|
||||
|
||||
(>>>) :: Core a -> Core a -> Core a
|
||||
a >>> b = Core (a :>> b)
|
||||
|
||||
infixr 1 >>>
|
||||
|
||||
block :: Foldable t => t (Core a) -> Core a
|
||||
block cs
|
||||
| null cs = unit
|
||||
| otherwise = foldr1 (>>>) cs
|
||||
|
||||
lam :: Eq a => a -> Core a -> Core a
|
||||
lam n b = Lam (bind n b)
|
||||
lam n b = Core (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 (Lam b) = pure (n, instantiate (pure n) b)
|
||||
unlam _ _ = empty
|
||||
unlam n (Core (Lam b)) = pure (n, instantiate (pure n) b)
|
||||
unlam _ _ = empty
|
||||
|
||||
unseq :: Alternative m => Core a -> m (Core a, Core a)
|
||||
unseq (a :>> b) = pure (a, b)
|
||||
unseq _ = empty
|
||||
unseq (Core (a :>> b)) = pure (a, b)
|
||||
unseq _ = empty
|
||||
|
||||
unseqs :: Core a -> NonEmpty (Core a)
|
||||
unseqs = go
|
||||
@ -92,31 +125,59 @@ 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 (f :$ a) = pure (f, a)
|
||||
unapply _ = empty
|
||||
unapply (Core (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)
|
||||
|
||||
block :: Foldable t => t (Core a) -> Core a
|
||||
block cs
|
||||
| null cs = Unit
|
||||
| otherwise = foldr1 (:>>) cs
|
||||
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)
|
||||
|
||||
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 Ann c) (stackLoc callStack)
|
||||
annWith callStack c = maybe c (flip (fmap Core . Ann) c) (stackLoc callStack)
|
||||
|
||||
|
||||
gfold :: forall m n b
|
||||
@ -141,21 +202,21 @@ gfold :: forall m n b
|
||||
gfold var let' seq' lam app unit bool if' string load edge frame dot assign ann k = go
|
||||
where go :: Core (m x) -> n x
|
||||
go = \case
|
||||
Var a -> var a
|
||||
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)
|
||||
Core (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)
|
||||
|
||||
kfold :: (a -> b)
|
||||
-> (Name -> b)
|
||||
|
||||
@ -10,7 +10,8 @@ module Data.Core.Parser
|
||||
|
||||
import Control.Applicative
|
||||
import qualified Data.Char as Char
|
||||
import Data.Core
|
||||
import Data.Core hiding (edge)
|
||||
import qualified Data.Core as Core
|
||||
import Data.Name
|
||||
import Data.Semigroup
|
||||
import Data.String
|
||||
@ -49,8 +50,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)
|
||||
@ -68,24 +69,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 = (:=) <$> try (lvalue <* symbolic '=') <*> core <?> "assignment"
|
||||
assign = fmap Core . (:=) <$> try (lvalue <* symbolic '=') <*> core <?> "assignment"
|
||||
|
||||
edge :: (TokenParsing m, Monad m) => m (Core Name)
|
||||
edge = kw <*> expr where kw = choice [ Edge Lexical <$ reserved "lexical"
|
||||
, Edge Import <$ reserved "import"
|
||||
, Load <$ reserved "load"
|
||||
edge = kw <*> expr where kw = choice [ Core.edge Lexical <$ reserved "lexical"
|
||||
, Core.edge Import <$ reserved "import"
|
||||
, Core.load <$ reserved "load"
|
||||
]
|
||||
|
||||
lvalue :: (TokenParsing m, Monad m) => m (Core Name)
|
||||
lvalue = choice
|
||||
[ Let <$ reserved "let" <*> name
|
||||
[ let' <$ reserved "let" <*> name
|
||||
, ident
|
||||
, parens expr
|
||||
]
|
||||
@ -99,10 +100,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
|
||||
[ Bool True `given` "#true"
|
||||
, Bool False `given` "#false"
|
||||
, Unit `given` "#unit"
|
||||
, Frame `given` "#frame"
|
||||
[ Core.bool True `given` "#true"
|
||||
, Core.bool False `given` "#false"
|
||||
, Core.unit `given` "#unit"
|
||||
, Core.frame `given` "#frame"
|
||||
, lambda
|
||||
] <?> "literal"
|
||||
|
||||
@ -112,4 +113,4 @@ lambda = lam <$ lambduh <*> name <* arrow <*> core <?> "lambda" where
|
||||
arrow = symbol "→" <|> symbol "->"
|
||||
|
||||
ident :: (Monad m, TokenParsing m) => m (Core Name)
|
||||
ident = Var <$> name <?> "identifier"
|
||||
ident = pure <$> name <?> "identifier"
|
||||
|
||||
@ -118,9 +118,9 @@ prettify :: (Member Naming sig, Member (Reader Prec) sig, Member (Reader Style)
|
||||
=> Core Name
|
||||
-> m AnsiDoc
|
||||
prettify = \case
|
||||
Var a -> pure $ name a
|
||||
Let a -> pure $ keyword "let" <+> name a
|
||||
a :>> b -> do
|
||||
Core (Var a) -> pure $ name a
|
||||
Core (Let a) -> pure $ keyword "let" <+> name a
|
||||
Core (a :>> b) -> do
|
||||
prec <- ask @Prec
|
||||
fore <- with 12 (prettify a)
|
||||
aft <- with 12 (prettify b)
|
||||
@ -132,41 +132,41 @@ prettify = \case
|
||||
|
||||
pure . Pretty.align $ encloseIf (12 > prec) open close (Pretty.align body)
|
||||
|
||||
Lam f -> inParens 11 $ do
|
||||
Core (Lam f) -> inParens 11 $ do
|
||||
x <- Gen <$> gensym ""
|
||||
body <- prettify (instantiate (pure x) f)
|
||||
lam <- lambda
|
||||
arr <- arrow
|
||||
pure (lam <> name x <+> arr <+> body)
|
||||
|
||||
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 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
|
||||
|
||||
f :$ x -> inParens 11 $ (<+>) <$> prettify f <*> prettify x
|
||||
Core (f :$ x) -> inParens 11 $ (<+>) <$> prettify f <*> prettify x
|
||||
|
||||
If con tru fal -> do
|
||||
Core (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']
|
||||
|
||||
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
|
||||
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
|
||||
f <- prettify item
|
||||
g <- prettify body
|
||||
pure (f <> symbol "." <> g)
|
||||
|
||||
lhs := rhs -> inParens 4 $ do
|
||||
Core (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.
|
||||
Ann _ c -> prettify c
|
||||
Core (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