strings and a few other small nice changes

1 files changed, 45 insertions, 30 deletions

diff --git a/app/Parser.hs b/app/Parser.hs
index e6b7a7a..9d11cc8 100644
--- a/app/Parser.hs
+++ b/app/Parser.hs
@@ -5,7 +5,8 @@ module Parser
   , parsePrlg
   , shuntPrlg
   , PAST
-  , Lexeme
+  , Lexeme(..)
+  , PrlgStr(..)
   ) where
 
 import Control.Monad (void)
@@ -42,14 +43,13 @@ import Text.Megaparsec
   )
 import Text.Megaparsec.Char (string)
 
-import IR (PrlgStr(..))
 import Operators (ArgKind(..), Fixity(..), Op(..), Ops)
 
 singleToks = ",;|()[]{}!"
 
 identParts = "_"
 
-notOpToks = "\'" ++ identParts
+notOpToks = "'\"" ++ identParts
 
 isOperatorlike x =
   (isSymbol x || isPunctuation x) && not (x `elem` singleToks ++ notOpToks)
@@ -64,6 +64,7 @@ data Lexeme
   = Blank String
   | Tok String
   | QTok String String -- unquoted quoted
+  | DQTok String String -- unquoted quoted
   deriving (Show, Eq, Ord)
 
 blank :: Lexer Lexeme
@@ -86,14 +87,15 @@ qtok = do
   z <- string "'"
   return $ QTok y (x ++ y ++ z)
 
-cmt :: Lexer Lexeme
-cmt =
-  Blank . concat <$>
-  sequence
-    [string "%", many $ satisfy (/= '\n'), choice [string "\n", "" <$ eof]]
+dqtok :: Lexer Lexeme
+dqtok = do
+  x <- string "\""
+  y <- many $ satisfy (/= '\"') -- TODO actual escaping
+  z <- string "\""
+  return $ DQTok y (x ++ y ++ z)
 
 lexeme :: Lexer Lexeme
-lexeme = choice [blank, tok, qtok, cmt]
+lexeme = choice [blank, tok, qtok, dqtok]
 
 lexPrlg :: Lexer [Lexeme]
 lexPrlg = many lexeme <* (many blank >> eof)
@@ -101,6 +103,7 @@ lexPrlg = many lexeme <* (many blank >> eof)
 showTok (Blank x) = x
 showTok (Tok x) = x
 showTok (QTok _ x) = x
+showTok (DQTok _ x) = x
 
 instance VisualStream [Lexeme] where
   showTokens _ (a :| b) = concatMap showTok (a : b)
@@ -146,9 +149,9 @@ instance TraversableStream [Lexeme] where
 
 data PAST
   = Call String [[PAST]]
-  | Seq [PAST]
+  | Group [PAST]
   | List [[PAST]] (Maybe [PAST])
-  | Literal String
+  | Literal Lexeme
   deriving (Show, Eq)
 
 type Parser = Parsec Void [Lexeme]
@@ -165,6 +168,7 @@ isNormalTokStr = (`notElem` [".", "[", "]", "(", "|", ")", "{", "}"])
 isNormalTok :: Lexeme -> Bool
 isNormalTok (Tok x) = isNormalTokStr x
 isNormalTok (QTok _ _) = True
+isNormalTok (DQTok _ _) = True
 isNormalTok _ = False
 
 isCallTok :: Lexeme -> Bool
@@ -174,34 +178,35 @@ isCallTok _ = True
 
 unTok (Tok t) = t
 unTok (QTok t _) = t
+unTok (DQTok t _) = t
 
 literal :: Parser PAST
 literal =
-  Literal . unTok <$>
+  Literal <$>
   free
     (choice
        [ satisfy isCallTok <* notFollowedBy (choice [lParen, lBrace])
        , satisfy (\x -> not (isCallTok x) && isNormalTok x)
        ])
 
-makeParams (Seq inner) = splitOn [Literal ","] inner
+makeParams (Group inner) = splitOn [Literal (Tok ",")] inner
 
 call eb contents fmod = do
   fn <- fmod . unTok <$> satisfy isCallTok -- not free
   (Call fn [] <$ try eb) <|> (Call fn . makeParams <$> free contents)
 
-parens = Seq <$> (free lParen *> some seqItem <* free rParen)
+parens = Group <$> (free lParen *> some seqItem <* free rParen)
 
-braces = Seq <$> (free lBrace *> some seqItem <* free rBrace)
+braces = Group <$> (free lBrace *> some seqItem <* free rBrace)
 
-emptyParens = Literal "()" <$ (free lParen >> free rParen)
+emptyParens = Literal (QTok "()" "()") <$ (free lParen >> free rParen)
 
