From b1f2c94eb88ab1952304e09ed3e08adc5f686606 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Tue, 7 Feb 2023 10:08:57 +0300 Subject: [PATCH] wip --- .gitignore | 1 + doc/devlog | 64 ++++++++ lib/Data/Config/Suckless/Parse/Megaparsec.hs | 147 +++++++++++++++++++ lib/Data/Config/Suckless/Syntax.hs | 73 +++++++++ lib/Data/Config/Suckless/Types.hs | 1 + suckless-conf.cabal | 63 +++++++- 6 files changed, 344 insertions(+), 5 deletions(-) create mode 100644 .gitignore create mode 100644 doc/devlog create mode 100644 lib/Data/Config/Suckless/Parse/Megaparsec.hs create mode 100644 lib/Data/Config/Suckless/Syntax.hs create mode 100644 lib/Data/Config/Suckless/Types.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c33954f --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist-newstyle/ diff --git a/doc/devlog b/doc/devlog new file mode 100644 index 0000000..6bb7633 --- /dev/null +++ b/doc/devlog @@ -0,0 +1,64 @@ + +## 2023-02-07 + +Для fixme нам нужны конфиги. Стандартые конфиги это, в основном, треш, +поэтому будем делать новые. Как всегда. + +Конфиги будут sexp, при этом, будут уметь притворяться не sexp. + +поэтому: + +``` +atom term* eol +``` + +единичная инструкция. + +эквивалентна + +``` +( atom term* ) +``` + +выражение конфига: + +``` + +(atom term* ) + +``` + +### term + +``` +term ::= string | number | atom | bool +``` + +Про bool это не точно. + + +### Пример конфига: + +``` +fixme-comments // # ; -- + +; FIXME могут быть в блоках комментариев, +; а могут и нет. + +fixme-prefix FIXME: bug issue + +; комментарий. ^^^^^ ^^^^^^^^^^^^^^^^^^^^^^ +; Префикс Категории для префикса + + +``` + +Как биндить термы на целевой язык? В нашем случае Haskell. + + +FIXME: хорошо бы тут сразу поддержать wisp. + Но что бы его поддержать, надо его понять. + + + + diff --git a/lib/Data/Config/Suckless/Parse/Megaparsec.hs b/lib/Data/Config/Suckless/Parse/Megaparsec.hs new file mode 100644 index 0000000..a3e1667 --- /dev/null +++ b/lib/Data/Config/Suckless/Parse/Megaparsec.hs @@ -0,0 +1,147 @@ +module Data.Config.Suckless.Parse.Megaparsec + where + +import Data.Config.Suckless.Syntax + +import Control.Applicative() + +import Data.Char (showLitChar) +import Data.Text qualified as Text + +import Text.Megaparsec +import Text.Megaparsec.Char (space1,char,letterChar,digitChar) +import Text.Megaparsec.Char.Lexer qualified as L +import Text.Megaparsec.Char.Lexer ( signed ) +import Data.String(IsString(..)) + +import Debug.Trace + +type Parser r = Parsec () [Char] r + +type ParseFail = ParseErrorBundle [Char] () + +sc :: Parser () +sc = do + L.space space1 lineComment empty + where + lineComment = L.skipLineComment ";" + +dquot :: Parser Char +dquot = char '"' + +-- FIXME: position! +stringLit :: Monoid (Context c) => Parser (Syntax c) +stringLit = L.lexeme sc $ + Literal mempty . LitStr <$> str + where + str = do + s <- dquot >> manyTill L.charLiteral dquot + pure $ Text.pack (mconcat [ showLitChar c "" | c <- s ]) + +{- + +-- FIXME: position! +intLit :: Parser Syntax +intLit = L.lexeme sc $ + Literal . LitInt <$> choice [hex, oct, bin, dec, dec'] + where + hex = L.symbol sc "0x" >> L.hexadecimal + oct = L.symbol sc "0o" >> L.octal + bin = L.symbol sc "0b" >> L.binary + dec = L.decimal + dec'= signed sc L.decimal + +symbolChars :: [Char] +symbolChars = "!$%&|*+-/:<=>?@^_~#.'" + +symbolChar :: Parser Char +symbolChar = oneOf symbolChars + +-- FIXME: position! +symbol :: Parser Syntax +symbol = L.lexeme sc $ do + co <- Context . Just <$> getOffset + h <- letterChar <|> symbolChar + t <- many (letterChar <|> digitChar <|> symbolChar) + case Symbol (fromString (h:t)) of + SymbolVal "#t" -> pure $ Literal (mkLit True) + SymbolVal "#f" -> pure $ Literal (mkLit False) + SymbolVal other -> pure (Symbol_ co other) + +skipChar :: Char -> Parser () +skipChar c = void $ char c + +oParen :: Parser () +oParen = skipChar '(' + +cParen :: Parser () +cParen = skipChar ')' + +oBrace :: Parser () +oBrace = skipChar '{' + +cBrace :: Parser () +cBrace = skipChar '}' + +oBracket :: Parser () +oBracket= skipChar '[' + +cBracket :: Parser () +cBracket = skipChar ']' + +someEnclosedBy :: Parser () + -> Parser a + -> Parser () + -> Parser [a] + +someEnclosedBy o i c = do + between o c (many (sc >> i)) -- <|> parseError (error (show ("WTF!", ctx))) -- (ParseError (ListParseError ctx)) + +list :: Parser Syntax +list = L.lexeme sc $ do + co <- Context . Just <$> getOffset + -- traceShowM ("List", co) + List_ co <$> choice [ someEnclosedBy oParen syntax cParen + , someEnclosedBy oBrace syntax cBrace + , someEnclosedBy oBracket syntax cBracket + ] + +syntax :: Parser Syntax +syntax = choice [ symbol + , stringLit + , intLit + , list + ] + +-- top :: Parser (AST (Core S)) +-- top = sc >> many syntaxWithPos >>= toAST +-- where +-- -- FIXME: push real position here +-- syntaxWithPos = do +-- pos <- getOffset +-- node <- (pos,) <$> syntax +-- pure node + +-- toAST xs = go xs + +-- go :: [(Int, Syntax)] -> Parser (AST (Core S)) +-- go ( (p, syn) : rest ) = do +-- let c = Context (Just p) +-- mkExpr c . Seq syn <$> go rest + +-- go [] = pure $ mkLeaf0 () + +-- merely :: Parser a -> Parser a +-- merely f = do +-- sc +-- r <- f +-- sc +-- eof +-- pure r + +-- parseSyntax :: String -> Either ParseFail Syntax +-- parseSyntax = parse (merely syntax) "input" + +-- parseTop :: String -> Either ParseFail (AST (Core S)) +-- parseTop = parse top "input" +-} diff --git a/lib/Data/Config/Suckless/Syntax.hs b/lib/Data/Config/Suckless/Syntax.hs new file mode 100644 index 0000000..6b3938c --- /dev/null +++ b/lib/Data/Config/Suckless/Syntax.hs @@ -0,0 +1,73 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms #-} +module Data.Config.Suckless.Syntax + ( Syntax(..) + , Context(..) + , Id(..) + , Literal(..) + , HasContext(..) + , pattern SymbolVal + ) + where + +import GHC.Generics +import Data.Text (Text) +import Data.Data +import Data.String +import Data.Kind + +import Prettyprinter + +pattern SymbolVal :: Id -> Syntax c +pattern SymbolVal v <- Symbol _ v + +data family Context c :: Type + +class HasContext c a where + setContext :: Context c -> a -> a + getContext :: a -> Context c + +newtype Id = + Id Text + deriving newtype (IsString,Pretty) + deriving stock (Data,Generic,Show,Eq,Ord) + +data Literal = + LitStr Text + | LitInt Integer + | LitBool Bool + deriving stock (Eq,Ord,Data,Generic,Show) + +data Syntax c + = List (Context c) [Syntax c] + | Symbol (Context c) Id + | Literal (Context c) Literal + deriving stock (Generic) + +instance HasContext c (Syntax c) where + setContext c1 = \case + List _ v -> List c1 v + Symbol _ v -> Symbol c1 v + Literal _ v -> Literal c1 v + + getContext = \case + List x _ -> x + Symbol x _ -> x + Literal x _ -> x + +instance Pretty (Syntax c) where + pretty (Literal _ ast) = pretty ast + pretty (Symbol _ s) = pretty s + pretty (List _ (x:xs)) = parens $ align $ sep ( fmap pretty (x:xs) ) + pretty (List _ []) = parens mempty + +instance Pretty Literal where + pretty = \case + LitStr s -> dquotes (pretty s) + LitInt i -> pretty i + + LitBool b | b -> "#t" + | otherwise -> "#f" + + diff --git a/lib/Data/Config/Suckless/Types.hs b/lib/Data/Config/Suckless/Types.hs new file mode 100644 index 0000000..8efe212 --- /dev/null +++ b/lib/Data/Config/Suckless/Types.hs @@ -0,0 +1 @@ +module Data.Config.Suckless.Types where \ No newline at end of file diff --git a/suckless-conf.cabal b/suckless-conf.cabal index a91675f..3807aea 100644 --- a/suckless-conf.cabal +++ b/suckless-conf.cabal @@ -13,14 +13,67 @@ build-type: Simple extra-doc-files: CHANGELOG.md -- extra-source-files: -common warnings - ghc-options: -Wall +common shared-properties + ghc-options: + -Wall + -- -fno-warn-unused-matches + -- -fno-warn-unused-do-bind + -- -Werror=missing-methods + -- -Werror=incomplete-patterns + -- -fno-warn-unused-binds + -- -threaded + -- -rtsopts + -- "-with-rtsopts=-N4 -A64m -AL256m -I0" + + + default-language: Haskell2010 + + default-extensions: + ApplicativeDo + , BangPatterns + , BlockArguments + , ConstraintKinds + , DataKinds + , DeriveDataTypeable + , DeriveGeneric + , DerivingStrategies + , DerivingVia + , ExtendedDefaultRules + , FlexibleContexts + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , ImportQualifiedPost + , LambdaCase + , MultiParamTypeClasses + , OverloadedStrings + , QuasiQuotes + , ScopedTypeVariables + , StandaloneDeriving + , TupleSections + , TypeApplications + , TypeFamilies + + library - import: warnings - exposed-modules: MyLib - -- other-modules: + import: shared-properties + + exposed-modules: + Data.Config.Suckless.Syntax + + other-modules: + Data.Config.Suckless.Types + , Data.Config.Suckless.Parse.Megaparsec + -- other-extensions: build-depends: base ^>=4.15.1.0 + , bytestring + , containers + , megaparsec + , prettyprinter + , text + hs-source-dirs: lib default-language: Haskell2010 +