diff --git a/.ghci b/.ghci index 4d96080..21ffd96 100644 --- a/.ghci +++ b/.ghci @@ -1,5 +1,9 @@ +-- repl extensions :set -XOverloadedStrings +-------------------------------------------------------------------------------- + +-- happy/alex: override :r to rebuild parsers :set -package process :{ @@ -16,3 +20,8 @@ _reload_and_make _ = do :def! r _reload_and_make +-------------------------------------------------------------------------------- + +-- import rlpc quasiquoters +:m + Core.TH Rlp.TH + diff --git a/rlp.cabal b/rlp.cabal index 5719560..2f0d553 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -75,6 +75,7 @@ library , comonad , lens , text-ansi + , microlens-pro ^>=0.2.0 hs-source-dirs: src default-language: GHC2021 diff --git a/src/Compiler/Types.hs b/src/Compiler/Types.hs index 09c60f1..5352850 100644 --- a/src/Compiler/Types.hs +++ b/src/Compiler/Types.hs @@ -2,6 +2,7 @@ module Compiler.Types ( SrcSpan(..) , srcspanLine, srcspanColumn, srcspanAbs, srcspanLen , Located(..) + , locating , nolo , (<<~), (<~>) @@ -57,6 +58,9 @@ srcspanLen = tupling . _4 nolo :: a -> Located a nolo = Located (SrcSpan 0 0 0 0) +locating :: Lens (Located a) (Located b) a b +locating = lens extract ($>) + instance Semigroup SrcSpan where SrcSpan la ca aa sa <> SrcSpan lb cb ab sb = SrcSpan l c a s where l = min la lb diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs index 56dbcd8..f44e989 100644 --- a/src/Rlp/Syntax.hs +++ b/src/Rlp/Syntax.hs @@ -18,6 +18,8 @@ module Rlp.Syntax , ConAlt(..) , Binding(..), Binding' + , _VarP, _LitP, _ConP + -- * Trees That Grow boilerplate -- ** Extension points , IdP, IdP', XRec, UnXRec(..), MapXRec(..) @@ -39,8 +41,6 @@ module Rlp.Syntax , pattern ConT'' -- *** Pat , pattern VarP'', pattern LitP'', pattern ConP'' - -- ** NoLocated - , NoLocated ) where ---------------------------------------------------------------------------------- @@ -52,8 +52,8 @@ import Data.Functor.Classes import Data.Functor.Identity import Data.Kind (Type) import Language.Haskell.TH.Syntax (Lift) -import Lens.Micro -import Lens.Micro.TH +import Lens.Micro.Pro +import Lens.Micro.Pro.TH import Core.Syntax hiding (Lit, Type, Binding, Binding') import Core (HasRHS(..), HasLHS(..)) ---------------------------------------------------------------------------------- @@ -297,13 +297,5 @@ type Lit' p = XRec p (Lit p) -------------------------------------------------------------------------------- makeLenses ''RlpModule - --------------------------------------------------------------------------------- - -data NoLocated - -type instance XRec NoLocated a = Identity a - -stripLocation :: (UnXRec p) => XRec p a -> f NoLocated -stripLocation p = undefined +makePrisms ''Pat diff --git a/src/Rlp2Core.hs b/src/Rlp2Core.hs index 791946e..c0a59e8 100644 --- a/src/Rlp2Core.hs +++ b/src/Rlp2Core.hs @@ -52,8 +52,6 @@ declToCore fd@(FunD'' n as e _) = mempty & programScDefs .~ [ScDef n' as' e''] names = [ nolo $ "$x_" <> tshow n | n <- [0..] ] tshow = T.pack . show --- mapAccumL :: Traversable t => (s -> a -> (s, b)) -> s -> t a -> (s, t b) - caseify :: RlpExpr RlpcPs -> (IdP' RlpcPs, Pat' RlpcPs) -> (RlpExpr RlpcPs, Name) caseify e (x,p) = (e', x') where @@ -62,7 +60,50 @@ caseify e (x,p) = (e', x') where alt = AltA p (nolo e) exprToCore :: RlpExpr RlpcPs -> Expr' -exprToCore = undefined + +exprToCore (VarE n) = Var (dsNameToName n) + +exprToCore (CaseE e as) = undefined + +-- >>> pat1 = nolo $ ConP "C" [nolo $ ConP "P" []] +-- >>> expandableAlt "name" (AltA pat1 (nolo $ VarE "e")) +-- Just (ConP "C" [Located (SrcSpan 0 0 0 0) (VarP "name")],ConP "P" [],VarE' () "e") +-- +-- >>> pat2 = nolo $ ConP "C" [nolo $ VarP "p", nolo $ ConP "P" []] +-- >>> expandableAlt "name" (AltA pat2 (nolo $ VarE "e")) +-- Just (ConP "C" [Located (SrcSpan 0 0 0 0) (VarP "p"),Located (SrcSpan 0 0 0 0) (VarP "name")],ConP "P" [],VarE' () "e") +expandableAlt :: IdP RlpcPs -> Alt RlpcPs + -> Maybe (Pat RlpcPs, Pat RlpcPs, RlpExpr RlpcPs) +expandableAlt n (AltA c@(ConP'' cn as) e) = do + p <- nestedPat + let c' = ConP cn as' + pure (c', p, extract e) + where + l :: Lens' [Pat RlpcPs] (Maybe (Pat RlpcPs)) + l = atFound (has _ConP) + nestedPat = (unXRec <$> as) ^. l + as' = (unXRec <$> as) & l ?~ VarP n + & fmap nolo + +-- this is an illegal lens, and we're using it illegally. it's convenient :3 +-- TODO: adhere to the holy laws of the Lens Herself +atFound :: forall a. (a -> Bool) -> Lens' [a] (Maybe a) +atFound p = lens (find p) alter where + alter :: [a] -> Maybe a -> [a] + alter l Nothing = deleteFound l + alter l (Just x') = setFound x' l + + deleteFound :: [a] -> [a] + deleteFound [] = [] + deleteFound (x:xs) + | p x = xs + | otherwise = x : deleteFound xs + + setFound :: a -> [a] -> [a] + setFound _ [] = [] + setFound x' (x:xs) + | p x = x' : xs + | otherwise = x : setFound x' xs constructorToCore :: Type -> Tag -> ConAlt RlpcPs -> Program' constructorToCore t tag (ConAlt cn as) =