wip remove extensible uni and fun.

IntersectMBO · Jan 13, 2022 · d9e5145 · d9e5145
1 parent 0c3574e
commit d9e5145
Show file tree

Hide file tree

Showing 5 changed files with 44 additions and 101 deletions.
diff --git a/plutus-core/plutus-core/src/PlutusCore.hs b/plutus-core/plutus-core/src/PlutusCore.hs
@@ -1,7 +1,6 @@
 -- Why is it needed here, but not in "Universe.Core"?
 {-# LANGUAGE ExplicitNamespaces #-}
 {-# LANGUAGE PatternSynonyms    #-}
-{-# LANGUAGE TypeApplications   #-}
 
 module PlutusCore
     (
@@ -150,11 +149,10 @@ import PlutusCore.Error
 import PlutusCore.Evaluation.Machine.Ck
 import PlutusCore.Evaluation.Machine.ExBudgetingDefaults
 import PlutusCore.Flat ()
-import PlutusCore.Lexer
-import PlutusCore.Lexer.Type
 import PlutusCore.Name
 import PlutusCore.Normalize
 import PlutusCore.Parser
+import PlutusCore.Parser.Type
 import PlutusCore.Pretty
 import PlutusCore.Quote
 import PlutusCore.Rename

diff --git a/plutus-core/plutus-core/src/PlutusCore/Flat.hs b/plutus-core/plutus-core/src/PlutusCore/Flat.hs
@@ -21,8 +21,8 @@ module PlutusCore.Flat
 import PlutusCore.Core
 import PlutusCore.Data
 import PlutusCore.DeBruijn
-import PlutusCore.Lexer.Type
 import PlutusCore.Name
+import PlutusCore.Parser.Type
 
 import Codec.Serialise (Serialise, deserialiseOrFail, serialise)
 import Data.Functor
@@ -311,7 +311,6 @@ instance ( Flat ann
 deriving newtype instance (Flat a) => Flat (Normalized a)
 
 instance Flat Keyword
-instance Flat Special
 
 deriving newtype instance Flat Index
 

diff --git a/plutus-core/plutus-core/src/PlutusCore/Parser/Internal.hs b/plutus-core/plutus-core/src/PlutusCore/Parser/Internal.hs
@@ -10,9 +10,9 @@ import PlutusPrelude
 import PlutusCore.Core
 import PlutusCore.Error
 import PlutusCore.Lexer
-import PlutusCore.Lexer.Type
 import PlutusCore.Name
 import PlutusCore.Parsable
+import PlutusCore.Parser.Type
 
 import Control.Monad.Except
 import Universe

diff --git a/plutus-core/plutus-core/src/PlutusCore/Parser/Lexer.hs b/plutus-core/plutus-core/src/PlutusCore/Parser/Lexer.hs
@@ -4,15 +4,15 @@
 module PlutusCore.Parser.Lexer where
 
 import PlutusCore qualified as PLC
-import PlutusCore.Lexer.Type as LT
-import PlutusCore.ParserCommon as PLC (Parser)
+import PlutusCore.Parser.ParserCommon as PLC (Parser)
+import PlutusCore.Parser.Type as LT
 import PlutusPrelude (NonEmpty ((:|)), Pretty (pretty), Render (render))
 
 import Data.List qualified as DL
 import Data.List.NonEmpty qualified as NE
 import Data.Proxy (Proxy (..))
 import Data.Set qualified as Set
-import PlutusCore.Lexer.Type (Keyword (KwIFix, KwLam))
+import PlutusCore.Parser.Type (Keyword (KwIFix, KwLam))
 import Text.Megaparsec
 import Text.Megaparsec.Byte
 import Text.Megaparsec.Char

diff --git a/plutus-core/plutus-ir/src/PlutusIR/Parser.hs b/plutus-core/plutus-ir/src/PlutusIR/Parser.hs
@@ -32,93 +32,82 @@ import Text.Megaparsec hiding (ParseError, State, many, parse, some)
 
 type PType = PLC.Type TyName DefaultUni DefaultFun
 
-recursivity :: Parser SourcePos Recursivity
+recursivity :: Parser  Recursivity
 recursivity = inParens $ (wordPos "rec" >> return Rec) <|> (wordPos "nonrec" >> return NonRec)
 
-strictness :: Parser SourcePos Strictness
+strictness :: Parser  Strictness
 strictness = inParens $ (wordPos "strict" >> return Strict) <|> (wordPos "nonstrict" >> return NonStrict)
 
-allType
-    :: PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni))
-    => Parser SourcePos (Type TyName uni SourcePos)
-allType = TyForall <$> wordPos "all" <*> tyName <*> kind <*> typ
-
-lamType
-    :: PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni))
-    => Parser SourcePos (Type TyName uni SourcePos)
-lamType = TyLam <$> wordPos "lam" <*> tyName <*> kind <*> typ
-
 pTyVar
     :: PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni))
