tweak name ticking

2 files changed, 25 insertions, 18 deletions

diff --git a/src/LambdaCube/Compiler/Lexer.hs b/src/LambdaCube/Compiler/Lexer.hs
index 83446799..f7c96bf6 100644
--- a/src/LambdaCube/Compiler/Lexer.hs
+++ b/src/LambdaCube/Compiler/Lexer.hs
@@ -205,10 +205,14 @@ data Namespace = Namespace
     }
   deriving (Show)
 
+namespace' = namespaceLevel <$> namespace
+
 tick = (\case TypeLevel -> switchTick; _ -> id) . fromMaybe ExpLevel . namespaceLevel
 
 tick' c = (`tick` c) <$> namespace
 
+switchNamespace = \case ExpLevel -> TypeLevel; TypeLevel -> ExpLevel
+
 switchTick ('\'': n) = n
 switchTick n = '\'': n
  
@@ -217,7 +221,7 @@ modifyLevel f = local $ (first . second) $ \(Namespace l p) -> Namespace (f <$>
 typeNS, expNS, switchNS :: P a -> P a
 typeNS   = modifyLevel $ const TypeLevel
 expNS    = modifyLevel $ const ExpLevel
-switchNS = modifyLevel $ \case ExpLevel -> TypeLevel; TypeLevel -> ExpLevel
+switchNS = modifyLevel $ switchNamespace
 
 ifNoCNamespace p = namespace >>= \ns -> if constructorNamespace ns then mzero else p
 
@@ -236,7 +240,7 @@ upperLetter = satisfy isUpper <|> ifNoCNamespace identStart
 
 --upperCase, lowerCase, symbols, colonSymbols, backquotedIdent :: P SName
 
-upperCase_      = identifier (tick' =<< maybeStartWith (=='\'') ((:) <$> upperLetter <*> many identLetter)) <?> "uppercase ident"
+upperCase       = identifier (tick' =<< maybeStartWith (=='\'') ((:) <$> upperLetter <*> many identLetter)) <?> "uppercase ident"
 lowerCase       = identifier ((:) <$> lowerLetter <*> many identLetter) <?> "lowercase ident"
 backquotedIdent = identifier ((:) <$ char '`' <*> identStart <*> many identLetter <* char '`') <?> "backquoted ident"
 symbols         = operator (some opLetter) <?> "symbols"
@@ -250,8 +254,7 @@ patVar          = second f <$> lowerCase where
 lhsOperator     = lcSymbols <|> backquotedIdent
 rhsOperator     = symbols <|> backquotedIdent
 varId           = lowerCase <|> parens (symbols <|> backquotedIdent)
-upperCase       = upperCase_
-upperLower      = lowerCase <|> upperCase_ <|> parens (symbols <|> backquotedIdent)
+upperLower      = lowerCase <|> upperCase <|> parens symbols
 
 --qIdent          = {-qualified_ todo-} (lowerCase <|> upperCase)
 
diff --git a/src/LambdaCube/Compiler/Parser.hs b/src/LambdaCube/Compiler/Parser.hs
index d7205c5d..8430caa7 100644
--- a/src/LambdaCube/Compiler/Parser.hs
+++ b/src/LambdaCube/Compiler/Parser.hs
@@ -364,26 +364,30 @@ parseTerm_ prec = case prec of
         ope = pure . Left <$> (rhsOperator <|> psn ("'EqCTt" <$ reservedOp "~"))
         ex pr = pure . Right <$> parseTerm pr
     PrecApp ->
-        apps' <$> try "record" ((SGlobal <$> upperCase) <* reservedOp "{") <*> commaSep (lowerCase *> reservedOp "=" *> ((,) Visible <$> parseTerm PrecLam)) <* reservedOp "}"
+        apps' <$> try "record" ((SGlobal <$> upperCase) <* symbol "{") <*> commaSep (lowerCase *> reservedOp "=" *> ((,) Visible <$> parseTerm PrecLam)) <* symbol "}"
      <|> apps' <$> parseTerm PrecSwiz <*> many (hiddenTerm (parseTTerm PrecSwiz) $ parseTerm PrecSwiz)
     PrecSwiz -> level PrecProj $ \t -> mkSwizzling t <$> lexeme (try "swizzling" $ char '%' *> manyNM 1 4 (satisfy (`elem` ("xyzwrgba" :: String))))
     PrecProj -> level PrecAtom $ \t -> try "projection" $ mkProjection t <$ char '.' <*> sepBy1 (uncurry SLit . second LString <$> lowerCase) (char '.')
     PrecAtom ->
          mkLit <$> try "literal" parseLit
      <|> Wildcard (Wildcard SType) <$ reserved "_"
