i want to fucking die

src/Compiler/Types.hs

@@ -1,19 +1,23 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE UndecidableInstances, QuantifiedConstraints #-}
+{-# LANGUAGE PatternSynonyms #-}
 module Compiler.Types
     ( SrcSpan(..)
     , srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen
+    , pattern (:<$)
     , Located(..)
-    , GetLocation(srcspan)
+    , HasLocation(..)
-    , HasLocation(location)
     , _Located
-    , nolo
+    , nolo, nolo'
 
-    , (<~>), (~>)
+    , (<~>), (~>), (~~>), (<~~)
+
+    , comb2, comb3, comb4
+    , lochead
 
     -- * Re-exports
-    , Comonad
+    , Comonad(extract)
     , Apply
     , Bind
     )
@@ -23,35 +27,56 @@ import Language.Haskell.TH.Syntax   (Lift)
 
 import Control.Comonad
 import Control.Comonad.Cofree
+import Control.Comonad.Trans.Cofree qualified as Trans.Cofree
+import Control.Comonad.Trans.Cofree (CofreeF)
 import Data.Functor.Apply
 import Data.Functor.Bind
+import Data.Functor.Compose
+import Data.Functor.Foldable
 import Data.Semigroup.Foldable
+import Data.Fix                     hiding (cata, ana)
 import Data.Kind
-import Control.Lens                 hiding ((<<~))
+import Control.Lens                 hiding ((<<~), (:<))
 
 import Data.List.NonEmpty           (NonEmpty)
+import Data.Function                (on)
 --------------------------------------------------------------------------------
 
 -- | Token wrapped with a span (line, column, absolute, length)
 data Located a = Located SrcSpan a
     deriving (Show, Lift, Functor)
 
-class GetLocation s where
+data Floc f = Floc SrcSpan (f (Floc f))
-    srcspan :: s -> SrcSpan
 
-class HasLocation s where
+pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b
-    location :: Lens' s SrcSpan
+pattern a :<$ b = a Trans.Cofree.:< b
 
 (<~>) :: a -> b -> SrcSpan
 (<~>) = undefined
 
 infixl 5 <~>
 
-(~>) :: a -> b -> b
+-- (~>) :: (CanGet k, CanSet k', HasLocation k a, HasLocation k' b)
+--      => a -> b -> b
+-- a ~> b = 
 (~>) = undefined
 
 infixl 4 ~>
 
+-- (~~>) :: (CanGet k, HasLocation k a, CanSet k', HasLocation k' b)
+--       => (a -> b) -> a -> b
+-- (~~>) :: (f SrcSpan -> b) -> Cofree f SrcSpan -> Cofree f SrcSpan
+-- f ~~> (ss :< as) = ss :< f as
+(~~>) = undefined
+
+infixl 3 ~~>
+
+-- (<~~) :: (GetLocation a, HasLocation b) => (a -> b) -> a -> b
+-- a <~~ b = a b & location <>~ srcspan b
+(<~~) = undefined
+
+infixr 2 <~~
+
 instance Apply Located where
     liftF2 f (Located sa p) (Located sb q)
             = Located (sa <> sb) (p `f` q)
@@ -86,6 +111,9 @@ srcSpanLen = tupling . _4
 nolo :: a -> Located a
 nolo = Located (SrcSpan 0 0 0 0)
 
+nolo' :: f (Cofree f SrcSpan) -> Cofree f SrcSpan
+nolo' as = SrcSpan 0 0 0 0 :< as
+
 instance Semigroup SrcSpan where
     -- multiple identities? what are the consequences of this...?
     SrcSpan _ _ _ 0 <> SrcSpan l c a s = SrcSpan l c a s
@@ -100,24 +128,103 @@ instance Semigroup SrcSpan where
             LT -> max sa (ab + sb - aa)
             GT -> max sb (aa + sa - ab)
 
+--------------------------------------------------------------------------------
+
+data GetOrSet = Get | Set | GetSet
+
+class CanGet (k :: GetOrSet)
+class CanSet (k :: GetOrSet) where
+
+instance CanGet Get
+instance CanGet GetSet
+instance CanSet Set
+instance CanSet GetSet
+
+data GetSetLens (k :: GetOrSet) s t a b :: Type where
+    Getter_      :: (s -> a)             -> GetSetLens Get s t a b
+    Setter_      :: ((a -> b) -> s -> t) -> GetSetLens Set s t a b
+    GetterSetter :: (CanGet k', CanSet k')
+                 => (s -> a) -> (s -> b -> t) -> GetSetLens k' s t a b
+
+type GetSetLens' k s a = GetSetLens k s s a a
+
+class HasLocation k s | s -> k where
+    -- location :: (Access k f, Functor f) => LensLike' f s SrcSpan
+    getSetLocation :: GetSetLens' k s SrcSpan
+
+type family Access (k :: GetOrSet) f where
+    Access GetSet f = Functor f
+    Access Set f = Settable f
+    Access Get f = (Functor f, Contravariant f)
+
+instance HasLocation GetSet SrcSpan where
+    getSetLocation = GetterSetter id (flip const)
+    -- location = fromGetSetLens getSetLocation
+
+instance (CanSet k, HasLocation k a) => HasLocation Set (r -> a) where
+    getSetLocation = Setter_ $ \ss ra r -> ra r & fromSet getSetLocation %~ ss
+    -- location = fromSet getSetLocation
+
+instance (HasLocation k a) => HasLocation k (Cofree f a) where
+    getSetLocation = case getSetLocation @_ @a of
+        Getter_ sa -> Getter_ $ \ (s :< _) -> sa s
+        Setter_ abst -> Setter_ $ \ss (s :< as) -> abst ss s :< as
+        GetterSetter sa sbt -> GetterSetter sa' sbt' where
+            sa' (s :< _) = sa s
+            sbt' (s :< as) b = sbt s b :< as
+
+location :: (Access k f, Functor f, HasLocation k s)
+         => LensLike' f s SrcSpan
+location = fromGetSetLens getSetLocation
+
+fromGetSetLens :: (Access k f, Functor f) => GetSetLens' k s a -> LensLike' f s a
+fromGetSetLens gsl = case gsl of
+    Getter_ sa          -> to sa
+    Setter_ abst        -> setting abst
+    GetterSetter sa sbt -> lens sa sbt
+
+fromGet :: (CanGet k) => GetSetLens k s t a b -> Getter s a
+fromGet (Getter_ sa)        = to sa
+fromGet (GetterSetter sa _) = to sa
+
+fromSet :: (CanSet k) => GetSetLens k s t a b -> Setter s t a b
+fromSet (Setter_ abst)        = setting abst
+fromSet (GetterSetter sa sbt) = lens sa sbt
+
+fromGetSet :: (CanGet k, CanSet k) => GetSetLens k s t a b -> Lens s t a b
+fromGetSet (GetterSetter sa sbt) = lens sa sbt
+
+--------------------------------------------------------------------------------
+
+comb2 :: (Functor f, Semigroup m)
+      => (Cofree f m -> Cofree f m -> f (Cofree f m))
+      -> Cofree f m -> Cofree f m -> Cofree f m
+comb2 f a b = ss :< f a b
+    where ss = a `mextract` b
+
+comb3 :: (Functor f, Semigroup m)
+      => (Cofree f m -> Cofree f m -> Cofree f m -> f (Cofree f m))
+      -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
+comb3 f a b c = ss :< f a b c
+    where ss = a `mapply` b `mextract` c
+
+comb4 :: (Functor f, Semigroup m)
+      => (Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
+         -> f (Cofree f m))
+      -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
+comb4 f a b c d = ss :< f a b c d
+    where ss = a `mapply` b `mapply` c `mextract` d
+
+mextract :: (Comonad w, Semigroup m) => w m -> w m -> m
+mextract = (<>) `on` extract
+
+mapply :: (Comonad w, Semigroup m) => w m -> w m -> w m
+mapply a b = b <&> (<> extract a)
+
+lochead :: Functor f
+        => (f SrcSpan -> f SrcSpan) -> Located (f SrcSpan) -> Cofree f SrcSpan
+lochead afs (Located ss fss) = ss :< unwrap (lochead afs $ Located ss fss)
+
+--------------------------------------------------------------------------------
+
 makePrisms ''Located
-
---------------------------------------------------------------------------------
-
-instance (GetLocation a) => GetLocation (NonEmpty a) where
-    srcspan = foldMap1 srcspan
-
-instance GetLocation SrcSpan where
-    srcspan = id
-
-instance (Functor f) => GetLocation (Cofree f SrcSpan) where
-    srcspan = extract
-
---------------------------------------------------------------------------------
-
-instance HasLocation SrcSpan where
-    location = id
-
-instance (Functor f) => HasLocation (Cofree f SrcSpan) where
-    location = _extract
-

src/Rlp/Lex.x

@@ -8,6 +8,7 @@ module Rlp.Lex
     , Located(..)
     , lexToken
     , lexStream
+    , lexStream'
     , lexDebug
     , lexCont
     , popLexState
@@ -29,6 +30,7 @@ import Data.Word
 import Data.Default
 import Control.Lens
 
+import Compiler.Types
 import Debug.Trace
 import Rlp.Parse.Types
 }
