Core: remove keywords, simplify parsetree, unify desugar

pact-lsp/Pact/Core/LanguageServer.hs

@@ -364,16 +364,8 @@ processFile replEnv nuri source = do
         _ | isAbsolute fp -> pure fp
           | takeFileName currFile == currFile -> pure fp
           | otherwise -> pure $ combine (takeDirectory currFile) fp
-    pipe = \case
-      Lisp.RTL (Lisp.RTLTopLevel tl) -> do
-        functionDocs tl
-        (ds, deps) <- compileDesugarOnly replEnv tl
-        constEvaled <- ConstEval.evalTLConsts replEnv ds
-        let tlFinal = MHash.hashTopLevel constEvaled
-        let act = M.singleton nuri [ds] <$ evalTopLevel replEnv tlFinal deps
-        catchError act (const (pure mempty))
-      Lisp.RTLReplSpecial rtl -> case rtl of
-        Lisp.ReplLoad fp _ i -> do
+    pipe rtl = case Repl.topLevelIsReplLoad rtl of
+      Right (Repl.ReplLoadFile fp _ i) -> do
           fp' <- mangleFilePath (T.unpack fp)
           res <- liftIO $ E.try (T.readFile fp')
           case res of
@@ -382,6 +374,13 @@ processFile replEnv nuri source = do
              Right txt -> do
                let nfp = normalizedFilePathToUri (toNormalizedFilePath fp')
                processFile replEnv nfp txt
+      Left (Lisp.RTLTopLevel tl) -> do
+        functionDocs tl
+        (ds, deps) <- compileDesugarOnly replEnv tl
+        constEvaled <- ConstEval.evalTLConsts replEnv ds
+        let tlFinal = MHash.hashTopLevel constEvaled
+        let act = M.singleton nuri [ds] <$ evalTopLevel replEnv tlFinal deps
+        catchError act (const (pure mempty))
       _ ->  pure mempty
 
 sshow :: Show a => a -> Text

pact-lsp/Pact/Core/LanguageServer/Utils.hs

@@ -11,7 +11,6 @@ import Pact.Core.IR.Term
 import Pact.Core.Builtin
 import Control.Lens hiding (inside)
 import Pact.Core.Imports
-import Pact.Core.Capabilities
 
 termAt
   :: Position
@@ -24,25 +23,22 @@ termAt p term
         termAt p tm1 <|> getAlt (foldMap (Alt . termAt p) tm2) <|> Just t
       t@(Let _ tm1 tm2 _) -> termAt p tm1 <|> termAt p tm2 <|> Just t
       t@(Sequence tm1 tm2 _) -> termAt p tm1 <|> termAt p tm2 <|> Just t
-      t@(Conditional op' _) ->
+      t@(BuiltinForm op' _) ->
         case op' of
           CAnd a b  -> termAt p a <|> termAt p b
           COr a b   -> termAt p a <|> termAt p b
           CIf a b c -> termAt p a <|> termAt p b <|> termAt p c
-          CEnforceOne a bs -> termAt p a <|> getAlt (foldMap (Alt . termAt p) bs)
+          CEnforceOne a b -> termAt p a <|> termAt p b
           CEnforce a b -> termAt p a <|> termAt p b
+          CWithCapability a b -> termAt p a <|> termAt p b
+          CTry a b -> termAt p a <|> termAt p b
+          CCreateUserGuard a -> termAt p a
         <|> Just t
       t@(ListLit tms _) -> getAlt (foldMap (Alt . termAt p) tms) <|> Just t
-      t@(Try tm1 tm2 _) -> termAt p tm1 <|> termAt p tm2 <|> Just t
       t@(Nullary tm _) -> termAt p tm <|> Just t
       t@(ObjectLit l _) -> getAlt (foldMap (\(_, tm) -> Alt (termAt p tm)) l) <|> Just t
-      t@(CapabilityForm cf _) -> termAtCapForm cf <|> Just t
       t -> Just t
   | otherwise = Nothing
-  where
-    termAtCapForm = \case
-      WithCapability tm1 tm2 -> termAt p tm1 <|> termAt p tm2
-      CreateUserGuard _ tms -> getAlt (foldMap (Alt . termAt p) tms)
 
 data PositionMatch b i
   = ModuleMatch (EvalModule b i)

pact-tests/Pact/Core/Test/LexerParserTests.hs

@@ -17,6 +17,7 @@ import qualified Pact.Core.Syntax.Parser as Lisp
 import Pact.Core.Syntax.LexUtils (Token(..))
 import Pact.Core.Literal
 import Pact.Core.Pretty
+import Pact.Core.Syntax.ParseTree (LetForm(LFLetNormal))
 
 showPretty :: Pretty a => a -> T.Text
 showPretty = T.pack . show . pretty
@@ -39,9 +40,8 @@ tokenGen = Gen.choice $ unary ++ [ TokenIdent <$> identGen, number, string]
     -- and num and turn this into an enum bounded call
     unary = Gen.constant
       <$> [ TokenLet
-          , TokenIf
+          , TokenLetStar
           , TokenLambda
-          , TokenTry
           , TokenModule
           , TokenInterface
           , TokenImport
@@ -64,14 +64,8 @@ tokenGen = Gen.choice $ unary ++ [ TokenIdent <$> identGen, number, string]
           , TokenColon
           , TokenDot
           -- Operators
-          , TokenAnd
-          , TokenOr
           , TokenTrue
           , TokenFalse
-          , TokenBlockIntro
-          , TokenSuspend
-          -- Repl-specific tokens
-          , TokenLoad
           ]
 
 lexerRoundtrip :: Property
@@ -132,26 +126,19 @@ constantGen = (`Lisp.Constant` ()) <$> Gen.choice
       pure $ LDecimal (Decimal i m)
 
 
-operatorGen :: ParserGen
-operatorGen = Gen.choice $ (\x -> pure (Lisp.Operator x ())) <$> [minBound .. ]
-
 exprGen :: ParserGen
 exprGen = Gen.recursive Gen.choice
   [ varGen
   , constantGen
-  , operatorGen
   ]
   -- recursive ones
-  [ Gen.subterm exprGen (`Lisp.Suspend` ())
-  , Gen.subterm2 exprGen exprGen (\x y -> Lisp.Try x y ())
-  , Gen.subtermM exprGen $ \x -> do
+  [ Gen.subtermM exprGen $ \x -> do
       xs <- Gen.list (Range.linear 0 8) exprGen
       pure $ Lisp.App x xs ()
   , (`Lisp.Block` ()) <$> Gen.nonEmpty (Range.linear 1 8) (Gen.subterm exprGen id)
   , (`Lisp.List` ()) <$> Gen.list (Range.linear 1 8) (Gen.subterm exprGen id)
   , lamGen
   , Gen.subtermM exprGen letGen
-  , Gen.subterm3 exprGen exprGen exprGen (\a b c -> Lisp.If a b c ())
   ]
   where
     lamGen = do
@@ -164,7 +151,7 @@ exprGen = Gen.recursive Gen.choice
 
     letGen inner = do
       binders <- Gen.nonEmpty (Range.constant 1 8) binderGen
-      pure $ Lisp.LetIn binders inner ()
+      pure $ Lisp.Let LFLetNormal binders inner ()
 
     typeGen :: Gen Lisp.Type
     typeGen = Gen.recursive Gen.choice

pact/Pact/Core/Builtin.hs

@@ -22,8 +22,12 @@ module Pact.Core.Builtin
  , ReplCoreBuiltin
  , BuiltinForm(..)
  , ReplOnlyBuiltin(..)
+ , _CAnd, _COr, _CIf
+ , _CEnforceOne, _CEnforce
+ , _CWithCapability, _CCreateUserGuard
  )where
 
+import Control.Lens
 import Data.Text(Text)
 import Data.Map.Strict(Map)
 import Control.DeepSeq
@@ -44,8 +48,11 @@ data BuiltinForm o
   = CAnd o o
   | COr o o
   | CIf o o o
-  | CEnforceOne o [o]
   | CEnforce o o
+  | CWithCapability o o
+  | CCreateUserGuard o
+  | CEnforceOne o o
+  | CTry o o
   deriving (Show, Eq, Functor, Foldable, Traversable, Generic)
 
 instance NFData o => NFData (BuiltinForm o)
@@ -58,10 +65,16 @@ instance Pretty o => Pretty (BuiltinForm o) where
       parens ("or" <+> pretty o <+> pretty o')
     CIf o o' o3 ->
       parens ("if" <+> pretty o <+> pretty o' <+> pretty o3)
-    CEnforceOne o li ->
-      parens ("enforce-one" <+> pretty o <+> brackets (hsep (punctuate comma (pretty <$> li))))
+    CEnforceOne o o' ->
+      parens ("enforce-one" <+> pretty o <+> pretty o')
     CEnforce o o' ->
       parens ("enforce" <+> pretty o <+> pretty o')
+    CWithCapability o o' ->
+      parens ("with-capability" <+> pretty o <+> pretty o')
+    CCreateUserGuard o ->
+      parens ("create-user-guard" <+> pretty o)
+    CTry o o' ->
+      parens ("try" <+> pretty o <+> pretty o')
 
 -- | Our list of base-builtins to pact.
 data CoreBuiltin
@@ -943,3 +956,4 @@ instance (Pretty b) => Pretty (ReplBuiltin b) where
 
 deriveConstrInfo ''CoreBuiltin
 deriveConstrInfo ''ReplOnlyBuiltin
+makePrisms ''BuiltinForm

pact/Pact/Core/Capabilities.hs

@@ -8,8 +8,6 @@
 module Pact.Core.Capabilities
  ( DefCapMeta(..)
  , DefManagedMeta(..)
- , CapForm(..)
- , capFormName
  , CapToken(..)
  , ctName, ctArgs
  , CapSlot(..)
@@ -57,23 +55,23 @@ dcMetaFqName f = \case
     DefManaged . DefManagedMeta i . FQName <$> f fqn
   p -> pure p
 
-data CapForm name e
-  = WithCapability e e
-  | CreateUserGuard name [e]
-  deriving (Show, Functor, Foldable, Traversable, Eq, Generic)
+-- data CapForm name e
+--   = WithCapability e e
+--   | CreateUserGuard name [e]
+--   deriving (Show, Functor, Foldable, Traversable, Eq, Generic)
 
 
-capFormName :: Traversal (CapForm name e) (CapForm name' e) name name'
-capFormName f = \case
-  WithCapability e e' -> pure (WithCapability e e')
-  CreateUserGuard name es -> (`CreateUserGuard` es) <$> f name
+-- capFormName :: Traversal (CapForm name e) (CapForm name' e) name name'
+-- capFormName f = \case
+--   WithCapability e e' -> pure (WithCapability e e')
+--   CreateUserGuard name es -> (`CreateUserGuard` es) <$> f name
 
-instance (Pretty name, Pretty e) => Pretty (CapForm name e) where
-  pretty = \case
-    WithCapability cap body ->
-      parens ("with-capability" <+> parens (pretty cap <+> pretty body))
-    CreateUserGuard name es ->
-      parens ("create-user-guard" <+> parens (pretty name <+> hsep (pretty <$> es)))
+-- instance (Pretty name, Pretty e) => Pretty (CapForm name e) where
+--   pretty = \case
+--     WithCapability cap body ->
+--       parens ("with-capability" <+> parens (pretty cap <+> pretty body))
+--     CreateUserGuard name es ->
+--       parens ("create-user-guard" <+> parens (pretty name <+> hsep (pretty <$> es)))
 
 -- | An acquired capability token
 -- with the reference
@@ -170,7 +168,7 @@ instance (Pretty name, Pretty v) => Pretty (CapToken name v) where
     pretty $ PrettyLispApp qn args
 
 instance (NFData name, NFData v) => NFData (Signer name v)
-instance (NFData name, NFData e) => NFData (CapForm name e)
+-- instance (NFData name, NFData e) => NFData (CapForm name e)
 instance (NFData name, NFData v) => NFData (ManagedCap name v)
 instance NFData v => NFData (ManagedCapType v)
 instance NFData v => NFData (PactEvent v)