4:00 AM psychopath code

rlp.cabal

@@ -30,6 +30,8 @@ library
                     , Core.TH
                     , Core.HindleyMilner
                     , Control.Monad.Errorful
+                    , Rlp.Syntax
+                    , Rlp.ParseDecls
 
     other-modules:    Data.Heap
                     , Data.Pretty
@@ -37,7 +39,6 @@ library
                     , Core.Lex
                     , Core2Core
                     , Control.Monad.Utils
-                    , RLP.Syntax
 
     build-tool-depends: happy:happy, alex:alex
 

src/RLP/ParseDecls.hs

@@ -0,0 +1,139 @@
+-- Show Y
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Rlp.ParseDecls
+    (
+    )
+    where
+----------------------------------------------------------------------------------
+import Rlp.Syntax
+import Text.Megaparsec              hiding (State)
+import Text.Megaparsec.Char
+import Text.Megaparsec.Char.Lexer   qualified as L
+import Data.Functor.Const
+import Data.Text                    (Text)
+import Data.Text                    qualified as T
+import Data.Void
+import Data.Char
+import Data.Functor
+import Data.HashMap.Strict          qualified as H
+import Control.Monad
+import Core.Syntax
+import Control.Monad.State
+----------------------------------------------------------------------------------
+
+type Parser = ParsecT Void Text (State ParserState)
+
+data ParserState = ParserState
+    { _psPrecTable :: PrecTable
+    }
+    deriving Show
+
+type PrecTable = H.HashMap Name (Assoc, Int)
+
+----------------------------------------------------------------------------------
+
+parseTest' :: (Show a) => Parser a -> Text -> IO ()
+parseTest' p s = case runState (runParserT p "test" s) init of
+    (Left e, _)   -> putStr (errorBundlePretty e)
+    (Right x, st) -> print st *> print x
+    where
+        init = ParserState mempty
+
+lexeme :: Parser a -> Parser a
+lexeme = L.lexeme sc
+
+symbol :: Text -> Parser Text
+symbol = L.symbol sc
+
+sc :: Parser ()
+sc = L.space space1 (void lineComment) (void blockComment)
+
+-- TODO: return comment text
+-- TODO: '---' should not start a comment
+lineComment :: Parser Text
+lineComment = L.skipLineComment "--" $> "<unimpl>"
+
+-- TODO: return comment text
+blockComment :: Parser Text
+blockComment = L.skipBlockCommentNested "{-" "-}" $> "<unimpl>"
+
+decl :: Parser PartialDecl'
+decl = choice
+    [ funD
+    , tySigD
+    , dataD
+    , infixD
+    ]
+
+funD :: Parser PartialDecl'
+funD = FunD <$> varid <*> many pat1 <*> (symbol "=" *> fmap Const partialExpr)
+
+partialExpr :: Parser PartialExpr'
+partialExpr = choice
+    [ fmap Y $ U <$> varid' <*> lexeme infixOp <*> varid'
+    ]
+    where varid' = E . VarEF <$> varid
+
+
+infixOp :: Parser Name
+infixOp = symvar <|> symcon
+
+symvar :: Parser Name
+symvar = T.pack <$>
+    liftA2 (:) (satisfy isVarSym) (many $ satisfy isSym)
+
+symcon :: Parser Name
+symcon = T.pack <$>
+    liftA2 (:) (char ':') (many $ satisfy isSym)
+
+-- partialExpr :: Parser (Const Text a)
+-- partialExpr = fmap Const $ L.lineFold w $ \w' ->
+--     try w' <> w
+--     where
+--         w = L.space eat (void lineComment) (void blockComment)
+--         eat = void . some $ satisfy (not . isSpace)
+
+pat1 :: Parser Pat'
+pat1 = VarP <$> varid
+
+varid :: Parser VarId
+varid = NameVar <$> lexeme namevar
+    <|> SymVar <$> lexeme (char '(' *> symvar <* char ')')
+    <?> "variable identifier"
+    where
+        namevar = T.pack <$>
+            liftA2 (:) (satisfy isLower) (many $ satisfy isNameTail)
+
+        isNameTail c = isAlphaNum c
+                    || c == '\''
+                    || c == '_'
+
+isVarSym :: Char -> Bool
+isVarSym = (`T.elem` "\\!#$%&*+./<=>?@^|-~")
+
+isSym :: Char -> Bool
+isSym c = c == ':' || isVarSym c
+
+infixD = undefined
+
+tySigD = undefined
+dataD = undefined
+
+----------------------------------------------------------------------------------
+
+-- absolute psycho shit
+
+type PartialDecl' = Decl (Const PartialExpr') Name
+
+newtype Y f = Y (f (Y f))
+
+instance (Show (f (Y f))) => Show (Y f) where
+    showsPrec p (Y f) = showsPrec p f
+
+data Partial a = E (RlpExprF Name a)
+               | U (Partial a) Name (Partial a)
+               deriving Show
+
+type PartialExpr' = Y Partial
+

