From b705bbb81718d0f246a171181622fc90b796377a Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Wed, 30 Aug 2017 01:20:21 +0200 Subject: [PATCH 1/1] init --- Language/TCT.hs | 180 +++++++++++++++++++++++++++++++++++++++++ vim/syntax/tct.vim | 196 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 376 insertions(+) create mode 100644 Language/TCT.hs create mode 100644 vim/syntax/tct.vim diff --git a/Language/TCT.hs b/Language/TCT.hs new file mode 100644 index 0000000..2b6cd70 --- /dev/null +++ b/Language/TCT.hs @@ -0,0 +1,180 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +module Language.TCT where + +import Data.Bool +import Control.Applicative (Applicative(..), Alternative(..)) +import qualified Data.Char as Char +import qualified Data.List as List +import Data.Semigroup ((<>)) +-- import Data.Tuple (fst,snd) +import Data.Maybe (Maybe(..)) +import Data.Ord (Ordering(..), Ord(..)) +import Data.Function (($), (.)) +import Data.Functor ((<$>)) +import Control.Monad (Monad(..)) +import Data.Eq (Eq(..)) +import Data.Text (Text) +import qualified Data.Text as T +import Text.Show (Show(..)) +import Data.String (String) +import Text.Megaparsec.Text +import Prelude (undefined, Int, Num(..), toInteger) +import qualified Text.Megaparsec as P + +import Data.Tree +import Debug.Trace () + +trac :: String -> a -> a +trac _m x = x + +dbg :: Show a => String -> a -> a +dbg m x = trac (m <> ": " <> show x) x + +pdbg :: (Show a, P.ShowErrorComponent e, P.ShowToken (P.Token s), P.Stream s) => String -> P.ParsecT e s m a -> P.ParsecT e s m a +pdbg m p = P.dbg m p + +column :: Parser Col +column = fromInteger . toInteger . P.unPos . P.sourceColumn <$> P.getPosition + +type Col = Int +type Name = Text +data Token = Key Key + | Value Text + deriving (Eq, Show) +data Key = Great Name + | Equal Name + | Colon Name + | Bar Name + | Dash + | Section Int Value + deriving (Eq, Show) +data Value = Verbatim Text + | Tag Text + | Decoration Decoration Value + deriving (Eq, Show) +data Decoration = Bold + | Italic + | Underline + | Crossed + | Code + deriving (Eq, Show) + +appendRow :: + [(Col,Tree Token)] -> -- ^ parents, from closed to farest (non-strictly descending) + [(Col,Token)] -> -- ^ next row, from leftest column to rightest (non-stricly ascending) + [(Col,Tree Token)] -- ^ new parents +appendRow [] row = ((`Node` []) <$>) <$> List.reverse row +appendRow parents [] = parents +appendRow ps@((colParent,parent@(Node tokParent nodesParent)):parents) + rs@((colRow,tokRow):rows) = + trac ("appendRow: ps=" <> show ps) $ + trac ("appendRow: rs=" <> show rs) $ + dbg "appendRow" $ + case dbg "colParent" colParent`compare`dbg "colRow" colRow of + LT -> lt + EQ -> + case (dbg "tokParent" tokParent,dbg "tokRow" tokRow) of + (Value p, Value r) -> appendRow ((colRow, Node tok nodesParent) : parents) rows + where tok = Value $ p <> T.singleton '\n' <> padding colParent colRow <> r + padding x y = T.replicate (fromInteger $ toInteger $ y - x) (T.singleton ' ') + (_, Key (Section sectionRow _)) | Just (sectionParent, sp:pars) <- collapseSection colRow ps -> + case dbg "sectionParent" sectionParent`compare`dbg "sectionRow" sectionRow of + LT -> appendRow ((colRow,Node tokRow []):sp:pars) rows + EQ -> appendRow ((colRow,Node tokRow []):insertChild sp pars) rows + GT -> gt + (Key (Section{}), Value{}) -> lt + (Key (Section{}), Key{}) -> lt + (Value{}, Key{}) -> eq + (Key{}, Key{}) -> eq + (Key{}, Value{}) -> eq + GT -> gt + where + lt = appendRow [] rs <> ps + eq = appendRow ((colRow,Node tokRow []):insertChild (colParent,parent) parents) rows + gt = appendRow (insertChild (colParent,parent) parents) rs + -- | Find the first section (if any), returning its level, and the path collpased upto it. + collapseSection :: Col -> [(Col,Tree Token)] -> Maybe (Int,[(Col,Tree Token)]) + collapseSection col pars@((c,x):xs) | c==col = + case x of + Node (Key (Section s _)) _ -> Just (s,pars) + _ -> (\(s,cs) -> (s,insertChild (c,x) cs)) <$> collapseSection col xs + collapseSection _ _ = Nothing + +insertChild :: (Col,Tree Token) -> [(Col,Tree Token)] -> [(Col,Tree Token)] +insertChild c ps@[] = + trac ("insertChild: c="<>show c) $ + trac ("insertChild: ps="<>show ps) $ + dbg "insertChild" $ + [c] +insertChild c@(colChild,child) ps@((colParent,Node tokParent nodesParent):parents) = + trac ("insertChild: c="<>show c) $ + trac ("insertChild: ps="<>show ps) $ + dbg "insertChild" $ + case dbg "colParent" colParent`compare`dbg "colChild" colChild of + LT -> (colParent,Node tokParent (nodesParent <> [child])) : parents + EQ -> (colParent,Node tokParent (nodesParent <> [child])) : parents + GT -> undefined + +collapsePath :: [(Col,Tree Token)] -> Tree Token +collapsePath [] = undefined +collapsePath [(_,child)] = dbg "collapsePath" $ child +collapsePath (child:parents) = dbg "collapsePath" $ collapsePath $ insertChild child parents + +p_Row :: [(Col,Token)] -> Parser [(Col,Token)] +p_Row path = pdbg "Path" $ do + P.skipMany $ P.char ' ' + P.try p_Key <|> p_Value path + where + p_Key = do + colKey <- column + P.choice + [ P.string "- " >> + P.try (p_Row ((colKey,Key Dash):path)) <|> + p_Value ((colKey,Key Dash):path) + , P.try $ do + hs <- List.length <$> P.some (P.char '#') <* P.char ' ' + v <- p_line + p_Value $ (colKey,Key $ Section hs $ Verbatim v):path + , do + name <- T.pack <$> some (P.satisfy $ \c -> Char.isAlphaNum c || c=='-' || c=='_') + P.choice + [ P.char ':' >> + P.try (p_Row ((colKey,Key $ Colon name):path)) <|> + p_Value ((colKey,Key $ Colon name):path) + , P.char '>' >> + P.try (p_Row ((colKey,Key $ Great name):path)) <|> + p_Value ((colKey,Key $ Great name):path) + , P.char '=' >> p_Value ((colKey,Key $ Equal name):path) + , P.char '|' >> p_Value ((colKey,Key $ Bar name):path) + ] + ] + p_Value pth = pdbg "Value" $ do + colValue <- column + P.option pth . P.try $ do + (\v -> (colValue, Value v) : pth) + <$> p_line + p_line = T.pack <$> some (P.notFollowedBy (P.newline) *> P.anyChar) + +p_TCT :: Parser [Tree Token] +p_TCT = do + tree <- collapsePath <$> go [(0,Node (Value T.empty) [])] + return $ + case tree of + Node (Value v) roots | T.null v -> roots + _ -> undefined + where + go :: [(Col,Tree Token)] -> Parser [(Col,Tree Token)] + go acc = pdbg "go" $ do + P.skipMany $ P.char ' ' <|> P.char '\n' + p_Row [] >>= \case + [] -> return acc + row -> go $ appendRow acc (List.reverse row) + +parser :: Parser [Tree Token] +parser = p_TCT <* P.eof diff --git a/vim/syntax/tct.vim b/vim/syntax/tct.vim new file mode 100644 index 0000000..9468b53 --- /dev/null +++ b/vim/syntax/tct.vim @@ -0,0 +1,196 @@ +" Language: Texte Convivial Technique (TCT) +" License: GNU General Public License, version 3 or later (at your option) +" Maintainer: Julien Moutinho +" URL: http://autogeree.net/pad/edition/tct/ +" Version: v2017-08-24 +" Installation: +" Copy this file to ~/.vim/syntax/tct.vim +" then add this line to ~/.vimrc : +" autocmd BufNewFile,BufRead *.tct set filetype=tct + +if exists("b:current_syntax") + finish + endif + +syn clear +syn sync fromstart +syn sync linebreaks=1 + +" Default +syn match tctPlain /.\+/ contains=@tctInline +hi def link tctPlain Normal + +" Block +syn match tctPath /^\( *\([^<>:=| ]*[:>]\|- \|\( *\d\+\.\)\+\)\)* *\ze\([^<>:=| ]*[>:=|@]\|-- \|- \|\( *\d\+\.\)\+\|#\+ \)/ + \ contains=tctNodeBird,tctNodeColon,tctNodeComment,tctNodeUL,tctNodeOL + \ nextgroup=@tctKeyPath +syn cluster tctKeyPath + \ contains=tctKeyAt,tctKeyBird,tctKeyColon,tctKeyEqual,tctKeyBar,tctKeyComment,tctKeyUL,tctKeyOL,tctKeySection +syn match tctKeyAt /[^<>:=| ]*@/ contained contains=tctNodeAt nextgroup=tctValueAt +syn match tctKeyBar /[^<>:=| ]*|/ contained contains=tctNodeBar nextgroup=tctValueBar +syn match tctKeyBird /[^<>:=| ]*>/ contained contains=tctNodeBird nextgroup=tctValueBird +syn match tctKeyColon /[^<>:=| ]*:/ contained contains=tctNodeColon nextgroup=tctValueColon +syn match tctKeyEqual /[^<>:=| ]*=/ contained contains=tctNodeEqual nextgroup=tctValueEqual +syn match tctKeyComment /-- / contained contains=tctNodeComment nextgroup=tctValueComment +syn match tctKeyUL /-\ze / contained contains=tctNodeUL nextgroup=tctValueUL +syn match tctKeyOL /\( *\d\+\.\)\+ / contained contains=tctNodeOL nextgroup=tctValueOL +syn match tctKeySection /#\+\ze / contained contains=tctNodeSection nextgroup=tctValueSection + +syn match tctNodeAt /[^<>:=| ]*@/ contained contains=tctSymAt,tctSymDot +syn match tctNodeBar /[^<>:=| ]*|/ contained contains=tctSymBar,tctSymDot +syn match tctNodeBird /[^<>:=| ]*>/ contained contains=tctSymBird,tctSymDot +syn match tctNodeColon /[^<>:=| ]*:/ contained contains=tctSymColon,@tctColons,tctSymDot +syn match tctNodeEqual /[^<>:=| ]*=/ contained contains=tctSymEqual,tctSymDot +syn match tctNodeComment /--/ contained +syn match tctNodeUL /-/ contained +syn match tctNodeOL /\( *\d\+\.\)\+/ contained contains=tctSymDot +syn match tctNodeSection /#\+/ contained + +syn match tctSymAt /@/ contained +syn match tctSymBar /|/ contained +syn match tctSymBird />/ contained +syn match tctSymColon /:/ contained +syn match tctSymDot /[.]/ contained +syn match tctSymEqual /=/ contained + +syn match tctValueAt /.*/ contained contains=@tctURL +syn match tctValueBar /.*/ contained +syn match tctValueBird /.*/ contained contains=@tctInline +syn match tctValueColon /.*/ contained contains=@tctInline +syn match tctValueEqual /.*/ contained contains=@tctInline +syn match tctValueComment /.*/ contained +syn match tctValueUL /.*/ contained contains=@tctInline +syn match tctValueOL /.*/ contained contains=@tctInline +syn match tctValueSection /.*/ contained contains=@tctInline + +"syn match tctSection /^ *#\+ .*/ contains=@tctInline + + +hi tctNodeAt cterm=NONE ctermfg=yellow guifg=yellow +hi tctNodeBar cterm=NONE ctermfg=DarkYellow guifg=yellow +hi tctNodeBird cterm=NONE ctermfg=DarkYellow guifg=yellow +hi tctNodeColon cterm=bold ctermfg=yellow guifg=yellow +hi tctNodeEqual cterm=bold ctermfg=DarkGrey guifg=yellow +hi tctNodeComment cterm=bold ctermfg=DarkGrey guifg=grey +hi tctNodeUL cterm=bold ctermfg=yellow guifg=yellow +hi tctNodeOL cterm=bold ctermfg=yellow guifg=yellow +hi tctNodeSection cterm=bold ctermfg=magenta guifg=magenta gui=bold + +hi tctSymAt cterm=bold ctermfg=cyan guifg=cyan +hi tctSymBar cterm=bold ctermfg=cyan guifg=cyan +hi tctSymBird cterm=bold ctermfg=cyan guifg=cyan +hi tctSymColon cterm=bold ctermfg=cyan guifg=cyan +hi tctSymDot cterm=bold ctermfg=DarkGrey guifg=grey +hi tctSymEqual cterm=bold ctermfg=cyan guifg=cyan + +hi tctValueAt cterm=bold gui=bold +hi def link tctValueBar Normal +hi tctValueColon cterm=bold gui=bold +hi tctValueBird cterm=NONE gui=NONE +hi tctValueEqual cterm=NONE gui=NONE +hi tctValueComment ctermfg=DarkGrey cterm=bold gui=NONE guifg=grey +hi tctValueUL cterm=NONE gui=NONE +hi tctValueOL cterm=NONE gui=NONE + +hi tctComment cterm=bold ctermfg=DarkGrey guifg=grey +hi tctKeySection cterm=bold ctermfg=magenta guifg=magenta gui=bold +hi tctValueSection cterm=bold ctermfg=magenta guifg=magenta gui=bold + + +" Semantic node names, these are not necessary but improves the view. +syn cluster tctColons contains=tctColonDONE,tctColonSOLVED,tctColonTODO +syn match tctColonDONE /\]\+\/\?>/ + \ contained contains=tctESym,tctEAttr +syn match tctESym + \ /[]/ + \ contained +syn match tctEAttr + \ / [^=]\+="[^"]*"/ + \ contained +syn match tctQuoteFrench + \ /«.\{-}»/ + \ contained contains=@tctInline +syn match tctItalic + \ /\(^\|[ *`«»"'’|_,.:;@^!?=~<>%(){}[\]\\#&+-]\)\zs\/[^ /]\([^/]*[^ /]\)\?\/\ze\([ *`«»"'’|_,.:;@^!?=~<>%(){}[\]\\#&+-]\|$\)/ + \ contained contains=@tctInline +syn match tctQuote + \ /\(^\|[ *`«»/'’|_,.:;@^!?=~<>%(){}[\]\\#&+-]\)\zs"[^ "]\([^"]*[^ "]\)\?"\ze\([ *`«»/'’|_,.:;@^!?=~<>%(){}[\]\\#&+-]\|$\)/ + \ contained contains=@tctInline +syn match tctRef + \ /\(^\|[ *`«»/"'’|_,.:;@^!?=~<>%(){}[\]\&+-]\)\zs#\([^ #]\([^#]*[^ #]\)\?#\|[^ #]*[^# *`«»/"'’|_,.:;@^!?=~<>%(){}[\]\&+-]\)\ze\([ *`«»/"'’|_,.:;@^!?=~<>%(){}[\]\&+-]\|$\)/ + \ contained contains=@tctInline +syn match tctUnderline + \ /\(^\|[ *`«»/"'’|,.:;@!?=~<>%(){}[\]\\#&+-]\)\zs_.*_\ze\([ *`«»/"'’|,.:;@!?=~<>%(){}[\]\\#&+-]\|$\)/ + \ contained contains=@tctInline +syn match tctURL + \ /[a-z+-]\+:\/\/[^| \t[\]]*\(\[[^\]]*\]\)\?/ + \ contained contains=tctURLText +syn match tctURLText + \ /\(\[\zs[^\]]*\ze\]\)\?/ + \ contained contains=@tctInline +syn match tctEntity "&[^; \t]*;" contained contains=tctEntityPunct +syn match tctEntityPunct contained "[&.;]" +syn region tctElem + \ matchgroup=tctElem start=/<\ze[^ /!?<>"']/ + \ matchgroup=tctElem end=/>/ + \ contained contains=tctElemName,tctAttr,tctSymEqual,tctAttrValue +syn region tctElemEnd + \ matchgroup=tctElem start=/<\/\ze[^ /!?<>"']/ + \ matchgroup=tctElem end=/>/ + \ contained contains=tctElemName,tctAttrPunct +syn match tctNamespace + \ +\(<\|"':]\+\ze[:]+ + \ contained +syn match tctElemName + \ /\(<\|<\/\)\@2<=[^ /!?<>"']\+/ + \ contained contains=tctNamespace,tctAttrPunct +syn match tctAttr + \ +[-'"<]\@1\%(['">]\@!\|$\)+ + \ contained contains=tctAttrPunct +syn match tctAttrPunct +[:.]+ contained +syn region tctAttrValue contained start=+"+ end=+"+ contains=tctEntity +syn region tctAttrValue contained start=+'+ end=+'+ contains=tctEntity + + +syn cluster tctInline contains=tctBold,tctCode,tctElem,tctElemEnd,tctEntity,tctQuoteFrench,tctItalic,tctQuote,tctRef,tctUnderline,tctURL + + +hi def link tctAttr Type +hi def link tctAttrPunct Comment +hi tctBold cterm=bold gui=bold +hi tctCode cterm=reverse ctermfg=white gui=reverse +hi tctESym cterm=bold ctermfg=cyan guifg=cyan +hi def link tctEntity Statement +hi def link tctEntityPunct Type +hi tctItalic cterm=italic gui=italic +hi def link tctNamespace Tag +hi tctQuote cterm=bold ctermfg=cyan guifg=cyan +hi tctQuoteFrench cterm=bold ctermfg=green guifg=green +hi tctRef cterm=bold ctermfg=cyan guifg=cyan +hi def link tctElem Function +hi def link tctElemEnd Identifier +hi tctElemName cterm=bold ctermfg=yellow guifg=yellow +hi def link tctAttrValue String +hi def link tctTodo Todo +hi def link tctURL Macro +hi def link tctURLText tctNormal +hi tctUnderline cterm=underline gui=underline + +let b:current_syntax = "tct" -- 2.44.1