somehow

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)
+
+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
                      ]
 
-syntax :: Parser Syntax
-syntax = choice [ symbol
-                , stringLit
-                , intLit
-                , list
+syntax :: forall c . MegaConstraints c
+      => Parser () -> Parser (Syntax c)
+syntax sp = choice [ symbol sp
+                   , stringLit sp
+                   , intLit sp
+                   , list sp
                    ]
 
--- 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
+merely :: Parser a -> Parser a
+merely f = do
+  sc
+  r <- f
+  sc
+  eof
+  pure r
 
---     toAST xs = go xs
+parseSyntax :: forall c . MegaConstraints c
+            => String -> Either ParseFail (Syntax c)
 
---     go :: [(Int, Syntax)] -> Parser (AST (Core S))
---     go ( (p, syn) : rest ) = do
---       let c = Context (Just p)
---       mkExpr c . Seq syn <$> go rest
+parseSyntax = parse (merely (syntax sc)) "input"
 
---     go [] = pure $ mkLeaf0 ()
+top :: forall c . MegaConstraints c => Parser [Syntax c]
+top = sc >> many (topStmt <|> syntax scTop)
 
--- merely :: Parser a -> Parser a
--- merely f = do
---   sc
---   r <- f
---   sc
---   eof
---   pure r
+topStmt :: forall c . MegaConstraints c => Parser (Syntax c)
+topStmt = do
+  scTop
 
--- parseSyntax :: String -> Either ParseFail Syntax
--- parseSyntax = parse (merely syntax) "input"
+  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"
--}

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

lib/MyLib.hs

@@ -1,4 +0,0 @@
-module MyLib (someFunc) where
-
-someFunc :: IO ()
-someFunc = putStrLn "someFunc"