show

rlp.cabal

@@ -48,7 +48,7 @@ library
     build-tool-depends: happy:happy, alex:alex
 
     -- other-extensions:
-    build-depends:    base ^>=4.18.0.0
+    build-depends:    base >=4.17 && <4.20
                     -- required for happy
                     , array >= 0.5.5 && < 0.6
                     , containers >= 0.6.7 && < 0.7
@@ -85,7 +85,7 @@ executable rlpc
     main-is:          Main.hs
     -- other-modules:
     -- other-extensions:
-    build-depends: base ^>=4.18.0.0
+    build-depends: base >=4.17.0.0 && <4.20.0.0
                  , rlp
                  , optparse-applicative >= 0.18.1 && < 0.19
                  , microlens >= 0.4.13 && < 0.5

src/Rlp/Parse.y

@@ -1,5 +1,5 @@
 {
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, ViewPatterns #-}
 module Rlp.Parse
     ( parseRlpProg
     )
@@ -86,7 +86,7 @@ Decl        :: { Decl' RlpcPs }
             | InfixDecl                 { $1 }
 
 InfixDecl   :: { Decl' RlpcPs }
-            : InfixWord litint InfixOp  {% mkInfixD $1 $2 $3 }
+            : InfixWord litint InfixOp  {% mkInfixD $1 (intOfToken $2) $3 }
 
 InfixWord   :: { Assoc }
             : infixl                    { InfixL }
@@ -94,11 +94,11 @@ InfixWord   :: { Assoc }
             | infix                     { Infix  }
 
 DataDecl    :: { Decl' RlpcPs }
-            : data Con TyParams '=' DataCons    { DataD $2 $3 $5 }
+            : data Con TyParams '=' DataCons    { $1 =>> \_ -> DataD' (extract $2) $3 $5 }
 
 TyParams    :: { [PsName] }
             : {- epsilon -}             { [] }
-            | TyParams varname          { $1 `snoc` $2 }
+            | TyParams varname          { $1 `snoc` extract (mkPsName $2) }
 
 DataCons    :: { [ConAlt RlpcPs] }
             : DataCons '|' DataCon      { $1 `snoc` $3 }
@@ -193,4 +193,7 @@ mkInfixD a p n = do
     pos <- use (psInput . aiPos)
     pure $ Located (spanFromPos pos 0) (InfixD' a p n)
 
+intOfToken :: Located RlpToken -> Int
+intOfToken (Located _ (TokenLitInt n)) = n
+
 }

src/Rlp/Parse/Associate.hs

@@ -14,6 +14,6 @@ import Rlp.Parse.Types
 import Rlp.Syntax
 --------------------------------------------------------------------------------
 
-associate = undefined
+associate x y = y
 {-# WARNING associate "temporarily undefined" #-}
 

src/Rlp/Parse/Types.hs

@@ -53,9 +53,22 @@ type instance XRec RlpcPs f = Located (f RlpcPs)
 type instance IdP RlpcPs = PsName
 
 type instance XInfixD RlpcPs = ()
-type instance XVarE RlpcPs = ()
-type instance XLitE RlpcPs = ()
 type instance XFunD RlpcPs = ()
+type instance XDataD RlpcPs = ()
+type instance XTySigD RlpcPs = ()
+type instance XXDecl RlpcPs = ()
+
+type instance XLetE RlpcPs = ()
+type instance XVarE RlpcPs = ()
+type instance XLamE RlpcPs = ()
+type instance XCaseE RlpcPs = ()
+type instance XIfE RlpcPs = ()
+type instance XAppE RlpcPs = ()
+type instance XLitE RlpcPs = ()
+type instance XParE RlpcPs = ()
+type instance XOAppE RlpcPs = ()
+type instance XXRlpExpr RlpcPs = ()
+type instance XLitE RlpcPs = ()
 
 type PsName = Text
 
@@ -198,6 +211,28 @@ spanAcross (la,ca,aa,sa) (lb,cb,ab,sb) = (l,c,a,s)
                 LT -> max sa (ab + sb)
                 GT -> max sb (aa + sa)
 
+-- | A synonym for '(<<=)' with a different precedence for use with '(<~>)' in a
+-- sort of, comonadic pseudo-applicative style.
+
+(<<~) :: (Comonad w) => (w a -> b) -> w a -> w b
+(<<~) = (<<=)
+
+infixl 4 <<~
+
+-- | Similar to '(<*>)', but with a cokleisli arrow.
+
+(<~>) :: (Comonad w, Bind w) => w (w a -> b) -> w a -> w b
+mc <~> ma = mc >>- \f -> ma =>> f
+
+infixl 4 <~>
+
+-- f :: (w a -> w b -> c)
+-- a :: w a
+-- b :: w b
+
+-- result :: w c
+-- result = f >~~ a <~> b
+
 instance Comonad Located where
     extract (Located _ a) = a
     extend ck w@(Located p _) = Located p (ck w)

src/Rlp/Syntax.hs

@@ -3,6 +3,7 @@
   , TemplateHaskell, TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings, PatternSynonyms #-}
 {-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
+{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
 module Rlp.Syntax
     (
     -- * AST
@@ -17,14 +18,15 @@ module Rlp.Syntax
 
     -- * Pattern synonyms for unused extensions
     -- ** Decl
-    , pattern InfixD', pattern FunD'
+    , pattern InfixD', pattern FunD', pattern DataD'
     -- ** RlpExpr
     , pattern ParE', pattern VarE', pattern LitE'
 
     -- * Trees That Grow extensions
     , UnXRec(..), MapXRec(..), XRec, IdP
     -- ** RlpExpr
-    , XLetE, XVarE, XConE, XLamE, XCaseE, XIfE, XAppE, XLitE, XXRlpExpr
+    , XLetE, XVarE, XConE, XLamE, XCaseE, XIfE, XAppE, XLitE, XParE, XOAppE
+    , XXRlpExpr
     -- ** Decl
     , XFunD, XTySigD, XDataD, XInfixD, XXDecl
     )
@@ -37,7 +39,7 @@ import Data.Functor.Foldable.TH     (makeBaseFunctor)
 import Data.Functor.Classes
 import Lens.Micro
 import Lens.Micro.TH
-import Core.Syntax                  hiding (Lit)
+import Core.Syntax                  hiding (Lit, Binding)
 import Core                         (HasRHS(..), HasLHS(..))
 ----------------------------------------------------------------------------------
 
@@ -46,7 +48,15 @@ data RlpModule p = RlpModule
     , _rlpmodProgram    :: RlpProgram p
     }
 
-newtype RlpProgram p = RlpProgram [Decl p]
+-- | dear god.
+type PhaseShow p =
+    ( Show (XRec p Pat), Show (XRec p RlpExpr)
+    , Show (XRec p Lit), Show (IdP p)
+    )
+
+newtype RlpProgram p = RlpProgram [Decl' p]
+
+deriving instance (PhaseShow p, Show (XRec p Decl)) => Show (RlpProgram p)
 
 data Decl p = FunD   (XFunD p)   (IdP p) [Pat' p] (RlpExpr' p) (Maybe (Where p))
             | TySigD (XTySigD p) [IdP p] Type
@@ -54,6 +64,12 @@ data Decl p = FunD   (XFunD p)   (IdP p) [Pat' p] (RlpExpr' p) (Maybe (Where p))
             | InfixD (XInfixD p) Assoc Int (IdP p)
             | XDecl  !(XXDecl p)
 
+deriving instance ( Show (XFunD p), Show (XTySigD p)
+                  , Show (XDataD p), Show (XInfixD p)
+                  , Show (XXDecl p), Show (IdP p)
+                  , PhaseShow p
+                  ) => Show (Decl p)
+
 type family XFunD p
 type family XTySigD p
 type family XDataD p
@@ -68,6 +84,9 @@ pattern FunD' n as e wh = FunD () n as e wh
 pattern InfixD' :: (XInfixD p ~ ()) => Assoc -> Int -> (IdP p) -> Decl p
 pattern InfixD' a p n = InfixD () a p n
 
+pattern DataD' :: (XDataD p ~ ()) => IdP p -> [IdP p] -> [ConAlt p] -> Decl p
+pattern DataD' n as ds = DataD () n as ds
+
 type Decl' p = XRec p Decl
 
 data Assoc = InfixL
@@ -77,7 +96,9 @@ data Assoc = InfixL
 
 data ConAlt p = ConAlt (IdP p) [Type]
 
-data RlpExpr p = LetE  (XLetE p)   [Bind p] (RlpExpr' p)
+deriving instance (Show (IdP p)) => Show (ConAlt p)
+
+data RlpExpr p = LetE  (XLetE p)   [Binding p] (RlpExpr' p)
                | VarE  (XVarE p)   (IdP p)
                | LamE  (XLamE p)   [Pat p] (RlpExpr' p)
                | CaseE (XCaseE p)  (RlpExpr' p) [(Alt p, Where p)]
@@ -88,6 +109,12 @@ data RlpExpr p = LetE  (XLetE p)   [Bind p] (RlpExpr' p)
                | OAppE (XOAppE p)  (IdP p) (RlpExpr' p) (RlpExpr' p)
                | XRlpExpr !(XXRlpExpr p)
 
+deriving instance
+    ( Show (XLetE p), Show (XVarE p), Show (XLamE p), Show (XCaseE p)
+    , Show (XIfE p), Show (XAppE p), Show (XLitE p), Show (XParE p)
+    , Show (XOAppE p), Show (XXRlpExpr p), PhaseShow p)
+    => Show (RlpExpr p)
+
 type RlpExpr' p = XRec p RlpExpr
 
 class UnXRec p where
@@ -121,24 +148,33 @@ pattern LitE' e = LitE () e
 pattern VarE' :: (XVarE p ~ ()) => IdP p -> RlpExpr p
 pattern VarE' e = VarE () e
 
-type Where p = [Bind p]
+type Where p = [Binding p]
 
 -- do we want guards?
 data Alt p = AltA (Pat' p) (RlpExpr' p)
 
-data Bind p = PatB (Pat' p) (RlpExpr' p)
+deriving instance (PhaseShow p) => Show (Alt p)
+
+data Binding p = PatB (Pat' p) (RlpExpr' p)
                | FunB (IdP p) [Pat' p] (RlpExpr' p)
 
+deriving instance (Show (XRec p Pat), Show (XRec p RlpExpr), Show (IdP p)
+                  ) => Show (Binding p)
+
 data Pat p = VarP (IdP p)
            | LitP (Lit' p)
            | ConP (IdP p) [Pat' p]
 
+deriving instance (PhaseShow p) => Show (Pat p)
+
 type Pat' p = XRec p Pat
 
 data Lit p = IntL Int
            | CharL Char
            | ListL [RlpExpr' p]
 
+deriving instance (PhaseShow p) => Show (Lit p)
+
 type Lit' p = XRec p Lit
 
 -- instance HasLHS Alt Alt Pat Pat where