-emptyBraces = Literal "{}" <$ (free lBrace >> free rBrace)
+emptyBraces = Literal (QTok "{}" "{}") <$ (free lBrace >> free rBrace)
 
 list = do
   free lBracket
   (List [] Nothing <$ free rBracket) <|> do
-    items <- splitOn [Literal ","] <$> some seqItem
+    items <- splitOn [Literal (Tok ",")] <$> some seqItem
     (List items Nothing <$ free rBracket) <|>
       (List items . Just <$> (free listTail *> some seqItem <* free rBracket))
 
@@ -237,7 +242,7 @@ lBrace = simpleTok "{"
 rBrace = simpleTok "}"
 
 clause :: Parser PAST
-clause = Seq <$> some (free seqItem) <* free period
+clause = Group <$> some (free seqItem) <* free period
 
 parsePrlg :: Parser [PAST]
 parsePrlg = ws *> many clause <* eof
@@ -246,6 +251,11 @@ type ShuntError = String
 
 type ShuntResult = Either ShuntError PrlgStr
 
+data PrlgStr
+  = CallS String [PrlgStr]
+  | LiteralS Lexeme
+  deriving (Show)
+
 err :: ShuntError -> Either ShuntError a
 err = Left
 
@@ -254,8 +264,10 @@ shuntPrlg ot = shuntPrlg' (("", Op 0 $ Infix Y X) : ot)
 
 shuntPrlg' :: Ops -> PAST -> ShuntResult
 shuntPrlg' ot (List hs t) =
-  ListS <$> traverse (shunt ot) hs <*> traverse (shunt ot) t
-shuntPrlg' ot (Seq ss) = shunt ot ss
+  foldr (\x y -> CallS "[]" [x, y]) <$>
+  (maybe (LiteralS $ Tok "[]") id <$> traverse (shunt ot) t) <*>
+  traverse (shunt ot) hs
+shuntPrlg' ot (Group ss) = shunt ot ss
 shuntPrlg' ot (Literal s) = pure (LiteralS s)
 shuntPrlg' ot (Call fn ss) = CallS fn <$> traverse (shunt ot) ss
 
@@ -296,13 +308,13 @@ shunt optable = start
              (ops', vs') <- pushInfix ops vs x
              wo ops' vs' xs
         , do getOperand x
-             ho ops vs (Literal "" : xs') -- app (see below)
+             ho ops vs (Literal (Tok "") : xs') -- app (see below)
         , do getPrefix x
-             ho ops vs (Literal "" : xs') -- also app!
+             ho ops vs (Literal (Tok "") : xs') -- also app!
         , err "expected infix or suffix operator"
         ]
     {- incoming non-literal operand; there must be an app in between -}
-    ho ops vs xs@(_:_) = ho ops vs (Literal "" : xs)
+    ho ops vs xs@(_:_) = ho ops vs (Literal (Tok "") : xs)
     {- the last operand was last, pop until finished -}
     ho [] [res] [] = pure res
     ho ops vs [] = do
@@ -319,11 +331,14 @@ shunt optable = start
     {- Operator checks -}
     uniq [x] = pure x
     uniq _ = err "ambiguous operator"
-    getPrefix x = uniq [op | (s, op@(Op _ (Prefix _))) <- optable, s == x]
-    getSuffix x = uniq [op | (s, op@(Op _ (Suffix _))) <- optable, s == x]
-    getInfix x = uniq [op | (s, op@(Op _ (Infix _ _))) <- optable, s == x]
-    getOperand x
-      | null [op | (s, op) <- optable, s == x] = pure ()
+    getPrefix t =
+      uniq [op | Tok x <- [t], (s, op@(Op _ (Prefix _))) <- optable, s == x]
+    getSuffix t =
+      uniq [op | Tok x <- [t], (s, op@(Op _ (Suffix _))) <- optable, s == x]
+    getInfix t =
+      uniq [op | Tok x <- [t], (s, op@(Op _ (Infix _ _))) <- optable, s == x]
+    getOperand t
+      | null [op | Tok x <- [t], (s, op) <- optable, s == x] = pure ()
       | otherwise = err "expected an operand"
     {- actual pushery -}
     canPush :: Ops -> Op -> Either ShuntError Bool
@@ -371,7 +386,7 @@ shunt optable = start
     shunt1 ops vs x op = do
       cp <- canPush ops op
       if cp
-        then pure ((x, op) : ops, vs)
+        then pure ((unTok x, op) : ops, vs)
         else do
           (ops', vs') <- pop ops vs
           shunt1 ops' vs' x op --prefix would behave differently here but that's impossible by canPush