@@ -274,11 +276,12 @@ lexCont :: (Located RlpToken -> P a) -> P a
 lexCont = (lexToken >>=)
 
 lexStream :: P [RlpToken]
-lexStream = do
+lexStream = fmap extract <$> lexStream'
-    t <- lexToken
+
-    case t of
+lexStream' :: P [Located RlpToken]
-        Located _ TokenEOF -> pure [TokenEOF]
+lexStream' = lexToken >>= \case
-        Located _ t        -> (t:) <$> lexStream
+    t@(Located _ TokenEOF) -> pure [t]
+    t        -> (t:) <$> lexStream'
 
 lexDebug :: (Located RlpToken -> P a) -> P a
 lexDebug k = do

src/Rlp/Parse.y

@@ -5,15 +5,17 @@ module Rlp.Parse
     , parseRlpProgR
     , parseRlpExpr
     , parseRlpExprR
+    , runP'
     )
     where
 import Compiler.RlpcError
 import Compiler.RLPC
+import Control.Comonad.Cofree
 import Rlp.Lex
 import Rlp.Syntax
 import Rlp.Parse.Types
 import Rlp.Parse.Associate
-import Control.Lens                 hiding (snoc, (.>), (<.), (<<~))
+import Control.Lens                 hiding (snoc, (.>), (<.), (<<~), (:<))
 import Data.List.Extra
 import Data.Fix
 import Data.Functor.Const
