github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 08:54:07 +03:00
Code Issues Projects Releases Wiki Activity

Move splice to data, allow config for translation

Browse Source
This commit is contained in:
Timothy Clem 2018-08-17 09:10:14 -07:00
parent 5165d28090
commit b49adc41fe
7 changed files with 86 additions and 182 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
semantic.cabal
View File

@ -96,6 +96,7 @@ library
, Data.Range
, Data.Record
, Data.Reprinting.Token
, Data.Reprinting.Splice
, Data.Semigroup.App
, Data.Scientific.Exts
, Data.Source

28
src/Data/Reprinting/Splice.hs Normal file
View File

@ -0,0 +1,28 @@
module Data.Reprinting.Splice where
import Data.Sequence (singleton)
import Data.String
import Prologue
-- | The simplest possible representation of concrete syntax: either
-- it's a run of literal text or information about whitespace.
data Splice
= Insert Text
| Directive Layout
deriving (Eq, Show)
splice :: Text -> Seq Splice
splice = singleton . Insert
-- | Indentation/spacing directives.
data Layout
= HardWrap Int Indent
| SoftWrap
| Don't
deriving (Eq, Show)
-- | Indentation types. This will eventually be moved into the rules engine.
data Indent = Space | Tab deriving (Eq, Show)
instance IsString Splice where fromString = Insert . fromString

10
src/Data/Reprinting/Token.hs
View File

@ -7,14 +7,18 @@ module Data.Reprinting.Token
) where
import Data.Text (Text)
import Data.Source (Source)
-- language agnostic -> language specific -> formatting whitespace
-- tokenize -> translate -> typeset
-- Seq Token -> Seq Splice -> Doc
-- | 'Token' encapsulates 'Element' and 'Control' tokens, as well as sliced
-- portions of the original 'Source' for a given AST.
data Token
= Chunk Source
| TElement Element
= Chunk Source -- original 'Source' from AST, unmodified by pipeline.
| TElement Element --
| TControl Control
deriving (Show, Eq)

11
src/Language/JSON/Translate.hs
View File

@ -6,8 +6,15 @@ import Data.Reprinting.Token
import Prologue
import Reprinting.Translate
instance Translation 'JSON where
translation _ content context = case (content, context) of
data JSONTypeSetting = JSONTypeSetting { jsonPrettyPrint :: Bool }
deriving (Eq, Show)
prettyJSON :: JSONTypeSetting
prettyJSON = JSONTypeSetting True
instance Translation 'JSON JSONTypeSetting where
translation _ _ content context = case (content, context) of
(Fragment f, _) -> emit f
(Truth t, _) -> emit $ if t then "true" else "false"

5
src/Reprinting/Pipeline.hs
View File

@ -85,9 +85,10 @@ 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 :: forall lang fields a . (Show (Record fields), Tokenize a, HasField fields History, Translation lang)
runReprinter :: forall lang config fields a . (Show (Record fields), Tokenize a, HasField fields History, Translation lang config)
=> Source
-> config
-> Term a (Record fields)
-> Either TranslationException Source
runReprinter s = fmap go . translating @lang . tokenizing s
runReprinter s config = fmap go . translating @lang config . tokenizing s
where go = fromText . renderStrict . layoutPretty defaultLayoutOptions . typeset

205
src/Reprinting/Translate.hs
View File

