diff --git a/semantic-core/src/Data/Core.hs b/semantic-core/src/Data/Core.hs index 1bb9934af1..e3a6d8c270 100644 --- a/semantic-core/src/Data/Core.hs +++ b/semantic-core/src/Data/Core.hs @@ -194,25 +194,8 @@ annWith :: (Carrier sig m, Member Core sig) => CallStack -> m a -> m a annWith callStack = maybe id (fmap send . Ann) (stackLoc callStack) -stripAnnotations :: (Member Core sig, Syntax sig) => Term sig a -> Term sig a -stripAnnotations = iter id alg Var Var - where alg t | Just c <- prj t, Ann _ b <- c = b - | otherwise = Term t - - -instance Syntax Core where - foldSyntax go k h = \case - Let a -> Let a - a :>> b -> go h a :>> go h b - Lam u b -> Lam u (foldSyntax go k h b) - a :$ b -> go h a :$ 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 :. go h b - a := b -> go h a := go h b - Ann loc t -> Ann loc (go h t) +stripAnnotations :: (Member Core sig, HFunctor sig, forall g . Functor g => Functor (sig g)) => Term sig a -> Term sig a +stripAnnotations (Var v) = Var v +stripAnnotations (Term t) + | Just c <- prj t, Ann _ b <- c = stripAnnotations b + | otherwise = Term (hmap stripAnnotations t) diff --git a/semantic-core/src/Data/Core/Pretty.hs b/semantic-core/src/Data/Core/Pretty.hs index 70cc97197a..57e70c7cb4 100644 --- a/semantic-core/src/Data/Core/Pretty.hs +++ b/semantic-core/src/Data/Core/Pretty.hs @@ -11,7 +11,6 @@ module Data.Core.Pretty import Control.Effect.Reader import Data.Core import Data.File -import Data.Functor.Const import Data.Name import Data.Scope import Data.Term @@ -56,57 +55,58 @@ inParens amount go = do body <- with amount go pure (encloseIf (amount >= prec) (symbol "(") (symbol ")") body) -prettify :: (Member (Reader [AnsiDoc]) sig, Member (Reader Prec) sig, Carrier sig m) - => Style - -> Core (Const (m AnsiDoc)) a - -> m AnsiDoc -prettify style = \case - Let a -> pure $ keyword "let" <+> name a - Const a :>> Const b -> do - prec <- ask @Prec - fore <- with 12 a - aft <- with 12 b - - let open = symbol ("{" <> softline) - close = symbol (softline <> "}") - separator = ";" <> Pretty.line - body = fore <> separator <> aft - - pure . Pretty.align $ encloseIf (12 > prec) open close (Pretty.align body) - - Lam n f -> inParens 11 $ do - (x, body) <- bind n f - pure (lambda <> x <+> arrow <+> 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 - - Const f :$ Const x -> inParens 11 $ (<+>) <$> f <*> x - - If (Const con) (Const tru) (Const fal) -> do - con' <- "if" `appending` con - tru' <- "then" `appending` tru - fal' <- "else" `appending` fal - pure $ Pretty.sep [con', tru', fal'] - - Load (Const p) -> "load" `appending` p - Edge Lexical (Const n) -> "lexical" `appending` n - Edge Import (Const n) -> "import" `appending` n - Const item :. Const body -> inParens 4 $ do - f <- item - g <- body - pure (f <> symbol "." <> g) - - Const lhs := Const rhs -> inParens 3 $ do - f <- lhs - g <- rhs - pure (f <+> symbol "=" <+> g) - - -- Annotations are not pretty-printed, as it lowers the signal/noise ratio too profoundly. - Ann _ (Const c) -> c - where bind (Ignored x) f = let x' = name x in (,) x' <$> local (x':) (getConst (unScope f)) +prettyCore :: Style -> Term Core User -> AnsiDoc +prettyCore style = run . runReader @Prec 0 . go (pure . name) + where go :: (Member (Reader Prec) sig, Carrier sig m) => (a -> m AnsiDoc) -> Term Core a -> m AnsiDoc + go var = \case + Var v -> var v + Term t -> case t of + Let a -> pure $ keyword "let" <+> name a + a :>> b -> do + prec <- ask @Prec + fore <- with 12 (go var a) + aft <- with 12 (go var b) + + let open = symbol ("{" <> softline) + close = symbol (softline <> "}") + separator = ";" <> Pretty.line + body = fore <> separator <> aft + + pure . Pretty.align $ encloseIf (12 > prec) open close (Pretty.align body) + + Lam n f -> inParens 11 $ do + (x, body) <- bind n f + pure (lambda <> x <+> arrow <+> 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 + + f :$ x -> inParens 11 $ (<+>) <$> go var f <*> go var x + + If con tru fal -> do + con' <- "if" `appending` go var con + tru' <- "then" `appending` go var tru + fal' <- "else" `appending` go var fal + pure $ Pretty.sep [con', tru', fal'] + + Load p -> "load" `appending` go var p + Edge Lexical n -> "lexical" `appending` go var n + Edge Import n -> "import" `appending` go var n + item :. body -> inParens 4 $ do + f <- go var item + g <- go var body + pure (f <> symbol "." <> g) + + lhs := rhs -> inParens 3 $ do + f <- go var lhs + g <- go var rhs + pure (f <+> symbol "=" <+> g) + + -- Annotations are not pretty-printed, as it lowers the signal/noise ratio too profoundly. + Ann _ c -> go var c + where bind (Ignored x) f = let x' = name x in (,) x' <$> go (incr (const (pure x')) var) (fromScope f) lambda = case style of Unicode -> symbol "λ" Ascii -> symbol "\\" @@ -117,8 +117,3 @@ prettify style = \case appending :: Functor f => AnsiDoc -> f AnsiDoc -> f AnsiDoc appending k item = (keyword k <+>) <$> item - -prettyCore :: Style -> Term Core User -> AnsiDoc -prettyCore s = run . runReader @Prec 0 . runReader @[AnsiDoc] [] . cata id (prettify s) bound (pure . name) - where bound (Z _) = asks (head @AnsiDoc) - bound (S n) = local (tail @AnsiDoc) n diff --git a/semantic-core/src/Data/Term.hs b/semantic-core/src/Data/Term.hs index 0557116a13..f7e9695d9f 100644 --- a/semantic-core/src/Data/Term.hs +++ b/semantic-core/src/Data/Term.hs @@ -1,18 +1,11 @@ -{-# LANGUAGE DeriveTraversable, FlexibleInstances, LambdaCase, MultiParamTypeClasses, QuantifiedConstraints, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DeriveTraversable, FlexibleInstances, MultiParamTypeClasses, QuantifiedConstraints, StandaloneDeriving, UndecidableInstances #-} module Data.Term ( Term(..) -, Syntax(..) -, iter -, cata -, interpret ) where import Control.Effect.Carrier import Control.Monad (ap) import Control.Monad.Module -import Data.Coerce (coerce) -import Data.Functor.Const -import Data.Scope data Term sig a = Var a @@ -48,46 +41,3 @@ instance RightModule sig => Monad (Term sig) where instance RightModule sig => Carrier sig (Term sig) where eff = Term - - -class (HFunctor sig, forall g . Functor g => Functor (sig g)) => Syntax sig where - foldSyntax :: (forall x y . (x -> m y) -> f x -> n y) - -> (forall a . Incr () (n a) -> m (Incr () (n a))) - -> (a -> m b) - -> sig f a - -> sig n b - -instance Syntax (Scope ()) where - foldSyntax go bound free = Scope . go (bound . fmap (go free)) . unScope - -instance (Syntax l, Syntax r) => Syntax (l :+: r) where - foldSyntax go bound free (L l) = L (foldSyntax go bound free l) - foldSyntax go bound free (R r) = R (foldSyntax go bound free r) - - -iter :: forall m n sig a b - . Syntax sig - => (forall a . m a -> n a) - -> (forall a . sig n a -> n a) - -> (forall a . Incr () (n a) -> m (Incr () (n a))) - -> (a -> m b) - -> Term sig a - -> n b -iter var alg bound = go - where go :: forall x y . (x -> m y) -> Term sig x -> n y - go free = \case - Var a -> var (free a) - Term t -> alg (foldSyntax go bound free t) - -cata :: Syntax sig - => (a -> b) - -> (forall a . sig (Const b) a -> b) - -> (Incr () b -> a) - -> (x -> a) - -> Term sig x - -> b -cata var alg k h = getConst . iter (coerce var) (Const . alg) (coerce k) (Const . h) - - -interpret :: (Carrier sig m, Member eff sig, Syntax eff) => (forall a . Incr () (m a) -> m (Incr () (m a))) -> (a -> m b) -> Term eff a -> m b -interpret = iter id send