@@ -74,8 +76,8 @@ import Compiler.Types
 StandaloneProgram   :: { Program RlpcPs SrcSpan }
 StandaloneProgram   : layout0(Decl)         { Program $1 }
 
-StandaloneExpr      :: { Expr RlpcPs }
+StandaloneExpr      :: { Expr' RlpcPs SrcSpan }
-                    : VL Expr VR            { undefined }
+                    : VL Expr VR            { $2 }
 
 VL  :: { () }
 VL  : vlbrace       { () }
@@ -106,45 +108,45 @@ InfixWord   :: { Assoc }
             | infix                     { Infix }
 
 DataDecl    :: { Decl RlpcPs SrcSpan }
-            : data Con TyParams '=' DataCons    { undefined }
+            : data Con TyParams '=' DataCons    { DataD $2 $3 $5 }
 
 TyParams    :: { [PsName] }
-            : {- epsilon -}             { undefined }
+            : {- epsilon -}             { [] }
-            | TyParams varname          { undefined }
+            | TyParams varname          { $1 `snoc` extractName $2 }
 
 DataCons    :: { [ConAlt RlpcPs] }
-            : DataCons '|' DataCon      { undefined }
+            : DataCons '|' DataCon      { $1 `snoc` $3 }
-            | DataCon                   { undefined }
+            | DataCon                   { [$1] }
 
 DataCon     :: { ConAlt RlpcPs }
-            : Con Type1s                { undefined }
+            : Con Type1s                { ConAlt $1 $2 }
 
 Type1s      :: { [Ty RlpcPs] }
-            : {- epsilon -}             { undefined }
+            : {- epsilon -}             { [] }
-            | Type1s Type1              { undefined }
+            | Type1s Type1              { $1 `snoc` $2 }
 
 Type1       :: { Ty RlpcPs }
-            : '(' Type ')'              { undefined }
+            : '(' Type ')'              { $2 }
-            | conname                   { undefined }
+            | conname                   { ConT (extractName $1) }
-            | varname                   { undefined }
+            | varname                   { VarT (extractName $1) }
 
 Type        :: { Ty RlpcPs }
-            : Type '->' Type            { undefined }
+            : Type '->' Type            { FunT $1 $3 }
-            | TypeApp                   { undefined }
+            | TypeApp                   { $1 }
 
 TypeApp     :: { Ty RlpcPs }
-            : Type1                     { undefined }
+            : Type1                     { $1 }
-            | TypeApp Type1             { undefined }
+            | TypeApp Type1             { AppT $1 $2 }
 
 FunDecl     :: { Decl RlpcPs SrcSpan }
 FunDecl     : Var Params '=' Expr       { FunD $1 $2 $4 Nothing }
 
 Params      :: { [Pat RlpcPs] }
-Params      : {- epsilon -}             { undefined }
+Params      : {- epsilon -}             { [] }
-            | Params Pat1               { undefined }
+            | Params Pat1               { $1 `snoc` $2 }
 
 Pat         :: { Pat RlpcPs }
-            : Con Pat1s                 { undefined }
+            : Con Pat1s                 { $1 }
             | Pat1                      { undefined }
 
 Pat1s       :: { [Pat RlpcPs] }
@@ -160,18 +162,18 @@ Pat1        :: { Pat RlpcPs }
 Expr        :: { Expr' RlpcPs SrcSpan }
             -- infixities delayed till next release :(
             -- : Expr1 InfixOp Expr        { undefined }
-            : TempInfixExpr             { undefined }
+            : AppExpr                   { $1 }
-            | LetExpr                   { undefined }
+            -- | TempInfixExpr             { undefined }
-            | CaseExpr                  { undefined }
+            -- | LetExpr                   { undefined }
-            | AppExpr                   { undefined }
+            -- | CaseExpr                  { undefined }
 
-TempInfixExpr :: { Expr RlpcPs }
+TempInfixExpr :: { Expr' RlpcPs SrcSpan }
 TempInfixExpr : Expr1 InfixOp TempInfixExpr { undefined }
               | Expr1 InfixOp Expr1         { undefined }
 
-AppExpr     :: { Expr RlpcPs }
+AppExpr     :: { Expr' RlpcPs SrcSpan }
-            : Expr1                     { undefined }
+            : Expr1                     { $1 }
-            | AppExpr Expr1             { undefined }
+            | AppExpr Expr1             { comb2 AppEF $1 $2 }
 
 LetExpr     :: { Expr RlpcPs }
             : let layout1(Binding) in Expr      { undefined }
@@ -205,17 +207,17 @@ layout_list1(sep,p) : p                          { [$1] }
                     | layout_list1(sep,p) sep p  { $1 `snoc` $3 }
 
 Binding     :: { Binding RlpcPs }
-            : Pat '=' Expr              { undefined }
+            : Pat '=' Expr              { PatB $1 (collapse . strip $ $3) }
 
-Expr1       :: { Expr RlpcPs }
+Expr1       :: { Expr' RlpcPs SrcSpan }
-            : '(' Expr ')'              { undefined }
+            : '(' Expr ')'              { $2 }
-            | Lit                       { undefined }
+            | Lit                       { nolo' $ LitEF $1 }
-            | Var                       { undefined }
+            | Var                       { case $1 of Located ss _ -> ss :< VarEF $1 }
-            | Con                       { undefined }
+            | Con                       { case $1 of Located ss _ -> ss :< VarEF $1 }
 
 InfixOp     :: { PsName }
-            : consym                    { undefined }
+            : consym                    { extractName $1 }
-            | varsym                    { undefined }
+            | varsym                    { extractName $1 }
 
 -- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
 Lit         :: { Lit RlpcPs }
@@ -224,11 +226,11 @@ Lit         :: { Lit RlpcPs }
                                               . to IntL }
 
 Var         :: { PsName }
-Var         : varname                   { undefined }
+Var         : varname                   { $1 <&> view (singular _TokenVarName) }
-            | varsym                    { undefined }
+            | varsym                    { $1 <&> view (singular _TokenVarSym) }
 
 Con         :: { PsName }
-            : conname                   { undefined }
+            : conname                   { $1 <&> view (singular _TokenConName) }
 
 {
 
@@ -301,10 +303,15 @@ _litint = to extract
 
 mkPsName = undefined
 tempInfixExprErr = undefined
-extractName = undefined
 extractInt = undefined
 mkProgram = undefined
 
+extractName :: Located RlpToken -> PsName
+extractName (Located ss (TokenVarSym n)) = Located ss n
+extractName (Located ss (TokenVarName n)) = Located ss n
+extractName (Located ss (TokenConName n)) = Located ss n
+extractName (Located ss (TokenConSym n)) = Located ss n
+
 parseError :: (Located RlpToken, [String]) -> P a
 parseError ((Located ss t), exp) = addFatal $
     errorMsg ss (RlpParErrUnexpectedToken t exp)

src/Rlp/Parse/Types.hs

@@ -18,7 +18,8 @@ module Rlp.Parse.Types
     , RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
     , Located(..), PsName
     -- ** Lenses
-    , _TokenLitInt, aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
+    , _TokenLitInt, _TokenVarName, _TokenConName, _TokenVarSym
+    , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
 
     -- * Error handling
     , MsgEnvelope(..), RlpcError(..), RlpParseError(..)
@@ -93,10 +94,10 @@ data RlpToken
     -- literals
     = TokenLitInt Int
     -- identifiers
-    | TokenVarName Name
+    | TokenVarName Text
-    | TokenConName Name
+    | TokenConName Text
-    | TokenVarSym Name
+    | TokenVarSym Text
-    | TokenConSym Name
+    | TokenConSym Text
     -- reserved words
     | TokenData
     | TokenCase
@@ -132,6 +133,26 @@ _TokenLitInt = prism TokenLitInt $ \case
     TokenLitInt n -> Right n
     x             -> Left x
 
+_TokenVarName :: Prism' RlpToken Text
+_TokenVarName = prism TokenVarName $ \case
+    TokenVarName n -> Right n
+    x              -> Left x
+
+_TokenVarSym :: Prism' RlpToken Text
+_TokenVarSym = prism TokenVarSym $ \case
+    TokenVarSym n -> Right n
+    x              -> Left x
+
+_TokenConName :: Prism' RlpToken Text
+_TokenConName = prism TokenConName $ \case
+    TokenConName n -> Right n
+    x              -> Left x
+
+_TokenConSym :: Prism' RlpToken Text
+_TokenConSym = prism TokenConSym $ \case
+    TokenConSym n -> Right n
+    x              -> Left x
+
 newtype P a = P {
         runP :: ParseState
              -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
@@ -261,6 +282,7 @@ initAlexInput s = AlexInput
 
 --------------------------------------------------------------------------------
 
+
 -- deriving instance Lift (Program RlpcPs)
 -- deriving instance Lift (Decl RlpcPs)
 -- deriving instance Lift (Pat RlpcPs)

src/Rlp/Syntax/Backstage.hs

@@ -1,11 +1,13 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE UndecidableInstances #-}
 module Rlp.Syntax.Backstage
-    (
+    ( strip, collapse
     )
     where
 --------------------------------------------------------------------------------
+import Data.Fix                     hiding (cata)
 import Data.Functor.Classes
+import Data.Functor.Foldable
 import Rlp.Syntax.Types
 import Text.Show.Deriving
 import Language.Haskell.TH.Syntax   (Lift)
@@ -22,3 +24,9 @@ deriving instance (Show (NameP p), Show a) => Show (Decl p a)
 
 deriving instance (Show (NameP p), Show a) => Show (Program p a)
 
+strip :: Functor f => Cofree f a -> Fix f
+strip (_ :< as) = Fix $ strip <$> as
+
+collapse :: Fix (ExprF b) -> Expr b
+collapse = cata embed
+

src/Rlp/Syntax/Types.hs

@@ -5,6 +5,7 @@
 module Rlp.Syntax.Types
     (
       NameP
+    , SimpleP
     , Assoc(..)
     , ConAlt(..)
     , Alt(..)
@@ -20,7 +21,6 @@ module Rlp.Syntax.Types
     -- * Re-exports
     , Cofree(..)
     , Trans.Cofree.CofreeF
-    , pattern (:<$)
     , SrcSpan(..)
     )
     where
@@ -35,7 +35,7 @@ import Data.Fix
 import Data.Kind                    (Type)
 import GHC.Generics
 import Language.Haskell.TH.Syntax   (Lift)
-import Control.Lens
+import Control.Lens                 hiding ((:<))
 
 import Control.Comonad.Trans.Cofree qualified as Trans.Cofree
 import Control.Comonad.Cofree
@@ -47,6 +47,10 @@ import Core.Syntax                  qualified as Core
 import Core                         (Rec(..), HasRHS(..), HasLHS(..))
 ----------------------------------------------------------------------------------
 
+data SimpleP
+
+type instance NameP SimpleP = String
+
 type family NameP p
 
 data Expr p = LetE   Rec [Binding p] (Expr p)
@@ -68,7 +72,10 @@ data ConAlt p = ConAlt (NameP p) [Ty p]
 deriving instance (Lift (NameP p)) => Lift (ConAlt p)
 deriving instance (Show (NameP p)) => Show (ConAlt p)
 
-data Ty p = TyCon (NameP p)
+data Ty p = ConT (NameP p)
+          | VarT (NameP p)
+          | FunT (Ty p) (Ty p)
+          | AppT (Ty p) (Ty p)
 
 deriving instance (Show (NameP p)) => Show (Ty p)
 deriving instance (Lift (NameP p)) => Lift (Ty p)
@@ -100,9 +107,6 @@ type Where p = [Binding p]
 data Assoc = InfixL | InfixR | Infix
     deriving (Lift, Show)
 
-pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b
-pattern a :<$ b = a Trans.Cofree.:< b
-
 makeBaseFunctor ''Expr
 
 deriving instance (Show (NameP p), Show a) => Show (ExprF p a)
@@ -123,4 +127,11 @@ type Expr' p = Cofree (ExprF p)
 
 makeLenses ''Program
 
+loccof :: Iso' (Cofree f SrcSpan) (Located (f (Cofree f SrcSpan)))
+loccof = iso sa bt where
+    sa :: Cofree f SrcSpan -> Located (f (Cofree f SrcSpan))
+    sa (ss :< as) = Located ss as
+
+    bt :: Located (f (Cofree f SrcSpan)) -> Cofree f SrcSpan
+    bt (Located ss as) = ss :< as