@ -8,72 +8,73 @@ module Reprinting.Translate
, Splice (..)
, Layout (..)
, Indent (..)
, translating
, translate
, emit
, splice
) where
import Prologue hiding (Element)
import Control.Monad.Effect
import Control.Monad.Effect.Exception (Exc)
import qualified Control.Monad.Effect.Exception as Exc
import Control.Monad.Effect.State
import Control.Monad.Effect.Writer
import Data.Sequence (singleton)
import Data.String
import Lens.Micro
import Data.Language
import Data.Reprinting.Splice
import Data.Reprinting.Token
import Data.Sequence (singleton)
import qualified Data.Source as Source
class Translation (lang :: Language) where
translation :: (Element -> [Context] -> Translator ()) -> Element -> [Context] -> Translator ()
type Translate a = a -> Element -> [Context] -> Translator ()
class Translation (lang :: Language) a where
translation :: Translate a -> Translate a
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 a . (Translation lang a) => a -> Seq Token -> Either TranslationException (Seq Splice)
translating config tokens
= run
. Exc.runError
. fmap fst
. runWriter
. fmap snd
. runState mempty
$ translate @lang tokens
$ traverse_ (translate @lang config) tokens
translate :: forall lang . (Translation lang) => Seq Token -> Translator ()
translate = traverse_ step where
step :: Token -> Translator ()
step t = case t of
Chunk source -> emit (Source.toText source)
TElement content -> get >>= translation @lang defaultTranslation content
TControl ctl -> case ctl of
Log _ -> pure mempty
Enter c -> enterContext c
Exit c -> exitContext c
translate :: forall lang a . (Translation lang a) => a -> Token -> Translator ()
translate config t = case t of
Chunk source -> emit (Source.toText source)
TElement content -> get >>= translation @lang defaultTranslation config content
TControl ctl -> case ctl of
Log _ -> pure mempty
Enter c -> enterContext c
Exit c -> exitContext c
defaultTranslation :: Element -> [Context] -> Translator ()
defaultTranslation content context = case (content, context) of
(Fragment f, _) -> emit f
where
defaultTranslation :: Translate a
defaultTranslation _ content context = case (content, context) of
(Fragment f, _) -> emit f
(Truth t, _) -> emit $ if t then "true" else "false"
(Nullity, _) -> emit "null"
(Truth True, _) -> emit "true"
(Truth False, _) -> emit "false"
(Nullity, _) -> emit "null"
(Open, List:_) -> emit "["
(Open, Associative:_) -> emit "{"
(Open, List:_) -> emit "["
(Open, Associative:_) -> emit "{"
(Close, List:_) -> emit "]"
(Close, Associative:_) -> emit "}"
(Close, List:_) -> emit "]"
(Close, Associative:_) -> emit "}"
(Separator, List:_) -> emit ","
(Separator, Associative:_) -> emit ","
(Separator, Pair:_) -> emit ":"
(Separator, List:_) -> emit ","
(Separator, Associative:_) -> emit ","
(Separator, Pair:_) -> emit ":"
_ -> Exc.throwError (Unexpected "invalid context")
_ -> Exc.throwError (Unexpected "invalid context")
emit :: Text -> Translator ()
emit = tell . splice
@ -89,53 +90,6 @@ exitContext c = do
_ -> Exc.throwError (Unexpected "invalid context")
-- -- | 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
--
-- 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)
-- | Indentation types. This will eventually be moved into the rules engine.
data Indent = Space | Tab deriving (Eq, Show)
-- | Indentation/spacing directives.
data Layout
= HardWrap Int Indent
| SoftWrap
| Don't
deriving (Eq, Show)
-- | The simplest possible representation of concrete syntax: either
-- it's a run of literal text or information about whitespace.
data Splice
= Insert Text
| Directive Layout
deriving (Eq, Show)
splice :: Text -> Seq Splice
splice = singleton . Insert
instance IsString Splice where fromString = Insert . fromString
-- | Represents failure occurring in a 'Concrete' machine.
data TranslationException
= InvalidContext (Maybe Context) Context [Context]
@ -143,94 +97,3 @@ data TranslationException
| Unexpected String
-- ^ 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

8
src/Semantic/Util.hs
View File

@ -208,7 +208,7 @@ testRenameKey = do
pure (toks, tagged)
testRenameKey' = do
res <- translating @'Language.JSON . fst <$> testRenameKey
res <- translating @'Language.JSON prettyJSON . 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))
@ -256,7 +256,7 @@ testAddKVPair = do
pure (toks, tagged)
testAddKVPair' = do
res <- translating @'Language.JSON . fst <$> testAddKVPair
res <- translating @'Language.JSON prettyJSON . fst <$> testAddKVPair
putStrLn (either show (show . typeset) res)
testFloatMatcher = do
@ -291,7 +291,7 @@ testOverwriteFloats = do
pure (toks, tagged)
testOverwriteFloats' = do
res <- translating @'Language.JSON . fst <$> testOverwriteFloats
res <- translating @'Language.JSON prettyJSON . fst <$> testOverwriteFloats
putStrLn (either show (show . typeset) res)
@ -346,5 +346,5 @@ testChangeKV = do
pure (toks, tagged)
testChangeKV' = do
res <- translating @'Language.JSON . fst <$> testChangeKV
res <- translating @'Language.JSON prettyJSON . fst <$> testChangeKV
putStrLn (either show (show . typeset) res)