parser compiles

src/Core.hs

@@ -1,6 +1,5 @@
 module Core
     ( module Core.Syntax
-    , parseCore
     , parseCoreProg
     , parseCoreExpr
     , lexCore

src/Core/Parse.y

@@ -5,8 +5,7 @@ Description : Parser for the Core language
 -}
 {-# LANGUAGE OverloadedStrings, ViewPatterns #-}
 module Core.Parse
-    ( parseCore
+    ( parseCoreExpr
-    , parseCoreExpr
     , parseCoreExprR
     , parseCoreProg
     , parseCoreProgR
@@ -31,13 +30,15 @@ import Data.Text.IO         qualified as TIO
 import Data.Text            (Text)
 import Data.Text            qualified as T
 import Data.HashMap.Strict  qualified as H
+
+import Core.Parse.Types
 }
 
 %name parseCoreExpr StandaloneExpr
 %name parseCoreProg StandaloneProgram
 %tokentype { Located CoreToken }
 %error { parseError }
-%monad { RLPC } { happyBind } { happyPure }
+%monad { P }
 
 %token
       let             { Located _ TokenLet }
@@ -74,12 +75,12 @@ Eof             :: { () }
 Eof             : eof           { () }
                 | error         { () }
 
-StandaloneProgram :: { Program Var }
+StandaloneProgram :: { Program PsName }
 StandaloneProgram : Program eof                 { $1 }
 
-Program         :: { Program Var }
+Program         :: { Program PsName }
-Program         : ScTypeSig ';' Program         { insTypeSig $1 $3 }
+Program         : ScTypeSig ';' Program         { insTypeSig ($1 & _1 %~ Left) $3 }
-                | ScTypeSig OptSemi             { singletonTypeSig $1 }
+                | ScTypeSig OptSemi             { singletonTypeSig ($1 & _1 %~ Left) }
                 | ScDef     ';' Program         { insScDef $1 $3 }
                 | ScDef     OptSemi             { singletonScDef $1 }
                 | TLPragma  Program             {% doTLPragma $1 $2 }
@@ -105,24 +106,25 @@ ScDefs          : ScDef ';' ScDefs              { $1 : $3 }
                 | ScDef                         { [$1] }
 
 ScDef           :: { ScDef PsName }
-ScDef           : Id ParList '=' Expr          { ScDef ($1,Nothing) $2 $4 }
+ScDef           : Id ParList '=' Expr          { ScDef (Left $1) $2
+                                                  ($4 & _binders %~ Right) }
 
-Type            :: { [(Name, Kind)] -> Kind -> Type }
+Type            :: { Kind -> Type }
-                : Type1 '->' Type   { \cases
+                : Type1 '->' Type   { \case
-                                        g TyKindType ->
+                                        TyKindType ->
-                                          $1 g TyKindType :-> $3 g TyKindType
+                                          $1 TyKindType :-> $3 TyKindType
-                                        _ _ -> error "kind mismatch" }
+                                        _ -> error "kind mismatch" }
                 | Type1                         { $1 }
 
 -- do we want to allow symbolic names for tyvars and tycons?
 
-Type1           :: { [(Name, Kind)] -> Kind -> Type }
+Type1           :: { Kind -> Type }
 Type1           : '(' Type ')'                  { $2 }
                 | varname                       { \k -> TyVar $ MkVar $1 k }
                 | conname                       { \k -> TyCon $ MkTyCon $1 k }
 
 ParList         :: { [PsName] }
-ParList         : varname ParList               { ($1, Nothing) : $2 }
+ParList         : varname ParList               { Left $1 : $2 }
                 | {- epsilon -}                 { [] }
 
 StandaloneExpr  :: { Expr Var }
@@ -148,7 +150,7 @@ Application     : Application AppArg           { App $1 $2 }
                 | Expr1       AppArg           { App $1 $2 }
 
 AppArg          :: { Expr Var }
-                : '@' Type1                     { Type ($2 [] TyKindInferred) }
+                : '@' Type1                     { Type ($2 TyKindInferred) }
                 | Expr1                         { $1 }
 
 CaseExpr        :: { Expr Var }
@@ -189,11 +191,11 @@ Id              :: { Name }
                 | conname                           { $1 }
 
 Var             :: { Var }
-Var             : '(' varname '::' Type ')'         { MkVar $2 ($4 [] TyKindType) }
+Var             : '(' varname '::' Type ')'         { MkVar $2 ($4 TyKindType) }
 
 {
 
-parseError :: [Located CoreToken] -> RLPC a
+parseError :: [Located CoreToken] -> P a
 parseError (Located _ t : _) =
     error $ "<line>" <> ":" <> "<col>"
          <> ": parse error at token `" <> show t <> "'"
@@ -224,12 +226,13 @@ singletonScDef :: (Hashable b) => ScDef b -> Program b
 singletonScDef sc = insScDef sc mempty
 
 parseCoreExprR :: (Monad m) => [Located CoreToken] -> RLPCT m (Expr Var)
-parseCoreExprR = hoistRlpcT generalise . parseCoreExpr
+parseCoreExprR = liftMaybe . snd . flip runP def . parseCoreExpr
 
-parseCoreProgR :: forall m. (Monad m) => [Located CoreToken] -> RLPCT m (Program Var)
+parseCoreProgR :: forall m. (Monad m)
-parseCoreProgR = ddumpast <=< (hoistRlpcT generalise . parseCoreProg)
+               => [Located CoreToken] -> RLPCT m (Program PsName)
+parseCoreProgR s = ddumpast =<< (liftMaybe . snd $ runP (parseCoreProg s) def)
     where
-        ddumpast :: (Program Var) -> RLPCT m (Program Var)
+        ddumpast :: (Program PsName) -> RLPCT m (Program PsName)
         ddumpast p = do
             addDebugMsg "dump-parsed-core" . show $ p
             pure p
@@ -240,7 +243,7 @@ happyBind m k = m >>= k
 happyPure :: a -> RLPC a
 happyPure a = pure a
 
-doTLPragma :: Pragma -> Program' -> RLPC Program'
+doTLPragma :: Pragma -> Program PsName -> P (Program PsName)
 -- TODO: warn unrecognised pragma
 doTLPragma (Pragma []) p = pure p
 
@@ -252,7 +255,7 @@ doTLPragma (Pragma pr) p = case pr of
 readt :: (Read a) => Text -> a
 readt = read . T.unpack
 
-type PsName = (Name, Maybe Type)
+type PsName = Either Name Var
 
 }
 

src/Core/Parse/Types.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Core.Parse.Types
+    ( P(..)
+    , psTyVars
+    , def
+    )
+    where
+--------------------------------------------------------------------------------
+import Control.Applicative
+import Control.Monad
+import Control.Monad.State
+import Data.Default
+import Data.Tuple               (swap)
+
+import Control.Lens
+
+import Core.Syntax
+--------------------------------------------------------------------------------
+
+newtype P a = P { runP :: PState -> (PState, Maybe a) }
+    deriving Functor
+
+data PState = PState
+    { _psTyVars :: [(Name, Kind)]
+    }
+
+instance Applicative P where
+    pure a = P (, Just a)
+
+    P pf <*> P pa = P \st ->
+        let (st',mf) = pf st
+            (st'',ma) = pa st'
+        in (st'', mf <*> ma)
+
+instance Monad P where
+    P pa >>= k = P \st ->
+        let (st',ma) = pa st
+        in case ma of
+            Just a -> runP (k a) st'
+            Nothing -> (st', Nothing)
+
+instance MonadState PState P where
+    state = P . fmap ((_2 %~ Just) . review swapped)
+
+instance Default PState where
+    def = undefined
+
+makeLenses ''PState
+

src/Core/Syntax.hs

@@ -19,7 +19,7 @@ module Core.Syntax
     , Pragma(..)
     -- ** Variables and identifiers
     , Name, Var(..), TyCon(..), Tag
-    , Binding(..), pattern (:=)
+    , Binding(..), pattern (:=), pattern (:$)
     , type Binding'
     -- ** Working with the fixed point of ExprF
     , Expr, Expr'
@@ -33,6 +33,7 @@ module Core.Syntax
     , programScDefs, programTypeSigs, programDataTags
     , formalising
     , HasRHS(_rhs), HasLHS(_lhs)
+    , HasBinders(_binders)
     )
     where
 ----------------------------------------------------------------------------------
@@ -49,6 +50,7 @@ import Data.Char
 import Data.These
 import GHC.Generics                 (Generic, Generically(..))
 import Text.Show.Deriving
+import Data.Eq.Deriving
 
 import Data.Fix                     hiding (cata, ana)
 import Data.Bifoldable              (bifoldr)
@@ -89,6 +91,9 @@ data TyCon = MkTyCon Name Kind
 data Var = MkVar Name Type
     deriving (Eq, Show, Lift)
 
+instance Hashable Var where
+    hashWithSalt s (MkVar n _) = hashWithSalt s n
+
 pattern Con :: Tag -> Int -> Expr b
 pattern Con t a = Fix (ConF t a)
 
@@ -129,6 +134,10 @@ infixl 1 :=
 pattern (:=) :: b -> Expr b -> Binding b
 pattern k := v = Binding k v
 
+infixl 2 :$
+pattern (:$) :: Expr b -> Expr b -> Expr b
+pattern f :$ x = App f x
+
 data Alter b = Alter AltCon [b] (Expr b)
 
 newtype Pragma = Pragma [T.Text]
@@ -159,7 +168,7 @@ data Module b = Module (Maybe (Name, [Name])) (Program b)
 data Program b = Program
     { _programScDefs   :: [ScDef b]
     , _programTypeSigs :: HashMap b Type
-    , _programDataTags :: HashMap b (Tag, Int)
+    , _programDataTags :: HashMap Name (Tag, Int)
     -- ^ map constructors to their tag and arity
     }
     deriving (Generic)
@@ -189,6 +198,14 @@ instance IsString (Expr b) where
 
 ----------------------------------------------------------------------------------
 
+class HasBinders s t a b | s -> a, t -> b, s b -> t, t a -> s where
+    _binders :: Traversal s t a b
+
+instance HasBinders (Expr b) (Expr b') b b' where
+    _binders k = cata go where
+        go :: Applicative f => ExprF b (f (Expr b')) -> f (Expr b')
+        go = undefined
+
 class HasRHS s t a b | s -> a, t -> b, s b -> t, t a -> s where
     _rhs :: Lens s t a b
 
@@ -356,7 +373,15 @@ instance Lift b => Lift1 (ExprF b) where
 deriving instance (Show b, Show a) => Show (ExprF b a)
 deriving instance Show b => Show (Binding b)
 deriving instance Show b => Show (Alter b)
+deriving instance Show b => Show (ScDef b)
+deriving instance Show b => Show (Program b)
 
 deriving instance Lift b => Lift (Binding b)
 deriving instance Lift b => Lift (Alter b)
 
+deriveEq1 ''ExprF
+
+deriving instance Eq b => Eq (Alter b)
+deriving instance Eq b => Eq (Binding b)
+deriving instance (Eq a, Eq b) => Eq (ExprF b a)
+