src/RLP/Syntax.hs

@@ -1,23 +1,52 @@
+-- recursion-schemes
+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
+-- recursion-schemes
+{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings #-}
-module RLP.Syntax
+module Rlp.Syntax
-    ( RlpExpr
+    ( RlpExpr(..)
+    , RlpExprF(..)
+    , RlpExprF'
+    , Decl(..)
+    , Assoc(..)
+    , VarId(..)
+    , Pat(..)
+    , Pat'
     )
     where
 ----------------------------------------------------------------------------------
+import Data.Functor.Const
 import Data.Text                    (Text)
+import Data.Text                    qualified as T
+import Data.String                  (IsString(..))
+import Data.Functor.Foldable.TH     (makeBaseFunctor)
 import Lens.Micro
+import Core.Syntax                  hiding (Lit)
 import Core                         (HasRHS(..), HasLHS(..))
 ----------------------------------------------------------------------------------
 
-newtype RlpProgram b = RlpProgram [Decl b]
+newtype RlpProgram b = RlpProgram [Decl RlpExpr b]
 
-data Decl b = InfixD  InfixAssoc Int VarId
+-- | The @e@ parameter is used for partial results. When parsing an input, we
-            | FunD    VarId [Pat b] (RlpExpr b)
+-- first parse all top-level declarations in order to extract infix[lr]
-            | DataD   ConId [ConId] [ConAlt]
+-- declarations. This process yields a @[Decl (Const Text) Name]@, where @Const
+-- Text@ stores the remaining unparsed function bodies. Once infixities are
+-- accounted for, we may complete the parsing task and get a proper @[Decl
+-- RlpExpr Name]@.
+
+data Decl e b = FunD    VarId [Pat b] (e b)
+              | TySigD  [VarId] Type
+              | DataD   ConId [ConId] [ConAlt]
+              | InfixD  Assoc Int Name
+              deriving Show
+
+data Assoc = InfixL
+           | InfixR
+           | Infix
+           deriving Show
 
 data ConAlt = ConAlt ConId [ConId]
-
+               deriving Show
-data InfixAssoc = Assoc | AssocL | AssocR
 
 data RlpExpr b = LetE  [Bind b] (RlpExpr b)
                | VarE  VarId
@@ -27,26 +56,39 @@ data RlpExpr b = LetE  [Bind b] (RlpExpr b)
                | IfE   (RlpExpr b) (RlpExpr b) (RlpExpr b)
                | AppE  (RlpExpr b) (RlpExpr b)
                | LitE  (Lit b)
+               deriving Show
 
 -- do we want guards?
 data Alt b = AltA (Pat b) (RlpExpr b)
+               deriving Show
 
 data Bind b = PatB (Pat b) (RlpExpr b)
             | FunB VarId [Pat b] (RlpExpr b)
+            deriving Show
 
 data VarId = NameVar Text
            | SymVar Text
+           deriving Show
+
+instance IsString VarId where
+    -- TODO: use symvar if it's an operator
+    fromString = NameVar . T.pack
 
 data ConId = NameCon Text
            | SymCon Text
+           deriving Show
 
 data Pat b = VarP VarId
            | LitP (Lit b)
            | ConP ConId [Pat b]
+           deriving Show
+
+type Pat' = Pat Name
 
 data Lit b = IntL Int
            | CharL Char
            | ListL [RlpExpr b]
+           deriving Show
 
 -- instance HasLHS Alt Alt Pat Pat where
 --     _lhs = lens
@@ -57,3 +99,10 @@ data Lit b = IntL Int
 --     _rhs = lens
 --         (\ (AltA _ e) -> e)
 --         (\ (AltA p _) e' -> AltA p e')
+
+makeBaseFunctor ''RlpExpr
+
+deriving instance (Show b, Show a) => Show (RlpExprF b a)
+
+type RlpExprF' = RlpExprF Name
+