github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-27 00:44:57 +03:00
Code Issues Projects Releases Wiki Activity

Amazingly it complies! and still prettyprints

Browse Source
This commit is contained in:
Timothy Clem 2018-08-16 17:05:57 -07:00
parent 0cd96954d9
commit 5165d28090
3 changed files with 124 additions and 123 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/Reprinting/Pipeline.hs
View File

@ -67,6 +67,7 @@ stages of the pipeline follows:
-}
{-# LANGUAGE AllowAmbiguousTypes, TypeApplications, ScopedTypeVariables, RankNTypes #-}
module Reprinting.Pipeline ( runReprinter ) where
import Prologue
@ -84,10 +85,9 @@ import Data.Source
-- | Given a 'Proxy' corresponding to the language of the provided
-- 'Term' and the original 'Source' from which the provided 'Term' was
-- passed, run the reprinting pipeline.
runReprinter :: (Show (Record fields), Tokenize a, HasField fields History, Translate lang, Lower (Stack lang))
=> Proxy lang
-> Source
runReprinter :: forall lang fields a . (Show (Record fields), Tokenize a, HasField fields History, Translation lang)
=> Source
-> Term a (Record fields)
-> Either TranslationException Source
runReprinter prox s = fmap go . translating prox . tokenizing s
runReprinter s = fmap go . translating @lang . tokenizing s
where go = fromText . renderStrict . layoutPretty defaultLayoutOptions . typeset

230
src/Reprinting/Translate.hs
View File

@ -2,8 +2,8 @@
ScopedTypeVariables, TupleSections, TypeFamilyDependencies, TypeApplications, TypeOperators #-}
module Reprinting.Translate
( Translate (..)
, Translation (..)
( -- Translate (..)
Translation (..)
, TranslationException (..)
, Splice (..)
, Layout (..)
@ -35,8 +35,8 @@ class Translation (lang :: Language) where
type Translator = Eff '[State [Context], Writer (Seq Splice), Exc TranslationException]
translating' :: forall lang . (Translation lang) => Seq Token -> Either TranslationException (Seq Splice)
translating' tokens
translating :: forall lang . (Translation lang) => Seq Token -> Either TranslationException (Seq Splice)
translating tokens
= run
. Exc.runError
. fmap fst
@ -90,29 +90,29 @@ exitContext c = do
-- | Once the 'Tokenize' algebra has yielded a sequence of tokens,
-- we need to apply per-language interpretation to each token so as to
-- yield language-specific 'Splice's of source code. The 'Translate'
-- typeclass describes a stack machine capable of translating a given
-- a stream of 'Tokens', based on the concrete syntax of the specified
-- language, into concrete-syntax 'Splice's.
-- -- | Once the 'Tokenize' algebra has yielded a sequence of tokens,
-- -- we need to apply per-language interpretation to each token so as to
-- -- yield language-specific 'Splice's of source code. The 'Translate'
-- -- typeclass describes a stack machine capable of translating a given
-- -- a stream of 'Tokens', based on the concrete syntax of the specified
-- -- language, into concrete-syntax 'Splice's.
-- --
-- -- Some possible issues we should tackle before finalizing this design:
-- --
-- -- * Is a stack machine too inexpressive?
-- -- * Is this interface too clumsy? Do we just want to use Eff, or another monad?
-- -- * Do we want to use a generic MonadError rather than instantiate that to Either?
-- -- * @Coassignment@ might be a better name
-- class Translate (lang :: Language) where
--
-- Some possible issues we should tackle before finalizing this design:
-- type Stack lang = s | s -> lang
--
-- * Is a stack machine too inexpressive?
-- * Is this interface too clumsy? Do we just want to use Eff, or another monad?
-- * Do we want to use a generic MonadError rather than instantiate that to Either?
-- * @Coassignment@ might be a better name
class Translate (lang :: Language) where
type Stack lang = s | s -> lang
-- | Each 'Element' data token should emit a chunk of source code,
-- taking into account (but not changing) the state of the stack.
onElement :: Element -> Stack lang -> Either TranslationException (Seq Splice)
-- | Each 'Control' token can (but doesn't have to) change the state of the stack.
onControl :: Control -> Stack lang -> Either TranslationException (Stack lang)
-- -- | Each 'Element' data token should emit a chunk of source code,
-- -- taking into account (but not changing) the state of the stack.
-- onElement :: Element -> Stack lang -> Either TranslationException (Seq Splice)
--
-- -- | Each 'Control' token can (but doesn't have to) change the state of the stack.
-- onControl :: Control -> Stack lang -> Either TranslationException (Stack lang)
-- | Indentation types. This will eventually be moved into the rules engine.
data Indent = Space | Tab deriving (Eq, Show)
@ -144,93 +144,93 @@ data TranslationException
-- ^ Catch-all exception for unexpected tokens.
deriving (Eq, Show)
-- | Run a 'Concrete' machine over each 'Token' in the provided
-- 'Sequence'. Each resulting 'Doc' will be concatenated with
-- 'mconcat'. Pass in an appropriately-kinded 'Proxy' to select how
-- to interpret the language.
translating :: (Translate lang, Lower (Stack lang))
=> Proxy lang
-> Seq Token
-> Either TranslationException (Seq Splice)
translating prox =
run
. Exc.runError
. fmap snd
. runState lowerBound
. fmap fst
. runWriter
. traverse (stepM prox)
-- Private interfaces
newtype JSONState = JSONState
{ _contexts :: [Context]
} deriving (Eq, Show)
contexts :: Lens' JSONState [Context]
contexts = lens _contexts (\s cs -> s { _contexts = cs })
current :: JSONState -> Maybe Context
current s = s ^? contexts._head
instance Lower JSONState where
lowerBound = JSONState []
instance Translate 'JSON where
type Stack 'JSON = JSONState
onControl t st = case t of
Log _ -> pure st
Enter c -> pure (over contexts (c:) st)
Exit c -> let curr = current st in
if curr /= Just c
then throwError (InvalidContext curr c (st ^. contexts))
else pure (over contexts tail st)
onElement c st = let curr = current st in do
case c of
Fragment f -> pure . splice $ f
Truth t -> pure . splice $ if t then "true" else "false"
Nullity -> pure . splice $ "null"
Open -> do
case curr of
Just List -> pure . splice $ "["
Just Associative -> pure ["{", Directive (HardWrap 2 Space)]
x -> throwError (Unexpected (show (Open, x)))
Close -> do
case curr of
Just List -> pure . splice $ "]"
Just Associative -> pure [Directive (HardWrap 0 Space), "}"]
x -> throwError (Unexpected (show (Close, x)))
Separator -> do
let curr = current st
let i = Directive $
case curr of
Just List -> SoftWrap
Just Associative -> HardWrap 2 Space
Just Pair -> SoftWrap
_ -> Don't
case curr of
Just List -> pure [",", i]
Just Associative -> pure [",", i]
Just Pair -> pure [":", i]
Nothing -> pure mempty
ctx -> throwError (Unexpected (show ctx))
-- Distribute 'onControl' and 'onElement' over 'Token', using the
-- obvious case to handle 'Chunk' tokens.
step :: Translate lang => Token -> Stack lang -> Either TranslationException (Seq Splice, Stack lang)
step t st = case t of
Chunk src -> pure (splice . Source.toText $ src, st)
TElement el -> onElement el st >>= \s -> pure (s, st)
TControl ct -> (mempty, ) <$> onControl ct st
-- Kludgy hack to convert 'step' into an effect.
stepM :: forall lang . Translate lang => Proxy lang -> Token -> Eff '[Writer (Seq Splice), State (Stack lang), Exc TranslationException] ()
stepM _ t = do
st <- get @(Stack lang)
case step t st of
Left exc -> Exc.throwError exc
Right (s :: Seq Splice, st) -> tell s *> put st
-- -- | Run a 'Concrete' machine over each 'Token' in the provided
-- -- 'Sequence'. Each resulting 'Doc' will be concatenated with
-- -- 'mconcat'. Pass in an appropriately-kinded 'Proxy' to select how
-- -- to interpret the language.
-- translating :: (Translate lang, Lower (Stack lang))
-- => Proxy lang
-- -> Seq Token
-- -> Either TranslationException (Seq Splice)
-- translating prox =
-- run
-- . Exc.runError
-- . fmap snd
-- . runState lowerBound
-- . fmap fst
-- . runWriter
-- . traverse (stepM prox)
--
-- -- Private interfaces
--
-- newtype JSONState = JSONState
-- { _contexts :: [Context]
-- } deriving (Eq, Show)
--
-- contexts :: Lens' JSONState [Context]
-- contexts = lens _contexts (\s cs -> s { _contexts = cs })
--
-- current :: JSONState -> Maybe Context
-- current s = s ^? contexts._head
--
-- instance Lower JSONState where
-- lowerBound = JSONState []
--
-- instance Translate 'JSON where
-- type Stack 'JSON = JSONState
--
-- onControl t st = case t of
-- Log _ -> pure st
-- Enter c -> pure (over contexts (c:) st)
-- Exit c -> let curr = current st in
-- if curr /= Just c
-- then throwError (InvalidContext curr c (st ^. contexts))
-- else pure (over contexts tail st)
--
-- onElement c st = let curr = current st in do
-- case c of
-- Fragment f -> pure . splice $ f
-- Truth t -> pure . splice $ if t then "true" else "false"
-- Nullity -> pure . splice $ "null"
-- Open -> do
-- case curr of
-- Just List -> pure . splice $ "["
-- Just Associative -> pure ["{", Directive (HardWrap 2 Space)]
-- x -> throwError (Unexpected (show (Open, x)))
-- Close -> do
-- case curr of
-- Just List -> pure . splice $ "]"
-- Just Associative -> pure [Directive (HardWrap 0 Space), "}"]
-- x -> throwError (Unexpected (show (Close, x)))
-- Separator -> do
-- let curr = current st
--
-- let i = Directive $
-- case curr of
-- Just List -> SoftWrap
-- Just Associative -> HardWrap 2 Space
-- Just Pair -> SoftWrap
-- _ -> Don't
--
-- case curr of
-- Just List -> pure [",", i]
-- Just Associative -> pure [",", i]
-- Just Pair -> pure [":", i]
-- Nothing -> pure mempty
-- ctx -> throwError (Unexpected (show ctx))
--
-- -- Distribute 'onControl' and 'onElement' over 'Token', using the
-- -- obvious case to handle 'Chunk' tokens.
-- step :: Translate lang => Token -> Stack lang -> Either TranslationException (Seq Splice, Stack lang)
-- step t st = case t of
-- Chunk src -> pure (splice . Source.toText $ src, st)
-- TElement el -> onElement el st >>= \s -> pure (s, st)
-- TControl ct -> (mempty, ) <$> onControl ct st
--
-- -- Kludgy hack to convert 'step' into an effect.
-- stepM :: forall lang . Translate lang => Proxy lang -> Token -> Eff '[Writer (Seq Splice), State (Stack lang), Exc TranslationException] ()
-- stepM _ t = do
-- st <- get @(Stack lang)
-- case step t st of
-- Left exc -> Exc.throwError exc
-- Right (s :: Seq Splice, st) -> tell s *> put st

9
src/Semantic/Util.hs
View File

@ -55,6 +55,7 @@ import Semantic.Telemetry (LogQueue, StatQueue)
import System.Exit (die)
import System.FilePath.Posix (takeDirectory)
import Text.Show.Pretty (ppShow)
import Language.JSON.Translate
justEvaluating
= runM
@ -207,7 +208,7 @@ testRenameKey = do
pure (toks, tagged)
testRenameKey' = do
res <- translating (Proxy @'Language.JSON) . fst <$> testRenameKey
res <- translating @'Language.JSON . fst <$> testRenameKey
putStrLn (either show (show . typeset) res)
increaseNumbers :: (Literal.Float :< fs, Apply Functor fs) => Term (Sum fs) (Record (History ': fields)) -> Term (Sum fs) (Record (History ': fields))
@ -255,7 +256,7 @@ testAddKVPair = do
pure (toks, tagged)
testAddKVPair' = do
res <- translating (Proxy @'Language.JSON) . fst <$> testAddKVPair
res <- translating @'Language.JSON . fst <$> testAddKVPair
putStrLn (either show (show . typeset) res)
testFloatMatcher = do
@ -290,7 +291,7 @@ testOverwriteFloats = do
pure (toks, tagged)
testOverwriteFloats' = do
res <- translating (Proxy @'Language.JSON) . fst <$> testOverwriteFloats
res <- translating @'Language.JSON . fst <$> testOverwriteFloats
putStrLn (either show (show . typeset) res)
@ -345,5 +346,5 @@ testChangeKV = do
pure (toks, tagged)
testChangeKV' = do
res <- translating (Proxy @'Language.JSON) . fst <$> testChangeKV
res <- translating @'Language.JSON . fst <$> testChangeKV
putStrLn (either show (show . typeset) res)