diff --git a/lib/Data/Config/Suckless/Parse/Megaparsec.hs b/lib/Data/Config/Suckless/Parse/Megaparsec.hs index a3e1667..da433f7 100644 --- a/lib/Data/Config/Suckless/Parse/Megaparsec.hs +++ b/lib/Data/Config/Suckless/Parse/Megaparsec.hs @@ -1,4 +1,10 @@ +{-# Language ConstraintKinds #-} module Data.Config.Suckless.Parse.Megaparsec + ( parseSyntax + , parseTop + , MegaParsec + , MegaContext + ) where import Data.Config.Suckless.Syntax @@ -8,13 +14,27 @@ import Control.Applicative() import Data.Char (showLitChar) import Data.Text qualified as Text +import Control.Monad import Text.Megaparsec -import Text.Megaparsec.Char (space1,char,letterChar,digitChar) +import Text.Megaparsec.Char (hspace1,space1,char,letterChar,digitChar,eol) import Text.Megaparsec.Char.Lexer qualified as L import Text.Megaparsec.Char.Lexer ( signed ) import Data.String(IsString(..)) +import GHC.Generics +import Data.Data -import Debug.Trace +data MegaParsec = + MegaParsec + deriving (Data,Typeable,Generic) + +newtype instance Context MegaParsec = MegaContext (Maybe Int) + +instance IsContext MegaParsec where + noContext = MegaContext Nothing + +type MegaContext = Context MegaParsec + +type MegaConstraints c = ( c ~ MegaParsec, IsContext c ) type Parser r = Parsec () [Char] r @@ -26,24 +46,34 @@ sc = do where lineComment = L.skipLineComment ";" +scTop :: Parser () +scTop = do + L.space hspace1 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 +stringLit :: forall c . MegaConstraints c + => Parser () -> Parser (Syntax c) + +stringLit sp = L.lexeme sp $ do + co <- MegaContext . Just <$> getOffset + Literal co . 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'] +intLit :: forall c . MegaConstraints c + => Parser () -> Parser (Syntax c) + +intLit sp = L.lexeme sp $ do + co <- MegaContext . Just <$> getOffset + Literal co . LitInt <$> choice [hex, oct, bin, dec, dec'] where hex = L.symbol sc "0x" >> L.hexadecimal oct = L.symbol sc "0o" >> L.octal @@ -58,18 +88,20 @@ symbolChar :: Parser Char symbolChar = oneOf symbolChars -- FIXME: position! -symbol :: Parser Syntax -symbol = L.lexeme sc $ do - co <- Context . Just <$> getOffset +symbol :: forall c . MegaConstraints c + => Parser () -> Parser (Syntax c) +symbol sp = L.lexeme sp $ do + co <- MegaContext . 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) + case h:t of + "#t" -> pure $ Literal co (mkLit True) + "#f" -> pure $ Literal co (mkLit False) + other -> pure $ Symbol co (fromString other) + skipChar :: Char -> Parser () -skipChar c = void $ char c +skipChar c = void (char c) oParen :: Parser () oParen = skipChar '(' @@ -97,51 +129,54 @@ someEnclosedBy :: Parser () 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 - ] +list :: forall c . MegaConstraints c + => Parser() -> Parser (Syntax c) -syntax :: Parser Syntax -syntax = choice [ symbol - , stringLit - , intLit - , list - ] +list sp = L.lexeme sp $ do + co <- MegaContext . Just <$> getOffset + List co <$> choice [ someEnclosedBy oParen (syntax sp) cParen + , someEnclosedBy oBrace (syntax sp) cBrace + , someEnclosedBy oBracket (syntax sp) cBracket + ] --- 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 +syntax :: forall c . MegaConstraints c + => Parser () -> Parser (Syntax c) +syntax sp = choice [ symbol sp + , stringLit sp + , intLit sp + , list sp + ] --- toAST xs = go xs +merely :: Parser a -> Parser a +merely f = do + sc + r <- f + sc + eof + pure r --- go :: [(Int, Syntax)] -> Parser (AST (Core S)) --- go ( (p, syn) : rest ) = do --- let c = Context (Just p) --- mkExpr c . Seq syn <$> go rest +parseSyntax :: forall c . MegaConstraints c + => String -> Either ParseFail (Syntax c) --- go [] = pure $ mkLeaf0 () +parseSyntax = parse (merely (syntax sc)) "input" --- merely :: Parser a -> Parser a --- merely f = do --- sc --- r <- f --- sc --- eof --- pure r +top :: forall c . MegaConstraints c => Parser [Syntax c] +top = sc >> many (topStmt <|> syntax scTop) --- parseSyntax :: String -> Either ParseFail Syntax --- parseSyntax = parse (merely syntax) "input" +topStmt :: forall c . MegaConstraints c => Parser (Syntax c) +topStmt = do + scTop + + co <- MegaContext . Just <$> getOffset + + s0 <- symbol scTop + ss <- many (syntax scTop) + + void eol <|> eof + pure $ List co (s0:ss) + +parseTop :: forall c . MegaConstraints c + => String -> Either ParseFail [Syntax c] + +parseTop = parse top "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 index 6b3938c..d556c3c 100644 --- a/lib/Data/Config/Suckless/Syntax.hs +++ b/lib/Data/Config/Suckless/Syntax.hs @@ -1,33 +1,51 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE PatternSynonyms #-} module Data.Config.Suckless.Syntax ( Syntax(..) - , Context(..) , Id(..) , Literal(..) + , Context , HasContext(..) + , IsContext(..) + , IsLiteral(..) , pattern SymbolVal + , pattern ListVal + , pattern LitVal ) where -import GHC.Generics -import Data.Text (Text) import Data.Data -import Data.String import Data.Kind +import Data.String +import Data.Text (Text) +import GHC.Generics import Prettyprinter pattern SymbolVal :: Id -> Syntax c pattern SymbolVal v <- Symbol _ v -data family Context c :: Type +pattern LitVal :: forall {c}. Id -> Syntax c +pattern LitVal v <- Symbol _ v + +pattern ListVal :: forall {c}. [Syntax c] -> Syntax c +pattern ListVal v <- List _ v + + +data family Context c :: Type + +class IsContext c where + noContext :: Context c class HasContext c a where setContext :: Context c -> a -> a getContext :: a -> Context c +class IsLiteral a where + mkLit :: a -> Literal + newtype Id = Id Text deriving newtype (IsString,Pretty) @@ -39,6 +57,15 @@ data Literal = | LitBool Bool deriving stock (Eq,Ord,Data,Generic,Show) +instance IsLiteral Text where + mkLit = LitStr + +instance IsLiteral Bool where + mkLit = LitBool + +instance IsLiteral Integer where + mkLit = LitInt + data Syntax c = List (Context c) [Syntax c] | Symbol (Context c) Id @@ -71,3 +98,9 @@ instance Pretty Literal where | otherwise -> "#f" +deriving instance ( Data c + , Data (Context c) + , Typeable c + ) => Data (Syntax c) + + diff --git a/lib/MyLib.hs b/lib/MyLib.hs deleted file mode 100644 index e657c44..0000000 --- a/lib/MyLib.hs +++ /dev/null @@ -1,4 +0,0 @@ -module MyLib (someFunc) where - -someFunc :: IO () -someFunc = putStrLn "someFunc"