HasLocation

HasLocation

src/Compiler/Types.hs

@@ -1,12 +1,16 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE UndecidableInstances, QuantifiedConstraints #-}
 module Compiler.Types
     ( SrcSpan(..)
     , srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen
     , Located(..)
+    , HasLocation(location)
     , _Located
-    , located
     , nolo
 
+    , (<~>), (~>)
+
     -- * Re-exports
     , Comonad
     , Apply
@@ -14,19 +18,38 @@ module Compiler.Types
     )
     where
 --------------------------------------------------------------------------------
+import Language.Haskell.TH.Syntax   (Lift)
+
 import Control.Comonad
+import Control.Comonad.Cofree
 import Data.Functor.Apply
 import Data.Functor.Bind
+import Data.Semigroup.Foldable
+import Data.Kind
 import Control.Lens                 hiding ((<<~))
-import Language.Haskell.TH.Syntax   (Lift)
+
+import Data.List.NonEmpty           (NonEmpty)
 --------------------------------------------------------------------------------
 
 -- | Token wrapped with a span (line, column, absolute, length)
 data Located a = Located SrcSpan a
     deriving (Show, Lift, Functor)
 
-located :: Lens (Located a) (Located b) a b
+class GetLocation s where
-located = lens extract ($>)
+    srcspan :: s -> SrcSpan
+
+class HasLocation s where
+    location :: Lens' s SrcSpan
+
+(<~>) :: a -> b -> SrcSpan
+(<~>) = undefined
+
+infixl 5 <~>
+
+(~>) :: a -> b -> b
+(~>) = undefined
+
+infixl 4 ~>
 
 instance Apply Located where
     liftF2 f (Located sa p) (Located sb q)
@@ -78,3 +101,22 @@ instance Semigroup SrcSpan where
 
 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/Parse.y

@@ -72,32 +72,21 @@ import Compiler.Types
 %%
 
 StandaloneProgram   :: { Program RlpcPs }
-StandaloneProgram   : '{' Decls  '}'        { undefined }
+StandaloneProgram   : layout0(Decl)         { Program $1 }
-                    | VL  DeclsV VR         { undefined }
 
 StandaloneExpr      :: { Expr RlpcPs }
-                    : VL Expr VR            { undefined }
+                    : VL Expr VR            { $2 }
 
 VL  :: { () }
-VL  : vlbrace       { undefined }
+VL  : vlbrace       { () }
 
 VR  :: { () }
-VR  : vrbrace       { undefined }
+VR  : vrbrace       { () }
-    | error         { undefined }
+    | error         { () }
 
-Decls               :: { [Decl RlpcPs] }
+VS                  :: { () }
-Decls               : Decl ';' Decls        { undefined }
+VS                  : ';'                   { () }
-                    | Decl ';'              { undefined }
+                    | vsemi                 { () }
-                    | Decl                  { undefined }
-
-DeclsV              :: { [Decl RlpcPs] }
-DeclsV              : Decl VS DeclsV        { undefined }
-                    | Decl VS               { undefined }
-                    | Decl                  { undefined }
-
-VS                  :: { Located RlpToken }
-VS                  : ';'                   { undefined }
-                    | vsemi                 { undefined }
 
 Decl        :: { Decl RlpcPs }
             : FunDecl                   { undefined }
@@ -148,7 +137,7 @@ TypeApp     :: { Ty RlpcPs }
             | TypeApp Type1             { undefined }
 
 FunDecl     :: { Decl RlpcPs }
-FunDecl     : Var Params '=' Expr       { undefined }
+FunDecl     : Var Params '=' Expr       { FunD $1 $2 $4 Nothing }
 
 Params      :: { [Pat RlpcPs] }
 Params      : {- epsilon -}             { undefined }
@@ -199,21 +188,21 @@ Alt         :: { Alt RlpcPs }
             : Pat '->' Expr                 { undefined }
 
 -- layout0(p : β) :: [β]
-layout0(p)  : '{' layout_list0(';',p) '}'   { undefined }
+layout0(p)  : '{' layout_list0(';',p) '}'   { $2 }
-            | VL  layout_list0(VS,p)  VR    { undefined }
+            | VL  layout_list0(VS,p)  VR    { $2 }
 
 -- layout_list0(sep : α, p : β) :: [β]
-layout_list0(sep,p) : p                          { undefined }
+layout_list0(sep,p) : p                          { [$1] }
-                    | layout_list1(sep,p) sep p  { undefined }
+                    | layout_list1(sep,p) sep p  { $1 `snoc` $3 }
-                    | {- epsilon -}              { undefined }
+                    | {- epsilon -}              { [] }
 
 -- layout1(p : β) :: [β]
-layout1(p)  : '{' layout_list1(';',p) '}'   { undefined }
+layout1(p)  : '{' layout_list1(';',p) '}'   { $2 }
-            | VL  layout_list1(VS,p) VR     { undefined }
+            | VL  layout_list1(VS,p) VR     { $2 }
 
 -- layout_list1(sep : α, p : β) :: [β]
-layout_list1(sep,p) : p                          { undefined }
+layout_list1(sep,p) : p                          { [$1] }
-                    | layout_list1(sep,p) sep p  { undefined }
+                    | layout_list1(sep,p) sep p  { $1 `snoc` $3 }
 
 Binding     :: { Binding RlpcPs }
             : Pat '=' Expr              { undefined }
@@ -230,17 +219,17 @@ InfixOp     :: { Located PsName }
 
 -- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
 Lit         :: { Lit RlpcPs }
-            : litint                    { undefined }
+            : litint                    { $1 ^. to extract
+                                              . singular _TokenLitInt
+                                              . to IntL }
 
-Var         :: { Located PsName }
+Var         :: { PsName }
 Var         : varname                   { undefined }
             | varsym                    { undefined }
 
-Con         :: { Located PsName }
+Con         :: { PsName }
             : conname                   { undefined }
 
---}
-
 {
 
 parseRlpProgR = undefined

src/Rlp/Parse/Types.hs

@@ -17,7 +17,7 @@ module Rlp.Parse.Types
     , RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
     , Located(..), PsName
     -- ** Lenses
-    , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
+    , _TokenLitInt, aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
 
     -- * Error handling
     , MsgEnvelope(..), RlpcError(..), RlpParseError(..)
@@ -53,7 +53,7 @@ data RlpcPs
 
 type instance NameP RlpcPs = PsName
 
-type PsName = Text
+type PsName = Located Text
 
 --------------------------------------------------------------------------------
 
@@ -125,6 +125,11 @@ data RlpToken
     | TokenEOF
     deriving (Show)
 
+_TokenLitInt :: Prism' RlpToken Int
+_TokenLitInt = prism TokenLitInt $ \case
+    TokenLitInt n -> Right n
+    x             -> Left x
+
 newtype P a = P {
         runP :: ParseState
              -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)

src/Rlp/Syntax.hs

@@ -40,12 +40,11 @@ import Control.Comonad.Cofree
 import Data.Functor.Foldable
 import Data.Functor.Foldable.TH     (makeBaseFunctor)
 
-import Compiler.Types               (SrcSpan(..))
+import Compiler.Types               (SrcSpan(..), Located(..))
 import Core.Syntax                  qualified as Core
 import Core                         (Rec(..), HasRHS(..), HasLHS(..))
 ----------------------------------------------------------------------------------
 
-type PsName = Text
 type family NameP p
 
 data Program p = Program