i want to fucking die
This commit is contained in:
crumbtoo
@@ -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(location)
|
||||
, HasLocation(..)
|
||||
, _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
|
||||
srcspan :: s -> SrcSpan
|
||||
data Floc f = Floc SrcSpan (f (Floc f))
|
||||
|
||||
class HasLocation s where
|
||||
location :: Lens' s SrcSpan
|
||||
pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b
|
||||
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
|
||||
|
||||
|
||||
@@ -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
|
||||
t <- lexToken
|
||||
case t of
|
||||
Located _ TokenEOF -> pure [TokenEOF]
|
||||
Located _ t -> (t:) <$> lexStream
|
||||
lexStream = fmap extract <$> lexStream'
|
||||
|
||||
lexStream' :: P [Located RlpToken]
|
||||
lexStream' = lexToken >>= \case
|
||||
t@(Located _ TokenEOF) -> pure [t]
|
||||
t -> (t:) <$> lexStream'
|
||||
|
||||
lexDebug :: (Located RlpToken -> P a) -> P a
|
||||
lexDebug k = do
|
||||
|
||||
@@ -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 }
|
||||
: VL Expr VR { undefined }
|
||||
StandaloneExpr :: { Expr' RlpcPs SrcSpan }
|
||||
: 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 }
|
||||
| TyParams varname { undefined }
|
||||
: {- epsilon -} { [] }
|
||||
| TyParams varname { $1 `snoc` extractName $2 }
|
||||
|
||||
DataCons :: { [ConAlt RlpcPs] }
|
||||
: DataCons '|' DataCon { undefined }
|
||||
| DataCon { undefined }
|
||||
: DataCons '|' DataCon { $1 `snoc` $3 }
|
||||
| DataCon { [$1] }
|
||||
|
||||
DataCon :: { ConAlt RlpcPs }
|
||||
: Con Type1s { undefined }
|
||||
: Con Type1s { ConAlt $1 $2 }
|
||||
|
||||
Type1s :: { [Ty RlpcPs] }
|
||||
: {- epsilon -} { undefined }
|
||||
| Type1s Type1 { undefined }
|
||||
: {- epsilon -} { [] }
|
||||
| Type1s Type1 { $1 `snoc` $2 }
|
||||
|
||||
Type1 :: { Ty RlpcPs }
|
||||
: '(' Type ')' { undefined }
|
||||
| conname { undefined }
|
||||
| varname { undefined }
|
||||
: '(' Type ')' { $2 }
|
||||
| conname { ConT (extractName $1) }
|
||||
| varname { VarT (extractName $1) }
|
||||
|
||||
Type :: { Ty RlpcPs }
|
||||
: Type '->' Type { undefined }
|
||||
| TypeApp { undefined }
|
||||
: Type '->' Type { FunT $1 $3 }
|
||||
| TypeApp { $1 }
|
||||
|
||||
TypeApp :: { Ty RlpcPs }
|
||||
: Type1 { undefined }
|
||||
| TypeApp Type1 { undefined }
|
||||
: Type1 { $1 }
|
||||
| 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 Pat1 { undefined }
|
||||
Params : {- epsilon -} { [] }
|
||||
| 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 }
|
||||
| LetExpr { undefined }
|
||||
| CaseExpr { undefined }
|
||||
| AppExpr { undefined }
|
||||
: AppExpr { $1 }
|
||||
-- | TempInfixExpr { undefined }
|
||||
-- | LetExpr { undefined }
|
||||
-- | CaseExpr { undefined }
|
||||
|
||||
TempInfixExpr :: { Expr RlpcPs }
|
||||
TempInfixExpr :: { Expr' RlpcPs SrcSpan }
|
||||
TempInfixExpr : Expr1 InfixOp TempInfixExpr { undefined }
|
||||
| Expr1 InfixOp Expr1 { undefined }
|
||||
| Expr1 InfixOp Expr1 { undefined }
|
||||
|
||||
AppExpr :: { Expr RlpcPs }
|
||||
: Expr1 { undefined }
|
||||
| AppExpr Expr1 { undefined }
|
||||
AppExpr :: { Expr' RlpcPs SrcSpan }
|
||||
: Expr1 { $1 }
|
||||
| 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 }
|
||||
: '(' Expr ')' { undefined }
|
||||
| Lit { undefined }
|
||||
| Var { undefined }
|
||||
| Con { undefined }
|
||||
Expr1 :: { Expr' RlpcPs SrcSpan }
|
||||
: '(' Expr ')' { $2 }
|
||||
| Lit { nolo' $ LitEF $1 }
|
||||
| Var { case $1 of Located ss _ -> ss :< VarEF $1 }
|
||||
| Con { case $1 of Located ss _ -> ss :< VarEF $1 }
|
||||
|
||||
InfixOp :: { PsName }
|
||||
: consym { undefined }
|
||||
| varsym { undefined }
|
||||
: consym { extractName $1 }
|
||||
| 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 }
|
||||
| varsym { undefined }
|
||||
Var : varname { $1 <&> view (singular _TokenVarName) }
|
||||
| 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)
|
||||
|
||||
@@ -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
|
||||
| TokenConName Name
|
||||
| TokenVarSym Name
|
||||
| TokenConSym Name
|
||||
| TokenVarName Text
|
||||
| TokenConName Text
|
||||
| TokenVarSym Text
|
||||
| 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)
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
Reference in New Issue
Block a user