-    => Parser SourcePos (Type TyName uni SourcePos)
-pTyVar = wordPos "con" >> pTyBuiltin
+    => Parser  PType
+pTyVar = TyVar <$> wordPos "con" <*> tyName
 
-pTyBuiltin
-    :: PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni))
-    => Parser SourcePos (Type TyName uni SourcePos)
-pTyBuiltin = do
-    p <- getSourcePos
-    PLC.SomeTypeIn (PLC.Kinded uni) <- builtinTypeTag
-    pure . TyBuiltin p $ PLC.SomeTypeIn uni
+pTyBuiltin :: Parser PType
+pTyBuiltin = TyBuiltin <$> wordPos "con" <*> defaultUniType
 
-kind :: Parser SourcePos (Kind SourcePos)
+kind :: Parser (Kind SourcePos)
 kind = inParens (typeKind <|> funKind)
     where
         typeKind = Type <$> wordPos "type"
         funKind  = KindArrow <$> wordPos "fun" <*> kind <*> kind
 
-typ
-    :: PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni))
-    => Parser SourcePos (Type TyName uni SourcePos)
-typ = (tyName >>= (\n -> getSourcePos >>= \p -> return $ TyVar p n))
-    <|> (inParens $ funType <|> allType <|> lamType <|> ifixType <|> conType)
-    <|> inBrackets appType
+defaultUniType :: Parser (SomeTypeIn DefaultUni)
+defaultUniType = choice
+  [ inParens defaultUniType
+  , SomeTypeIn DefaultUniInteger <$ string "integer"
+  , SomeTypeIn DefaultUniByteString <$ string "bytestring"
+  , SomeTypeIn DefaultUniString <$ string "string"
+  , SomeTypeIn DefaultUniUnit <$ string "unit"
+  , SomeTypeIn DefaultUniBool <$ string "bool"
+  , SomeTypeIn DefaultUniProtoList <$ string "list"
+  , SomeTypeIn DefaultUniProtoPair <$ string "pair"
+  -- , SomeTypeIn DefaultUniApply <$ string "?" TODO need to make this an operator
+  , SomeTypeIn DefaultUniData <$ string "data" ]
 
 -- | Parser for @Type@. All constructors that have @Type@ as argument are @operators@.
-pType :: Parser SourcePos (Type TyName PLC.DefaultUni SourcePos)
+pType :: Parser  (Type TyName PLC.DefaultUni SourcePos)
 pType = choice
   [ inParens pType
   , pTyVar
   , pTyBuiltin
   ]
 
-operatorTable :: [[Operator (Parser SourcePos) PType]]
+operatorTable :: [[Operator Parser PType]]
 operatorTable =
-  [ [ prefix "fun" TyFun
+  [ [ binary "fun" TyFun
     , binary "ifix" TyIFix
     , binary "app" TyApp
+    , kindBinary "all" TyForall
+    , kindBinary "lam" TyLam
     ]
   ]
 
 parseType = makeExprParser pType operatorTable
 
-prefix  name f = Prefix  (f <$ symbol name)
-binary :: Text -> (PType -> PType -> PType) -> Operator Parser PType
-binary  name f = Prefix  (f <$ symbol name)
+binary :: Text -> (SourcePos -> PType -> PType -> PType) -> Operator Parser PType
+binary name f = Prefix  (f <$ symbol name)
+
+kindBinary :: Text -> (SourcePos -> TyName -> Kind SourcePos -> PType -> PType) -> Operator Parser PType
+kindBinary name f = Prefix (f <$ symbol name)
 
 varDecl
     :: PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni))
-    => Parser SourcePos (VarDecl TyName Name uni fun SourcePos)
+    => Parser  (VarDecl TyName Name uni fun SourcePos)
 varDecl = inParens $ VarDecl <$> wordPos "vardecl" <*> name <*> typ
 
-tyVarDecl :: Parser SourcePos (TyVarDecl TyName SourcePos)
+tyVarDecl :: Parser (TyVarDecl TyName SourcePos)
 tyVarDecl = inParens $ TyVarDecl <$> wordPos "tyvardecl" <*> tyName <*> kind
 
-datatype
-    :: PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni))
-    => Parser SourcePos (Datatype TyName Name uni fun SourcePos)
+datatype :: Parser (Datatype TyName Name DefaultUni DefaultFun SourcePos)
 datatype = inParens $ Datatype <$> wordPos "datatype"
     <*> tyVarDecl
     <*> many tyVarDecl
     <*> name
     <*> many varDecl
 
 binding