-     <|> char '\'' *> switchNS (parseTerm PrecAtom)
-     <|> SGlobal <$> try "identifier" upperLower
-     <|> brackets ( (parseTerm PrecLam >>= \e ->
-                mkDotDot e <$ reservedOp ".." <*> parseTerm PrecLam
-            <|> foldr ($) (SBuiltin "Cons" `SAppV` e `SAppV` SBuiltin "Nil") <$ reservedOp "|" <*> commaSep (generator <|> letdecl <|> boolExpression)
-            <|> mkList <$> namespace <*> ((e:) <$> option [] (symbol "," *> commaSep1 (parseTerm PrecLam)))
-            ) <|> mkList <$> namespace <*> pure [])
-     <|> mkTuple <$> namespace <*> parens (commaSep $ parseTerm PrecLam)
-     <|> mkRecord <$> braces (commaSep $ (,) <$> lowerCase <* symbol ":" <*> parseTerm PrecLam)
      <|> mkLets <$ reserved "let" <*> dsInfo <*> parseDefs <* reserved "in" <*> parseTerm PrecLam
+     <|> SGlobal <$> lowerCase
+     <|> SGlobal <$> upperCase  -- todo: move under ppa?
+     <|> braces (mkRecord <$> commaSep ((,) <$> lowerCase <* symbol ":" <*> parseTerm PrecLam))
+     <|> char '\'' *> ppa (fmap switchNamespace)
+     <|> ppa id
   where
     level pr f = parseTerm_ pr >>= \t -> option t $ f t
 
+    ppa tick =
+         brackets ( (parseTerm PrecLam >>= \e ->
+                mkDotDot e <$ reservedOp ".." <*> parseTerm PrecLam
+            <|> foldr ($) (SBuiltin "Cons" `SAppV` e `SAppV` SBuiltin "Nil") <$ reservedOp "|" <*> commaSep (generator <|> letdecl <|> boolExpression)
+            <|> mkList . tick <$> namespace' <*> ((e:) <$> option [] (symbol "," *> commaSep1 (parseTerm PrecLam)))
+            ) <|> mkList . tick <$> namespace' <*> pure [])
+     <|> parens (SGlobal <$> try "opname" (symbols <* lookAhead (symbol ")")) <|> mkTuple . tick <$> namespace' <*> commaSep (parseTerm PrecLam))
+
     mkSwizzling term = swizzcall
       where
         sc c = SBuiltin ['S',c]
@@ -415,14 +419,14 @@ parseTerm_ prec = case prec of
                          (SBuiltin "HNil")
 
     mkTuple _ [Section e] = e
-    mkTuple (Namespace (Just TypeLevel) _) [Parens e] = SBuiltin "'HList" `SAppV` (SBuiltin "Cons" `SAppV` e `SAppV` SBuiltin "Nil")
+    mkTuple (Just TypeLevel) [Parens e] = SBuiltin "'HList" `SAppV` (SBuiltin "Cons" `SAppV` e `SAppV` SBuiltin "Nil")
     mkTuple _ [Parens e] = SBuiltin "HCons" `SAppV` e `SAppV` SBuiltin "HNil"
     mkTuple _ [x] = Parens x
-    mkTuple (Namespace (Just TypeLevel) _) xs = SBuiltin "'HList" `SAppV` foldr (\x y -> SBuiltin "Cons" `SAppV` x `SAppV` y) (SBuiltin "Nil") xs
+    mkTuple (Just TypeLevel) xs = SBuiltin "'HList" `SAppV` foldr (\x y -> SBuiltin "Cons" `SAppV` x `SAppV` y) (SBuiltin "Nil") xs
     mkTuple _ xs = foldr (\x y -> SBuiltin "HCons" `SAppV` x `SAppV` y) (SBuiltin "HNil") xs
 
-    mkList (Namespace (Just TypeLevel) _) [x] = SBuiltin "'List" `SAppV` x
-    mkList (Namespace (Just ExpLevel)  _) xs = foldr (\x l -> SBuiltin "Cons" `SAppV` x `SAppV` l) (SBuiltin "Nil") xs
+    mkList (Just TypeLevel) [x] = SBuiltin "'List" `SAppV` x
+    mkList (Just ExpLevel) xs = foldr (\x l -> SBuiltin "Cons" `SAppV` x `SAppV` l) (SBuiltin "Nil") xs
     mkList _ xs = error "mkList"
 
     mkLit n@LInt{} = SBuiltin "fromInt" `SAppV` sLit n