wildcard parser

Author: tittoassini

src/ZM/Parser/Exp.hs

@@ -14,7 +14,8 @@ module ZM.Parser.Exp where
 import Data.Bifunctor
 import Data.Text (Text)
 import qualified Data.Text as T
-import qualified Data.Text.IO as T
+
+-- import qualified Data.Text.IO as T
 import Prettyprinter
 import Text.Megaparsec
 import ZM.Parser.Bracket (Bracket, bracket, prettyBracket)
@@ -24,6 +25,8 @@ import ZM.Parser.Op
 import ZM.Parser.Types
 import ZM.Parser.Util
 
+-- import ZM.Parser (ADTParts(name))
+
 {- $setup
 >>> pr = parseMaybe (doc expr)
 >>> p = fmap pretty . pr
@@ -197,29 +200,18 @@ Just (F (InfixApp (F (Lit (LInteger 1))) "+" (F (InfixApp (F (Lit (LInteger 2)))
 
 {-
 >>> tt "rec"
+
+>>> tt "parser"
 -}
-tt mdlName = loadMdl $ concat ["../qq/qq-src/", mdlName, ".qq"]
-
-loadMdl :: FilePath -> IO ()
-loadMdl fileName = do
-  src <- T.readFile fileName
-  case testPretty src of
-    Left "no parse" -> parseTest mdl src
-    Left m -> putStr m
-    Right src2 -> T.writeFile fileName src2
-
-testPretty :: Text -> Either String Text
-testPretty src =
-  case parseMdl src of
-    Left e -> Left e
-    Right syntax ->
-      let src2 = show . pretty . unAnn $ syntax
-          syntax1 = unAnn syntax
-       in case parseMdlF $ T.pack src2 of
-            Left e -> Left e
-            Right syntax2
-              | syntax1 == syntax2 -> Right $ T.pack src2
-              | otherwise -> Left (unlines ["bad pretty: ", src2, "semantic was", show syntax1, T.unpack src, "now is", show syntax2, src2])
+-- tt mdlName = loadMdl $ concat ["../qq/qq-src/", mdlName, ".qq"]
+
+-- loadMdl :: FilePath -> IO ()
+-- loadMdl fileName = do
+--   src <- T.readFile fileName
+--   case testPretty src of
+--     Left "no parse" -> parseTest mdl src
+--     Left m -> putStr m
+--     Right src2 -> T.writeFile fileName src2
 
 parseMdl :: T.Text -> Either String Exp
 parseMdl = first errorBundlePretty . runParser mdl ""
@@ -295,12 +287,16 @@ simple =
     , pre
     , con
     , lit
+    , wld
     ]
 
 par :: Parser Exp
 -- par = located $ Par <$> parenthesis expr
 par = parenthesis expr
 
+wld :: Parser Exp
+wld = located $ Wild <$> wild
+
 pre :: Parser Exp
 pre = located $ Prefix <$> prefixOp
 
@@ -320,15 +316,18 @@ lit = located $ Lit <$> literal
 -- type Expr = Fix ExpR
 data ExpR r
   = App r r
-  | InfixApp r Text r
-  | -- Universal App: App+Infix App + Section
+  | -- Universal App: App+Infix App + Section (What about functions with a single arg?)
 
     -- | App Text (These r r)
-    Con Text -- Constructor (e.g. "True")
-  | Prefix Text
-  | -- | Infix Text
-    Field Text
-  | -- | Par r
+    -- ?Or App r (These r r)
+    Prefix Text
+  | InfixApp r Text r
+  | Wild Text -- Wildcard (without initial _)
+  | Con Text -- Constructor (e.g. "True")
+  | -- \| Par r
+
+    -- | Infix Text
+    -- Field Text
     Arr (Bracket r)
   | Lit Literal
   deriving (Show, Eq, Functor)
@@ -350,7 +349,21 @@ data Arg = NoArg | PreArg | InfArg deriving (Show, Eq)
 >>> sup "foo bar  + big bop"
 Just foo bar + big bop
 
+>>> pr "x = y"
+Just (Ann 0 (InfixApp (Ann 0 (Prefix "x")) "=" (Ann 4 (Prefix "y"))))
+
+>>> sup "[[]]"
+Just [
+   [
+   ]
+]
+
+>>> sup "Z -> y -> y"
+Just Z -> (y -> y)
+
 >>> tt "rec"
+
+>>> tt "add"
 -}
 instance (PrettyArg r) => PrettyArg (ExpR r) where
   prettyArg arg =
@@ -370,29 +383,25 @@ instance (PrettyArg r) => PrettyArg (ExpR r) where
         Con name -> pretty name
         Arr brk -> prettyBracket no brk
         Prefix name -> pretty name
-        Field name -> pretty name
+        Wild name -> "_" <> pretty name
+        -- Field name -> pretty name
         Lit l -> pretty l
 
--- onArg PreArg d = "(" <> d <> ")"
--- onArf InfArg d = d
-
--- prettyArg :: Pretty r => ExpR r  -> Doc ann
--- prettyArg_ e
---   | isSimple e = pretty e
---   | otherwise = "(" <> pretty e <> ")"
-
--- isSimple :: ExpR r -> Bool
--- isSimple (App _ _) = False
--- isSimple (InfixApp{}) = False
--- isSimple _ = True
-
--- instance (Pretty (f (Annotate () f))) => Pretty (Annotate () f) where
---     pPrint (Ann () f) = pPrint f
-
--- instance (Pretty r) => Pretty (ExpR r) where
---   pPrint (App f a) = chr '(' <> hsep [pPrint f, pPrint a] <> chr ')'
---   pPrint (Con name) = txt name
---   pPrint (Prefix name) = txt name
---   pPrint (Infix name) = txt name
---   pPrint (Arr brk) = pPrint brk
---   pPrint (Lit l) = pPrint l
+{-
+pat =>  lpat qconop pat (infix constructor)
+        | lpat
+
+lpat => apat | - (integer | float) (negative literal) | gcon apat1 ... apatk (arity gcon = k, k >= 1)
+
+apat => var [ @ apat] (as pattern)
+      | gcon (arity gcon = 0)
+      | qcon { fpat1 ... fpatk } (labeled pattern, k >= 0)
+      | literal
+      | _ (wildcard)
+      | ( pat ) (parenthesized pattern)
+      | ( pat1 ... patk ) (tuple pattern, k >= 2)
+      | [ pat1 ... patk ] (list pattern, k >= 1)
+      | ˜ apat (irrefutable pattern)
+
+fpat => qvar = pat
+-}

src/ZM/Parser/Lexer.hs

@@ -13,7 +13,7 @@ module ZM.Parser.Lexer (
     eof,
     lexeme,
     -- $lexemes
-    var,
+    wild,
     identifier,
     sym,
     constr,
@@ -26,6 +26,7 @@ module ZM.Parser.Lexer (
 -- import Data.Word
 
 import Data.Char as C
+import Data.Maybe
 import Data.Text (Text, pack)
 import qualified Data.Text as T
 import Text.Megaparsec hiding (Label)
@@ -107,7 +108,6 @@ lineEnd =
 --       setOffset o
 --       fail msg
 
-
 localId :: Parser Text
 localId = lexeme name
 
@@ -181,21 +181,28 @@ symChar =
         <?> "sym"
 {-# INLINE symChar #-}
 
-{- |
->>> parseMaybe var "是不是"
-Nothing
+{-
+>>> let p = parseMaybe wild
 
->>> parseMaybe var "_"
-Just Nothing
+>>> p "_"
+Just ""
 
->>> parseMaybe var "_a"
-Just (Just "a")
+>>> p "__"
+Just "_"
 
->>> parseMaybe var "_是不是"
-Just (Just "\26159\19981\26159")
+>>> p "___"
+Just "__"
+
+>>> p "_a"
+Just "a"
+
+>>> p "_是不是"
+Nothing
 -}
-var :: Parser (Maybe Text)
-var = lexeme (char '_' *> optional name)
+wild :: Parser Text
+wild = lexeme $ T.tail <$> wld
+  where
+    wld = T.cons <$> char '_' <*> (fromMaybe T.empty <$> optional (name <|> wld))
 
 {- |
 Parse a specific string

src/ZM/Parser/Op.hs

@@ -6,69 +6,78 @@ module ZM.Parser.Op (
 ) where
 
 import Data.Char as C
-import Data.Text (Text, pack)
+import Data.Text (Text)
 import qualified Data.Text as T
 import Text.Megaparsec
-import Text.Megaparsec hiding (Label)
 import Text.Megaparsec.Char
 import ZM.Parser.Lexer
 import ZM.Parser.Types
 
+-- TODO: test that the different syntactical classes (infix,prefix,wild) are mutually exclusive
+
 {- |
 Parse a ZM prefixOp (a unicode letter followed by zero or more unicode alphanumeric characters or '_')
 
->>> parseMaybe prefixOp "*"
+>>> let p = parseMaybe prefixOp
+
+>>> p "*"
 Nothing
 
->>> parseMaybe prefixOp "1"
+>>> p "1"
 Nothing
 
->>> parseMaybe prefixOp "A"
-Just "A"
+>>> p "A"
+Nothing
 
->>> parseMaybe prefixOp "Gold金en"
-Just "Gold\37329en"
+NOTE: no support for non-ascii characters
 
->>> parseMaybe prefixOp "是不是"
-Just "\26159\19981\26159"
+>>> p "Gold金en"
+Nothing
 
->>> parseMaybe prefixOp "Bool -- a bool"
-Just "Bool"
+>>> p "是不是"
+Nothing
 
->>> parseMaybe prefixOp "ant_13_"
+>>> p "Bool -- a bool"
+Nothing
+
+>>> p "ant_13_"
 Just "ant_13_"
+
+>>> p "abc12"
+Just "abc12"
+
+>>> p "abc1*"
+Nothing
+
+>>> Nothing == p "True"
+True
+
+>>> Nothing == p "_"
+True
 -}
 
 -- TODO: add (+) `add`
 
 prefixOp :: Parser Text
-prefixOp = lexeme name
+prefixOp = lexeme var
 
-{-
->>> parseMaybe (infixOp >> char '}') "*}"
-Just '}'
--}
-infixOp :: Parser Text
-infixOp = lexeme sym
+var :: Parser Text
+var = T.cons <$> lowerChar <*> takeWhileP (Just "alpha numeric or _") (\c -> isAlphaNum c || c == '_')
 
 {-
+>>> parseMaybe infixOp "++"
+Just "++"
 
-FIX THIS?
-
->>> parseMaybe name "_asd"
-Nothing
-
->>> parseMaybe name "abc12"
-Just "abc12"
+>>> parseMaybe infixOp "_"
+Just "_"
 
->>> parseMaybe name "abc1*"
+>>> parseMaybe infixOp "_xyz"
 Nothing
 
->>> Nothing == parseMaybe name "True"
-True
-
->>> Nothing == parseMaybe name "_"
-True
+>>> parseMaybe (infixOp >> char '}') "*}"
+Just '}'
 -}
-name :: Parser Text
-name = T.cons <$> lowerChar <*> takeWhileP (Just "alpha numeric or _") (\c -> isAlphaNum c || c == '_')
+infixOp :: Parser Text
+infixOp = lexeme sym
+
+-- wild = char '_' >> return PWild

src/ZM/Parser/Value.hs

@@ -4,13 +4,14 @@ module ZM.Parser.Value (
   value,
   pattern,
   Value,
-  Pattern
+  Pattern,
 )
 where
 
 import Data.Text (Text)
+import qualified Data.Text as T
 import Text.Megaparsec
-import ZM.Parser.Lexer hiding (constr)
+import ZM.Parser.Lexer ( localId, symbol, wild )
 import ZM.Parser.Literal
 import ZM.Parser.Types
 import ZM.Parser.Util
@@ -127,7 +128,9 @@ special =
 
 -- TODO: Add VArray
 binds :: Parser (Val lit Binder)
-binds = maybe PWild PBind <$> var
+-- binds = maybe PWild PBind <$> wild
+-- ???
+binds = (\w -> if T.null w then PWild else PBind w) <$> wild
 
 nestedValue :: Parser (Val lit binder) -> Parser (Val lit binder)
 nestedValue v =
@@ -137,12 +140,10 @@ fieldsV
   , unnamedFields ::
     Parser (Val lit binder) ->
     Parser (Either [Val lit binder] [(Text, Val lit binder)])
-
 -- fields :: Parser ValueFields
 fieldsV v = namedFields v <|> unnamedFields v
 
 -- | Parse unnamed fields
-
 unnamedFields v = Left <$> many (nestedValue v)
 
 {- | Parse a set of named fields