2016-12-09 19:31:13 +03:00
|
|
|
{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
|
2016-12-10 01:32:22 +03:00
|
|
|
module Renderer.SExpression (sExpression, printTerm) where
|
2016-12-09 19:31:13 +03:00
|
|
|
|
|
|
|
import Data.Bifunctor.Join
|
|
|
|
import Data.Foldable
|
|
|
|
import Data.Record
|
2016-12-09 22:30:37 +03:00
|
|
|
import Data.Text hiding (foldr, replicate)
|
2016-12-09 19:31:13 +03:00
|
|
|
import Prologue hiding (toList, intercalate)
|
|
|
|
|
|
|
|
import Category as C
|
|
|
|
import Diff
|
|
|
|
import Renderer
|
|
|
|
import Patch
|
|
|
|
import Info
|
|
|
|
import Syntax
|
|
|
|
import Term
|
|
|
|
|
2016-12-09 22:42:32 +03:00
|
|
|
sExpression :: (HasField fields Category, HasField fields SourceSpan) => Renderer (Record fields)
|
|
|
|
sExpression _ diff = SExpressionOutput $ printDiff diff 0
|
2016-12-09 19:31:13 +03:00
|
|
|
|
2016-12-09 22:30:37 +03:00
|
|
|
printDiff :: (HasField fields Category, HasField fields SourceSpan) => Diff (Syntax Text) (Record fields) -> Int -> Text
|
|
|
|
printDiff diff level = case runFree diff of
|
2016-12-09 20:47:51 +03:00
|
|
|
(Pure patch) -> case patch of
|
2016-12-09 22:30:37 +03:00
|
|
|
Insert term -> pad (level - 1) <> "{+" <> printTerm term level <> "}"
|
|
|
|
Delete term -> pad (level - 1) <> "{-" <> printTerm term level <> "}"
|
|
|
|
Replace a b -> pad (level - 1) <> "{" <> printTerm a level <> "->" <> printTerm b level <> "}"
|
|
|
|
(Free (Join (_, annotation) :< syntax)) -> pad level <> "(" <> showAnnotation annotation <> foldr (\d acc -> printDiff d (level + 1) <> acc) "" syntax <> ")"
|
2016-12-09 20:47:51 +03:00
|
|
|
where
|
2016-12-09 22:30:37 +03:00
|
|
|
pad n | n < 1 = ""
|
2016-12-10 01:47:00 +03:00
|
|
|
| otherwise = "\n" <> mconcat (replicate n " ")
|
2016-12-09 20:47:51 +03:00
|
|
|
|
2016-12-09 22:30:37 +03:00
|
|
|
printTerm :: (HasField fields Category, HasField fields SourceSpan) => Term (Syntax t) (Record fields) -> Int -> Text
|
|
|
|
printTerm term level = go term level 0
|
|
|
|
where
|
2016-12-10 01:47:00 +03:00
|
|
|
pad p n | n < 1 = ""
|
|
|
|
| otherwise = "\n" <> mconcat (replicate (p + n) " ")
|
2016-12-09 22:30:37 +03:00
|
|
|
go term parentLevel level = case runCofree term of
|
|
|
|
(annotation :< Leaf _) -> pad parentLevel level <> "(" <> showAnnotation annotation <> ")"
|
2016-12-10 01:32:22 +03:00
|
|
|
(annotation :< syntax) -> pad parentLevel level <> "(" <> showAnnotation annotation <> foldr (\t acc -> go t parentLevel (level + 1) <> acc) "" syntax <> ")"
|
2016-12-09 20:47:51 +03:00
|
|
|
|
2016-12-09 22:30:37 +03:00
|
|
|
showAnnotation :: (HasField fields Category, HasField fields SourceSpan) => Record fields -> Text
|
|
|
|
showAnnotation annotation = categoryName annotation <> " " <> showSourceSpan annotation
|
|
|
|
where
|
|
|
|
showSourceSpan a = start a <> " - " <> end a
|
|
|
|
start = showPoint . spanStart . getField
|
|
|
|
end = showPoint . spanEnd . getField
|
|
|
|
showPoint SourcePos{..} = "[" <> show line <> ", " <> show column <> "]"
|
|
|
|
|
|
|
|
categoryName :: HasField fields Category => Record fields -> Text
|
|
|
|
categoryName = toS . category
|