wip

.gitignore

@@ -0,0 +1 @@
+dist-newstyle/

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.
+ Но что бы его поддержать, надо его понять.
+
+
+
+

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"
+-}

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"
+
+

lib/Data/Config/Suckless/Types.hs

@@ -0,0 +1 @@
+module Data.Config.Suckless.Types where

suckless-conf.cabal

@@ -13,14 +13,67 @@ build-type:         Simple
 extra-doc-files:    CHANGELOG.md
 -- extra-source-files:
 
-common warnings
+common shared-properties
-    ghc-options: -Wall
+  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
+    import:          shared-properties
-    exposed-modules:  MyLib
+
-    -- other-modules:
+    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
+