-    :: ( PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni))
-       , PLC.Closed uni, uni `PLC.Everywhere` PLC.Parsable
-       , Bounded fun, Enum fun, Pretty fun
-       )
-    => Parser SourcePos (Binding TyName Name uni fun SourcePos)
+    :: Parser (Binding TyName Name DefaultUni DefaultFun SourcePos)
 binding = inParens $
     (try $ wordPos "termbind" >> TermBind <$> getSourcePos <*> strictness <*> varDecl <*> term)
     <|> (wordPos "typebind" >> TypeBind <$> getSourcePos <*> tyVarDecl <*> typ)
@@ -127,8 +116,8 @@ binding = inParens $
 -- A small type wrapper for parsers that are parametric in the type of term they parse
 type Parametric uni fun
     = forall term. PIR.TermLike term TyName Name uni fun
-    => Parser SourcePos (term SourcePos)
-    -> Parser SourcePos (term SourcePos)
+    => Parser  (term SourcePos)
+    -> Parser  (term SourcePos)
 
 absTerm :: Parametric uni fun
 absTerm tm = PIR.tyAbs <$> wordPos "abs" <*> tyName <*> kind <*> tm
@@ -155,12 +144,7 @@ unwrapTerm tm = PIR.unwrap <$> wordPos "unwrap" <*> tm
 errorTerm :: PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni)) => Parametric uni fun
 errorTerm _tm = PIR.error <$> wordPos "error" <*> typ
 
-letTerm
-    :: ( PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni))
-       , PLC.Closed uni, uni `PLC.Everywhere` PLC.Parsable
-       , Bounded fun, Enum fun, Pretty fun
-       )
-    => Parser SourcePos (Term TyName Name uni fun SourcePos)
+letTerm :: Parser (Term TyName Name DefaultUni DefaultFun SourcePos)
 letTerm = Let <$> wordPos "let" <*> recursivity <*> NE.some (try binding) <*> term
 
 appTerm :: Parametric uni fun
@@ -169,42 +153,9 @@ appTerm tm = PIR.mkIterApp <$> getSourcePos <*> tm <*> some tm
 tyInstTerm :: PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni)) => Parametric uni fun
 tyInstTerm tm = PIR.mkIterInst <$> getSourcePos <*> tm <*> some typ
 
-term'
-    :: ( PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni))
-       , PLC.Closed uni, uni `PLC.Everywhere` PLC.Parsable
-       , Bounded fun, Enum fun, Pretty fun
-       )
-    => Parametric uni fun
-term' other = (name >>= (\n -> getSourcePos >>= \p -> return $ PIR.var p n))
-    <|> (inParens $ absTerm self <|> lamTerm self <|> conTerm self <|> iwrapTerm self <|> builtinTerm self <|> unwrapTerm self <|> errorTerm self <|> other)
-    <|> inBraces (tyInstTerm self)
-    <|> inBrackets (appTerm self)
-    where self = term' other
-
-term
-    :: ( PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni))
-       , PLC.Closed uni, uni `PLC.Everywhere` PLC.Parsable
-       , Bounded fun, Enum fun, Pretty fun
-       )
-    => Parser SourcePos (Term TyName Name uni fun SourcePos)
-term = term' letTerm
-
-plcTerm
-    :: ( PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni))
-       , PLC.Closed uni, uni `PLC.Everywhere` PLC.Parsable
-       , Bounded fun, Enum fun, Pretty fun
-       )
-    => Parser SourcePos (PLC.Term TyName Name uni fun SourcePos)
-plcTerm = term' empty
-
 -- Note that PIR programs do not actually carry a version number
 -- we (optionally) parse it all the same so we can parse all PLC code
-program
-    :: ( PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni))
-       , PLC.Closed uni, uni `PLC.Everywhere` PLC.Parsable
-       , Bounded fun, Enum fun, Pretty fun
-       )
-    => Parser SourcePos (Program TyName Name uni fun SourcePos)
+program :: Parser (Program TyName Name DefaultUni DefaultFun SourcePos)
 program = whitespace >> do
     prog <- inParens $ do
         p <- wordPos "program"
@@ -213,12 +164,7 @@ program = whitespace >> do
     notFollowedBy anySingle
     return prog
 
-plcProgram
-    :: ( PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni))
-       , PLC.Closed uni, uni `PLC.Everywhere` PLC.Parsable
-       , Bounded fun, Enum fun, Pretty fun
-       )
-    => Parser SourcePos (PLC.Program TyName Name uni fun SourcePos)
+plcProgram :: Parser (PLC.Program TyName Name DefaultUni DefaultFun SourcePos)
 plcProgram = whitespace >> do
     prog <- inParens $ PLC.Program <$> wordPos "program" <*> version <*> plcTerm
     notFollowedBy anySingle