microlens and an ugly parse of ,(something,something)

btw we triggered a ghc bug here with iscallTok in parser. Apparently it kills
`call` for whichever reason. New ghc solved it.

8 files changed, 34 insertions, 22 deletions

diff --git a/app/Builtins.hs b/app/Builtins.hs
index b38eaf0..357c490 100644
--- a/app/Builtins.hs
+++ b/app/Builtins.hs
@@ -15,7 +15,7 @@ import Env (PrlgEnv(..), findAtom, findStruct, prlgError)
 import Heap (Dereferenced(..), derefHeap, heapStruct, newHeapVars)
 import qualified IR
 import Interpreter (backtrack)
-import Lens.Family2.State
+import Lens.Micro.Mtl
 import Load (processInput)
 import qualified Operators as O
 import System.Console.Haskeline (getInputChar, outputStr, outputStrLn)
@@ -50,7 +50,7 @@ printLocals = do
 
 promptRetry :: InterpFn
 promptRetry = do
-  last <- cho `uses` null
+  last <- null <$> use cho
   if last
     then continue
     else promptRetry'
@@ -407,7 +407,7 @@ addPrelude = do
             , U (Struct s) -- expand_something(Arg1, Arg2).
             , U (LocalRef 0)
             , U (LocalRef 1)
-            , Cut -- TODO  check that the cut works here; this was the whole reason why we migrated off vienna
+            , Cut
             , Done
             ]
           , [U (LocalRef 0), U (LocalRef 0), Done]
diff --git a/app/CodeLens.hs b/app/CodeLens.hs
index 9c1f1d6..75f8d7b 100644
--- a/app/CodeLens.hs
+++ b/app/CodeLens.hs
@@ -3,8 +3,8 @@
 module CodeLens where
 
 import Code
-import Lens.Family2.TH
+import Lens.Micro.TH
 
-$(makeLenses ''Cho)
+makeLenses ''Cho
 
-$(makeLenses ''Interp)
+makeLenses ''Interp
diff --git a/app/Env.hs b/app/Env.hs
index 592d608..03a7ce8 100644
--- a/app/Env.hs
+++ b/app/Env.hs
@@ -3,11 +3,11 @@ module Env where
 import Code (InterpFn, PrlgEnv)
 import CodeLens
 import qualified IR
-import Lens.Family2.State
+import Lens.Micro.Mtl
 
 withStrTable :: (IR.StrTable -> (IR.StrTable, a)) -> Env.PrlgEnv a
 withStrTable f = do
-  (st', x) <- strtable `uses` f
+  (st', x) <- f <$> use strtable
   strtable .= st'
   return x
 
diff --git a/app/Frontend.hs b/app/Frontend.hs
index 77706d8..e049365 100644
--- a/app/Frontend.hs
+++ b/app/Frontend.hs
@@ -11,7 +11,7 @@ import qualified Data.Map as M
 import Env (PrlgEnv)
 import qualified IR
 import qualified Interpreter as I
-import Lens.Family2.State
+import Lens.Micro.Mtl
 import Load
   ( compile
   , intern
@@ -67,7 +67,7 @@ interpreterLoop queryMode = do
                then queryExpansion
                else loadExpansion)
             ast
-        finished <- lift $ cmdq `uses` null
+        finished <- lift $ null <$> use cmdq
         when finished . lift . lift . outputStrLn $
           case (resOK, queryMode) of
             (True, True) -> "yes."
diff --git a/app/Heap.hs b/app/Heap.hs
index 4108089..1daa52f 100644
--- a/app/Heap.hs
+++ b/app/Heap.hs
@@ -5,7 +5,7 @@ import CodeLens
 import Data.Foldable (traverse_)
 import qualified Data.Map as M
 import IR (Id(..))
-import Lens.Family2.State
+import Lens.Micro.Mtl
 
 data Dereferenced
   = FreeRef Int
@@ -27,7 +27,7 @@ deref' h@(Heap _ hmap) x =
 derefHeap = deref' --TODO remove
 
 deref :: Int -> PrlgEnv Dereferenced
-deref = uses (cur . heap) . flip deref'
+deref x = flip deref' x <$> use (cur . heap)
 
 writeHeap :: Int -> Datum -> PrlgEnv ()
 writeHeap a v = cur . heap %= (\(Heap nxt m) -> Heap nxt $ M.insert a v m)
diff --git a/app/Interpreter.hs b/app/Interpreter.hs
index 8531a27..0107bf5 100644
--- a/app/Interpreter.hs
+++ b/app/Interpreter.hs
@@ -19,8 +19,8 @@ import qualified Data.Map as M
 import Env (PrlgEnv)
 import Heap
 import IR (Id(..), StrTable(..))
-import Lens.Family2
-import Lens.Family2.State
+import Lens.Micro
+import Lens.Micro.Mtl
 
 prove :: Code -> PrlgEnv (Either String Bool)
 prove g = do
@@ -140,7 +140,7 @@ cutGoal = doCut >> advance
 
 openGoal :: IR.Id -> InterpFn
 openGoal fn = do
-  def <- defs `uses` (M.!? fn)
+  def <- (M.!? fn) <$> use defs
   case def of
     Just hs@(_:_) -> do
       advance
@@ -293,7 +293,7 @@ unify _ _ = backtrack
 {- unification reference-handling tools -}
 findLocalRef :: Lens' Cho (M.Map Int Int) -> Int -> PrlgEnv Int
 findLocalRef store lr = do
-  a' <- (cur . store) `uses` (M.!? lr)
+  a' <- (M.!? lr) <$> use (cur . store)
   case a' of
     Nothing -> do
       a <- newHeapVar
diff --git a/app/Load.hs b/app/Load.hs
index f705114..9fb4c94 100644
--- a/app/Load.hs
+++ b/app/Load.hs
@@ -8,7 +8,7 @@ import Control.Monad.Trans.Except (ExceptT, except)
 import qualified Data.Map as M
 import Env (findAtom, findStruct, withStrTable)
 import qualified IR
-import Lens.Family2.State
+import Lens.Micro.Mtl
 import qualified Parser as P
 import qualified Text.Megaparsec as MP
 
@@ -53,7 +53,7 @@ expansion noexpand expander output x = do
   es <- findStruct expander 2
   o <- findAtom output
   comma <- findAtom ","
-  expand <- defs `uses` M.member es
+  expand <- M.member es <$> use defs
   pure $
     if expand
       then IR.CallI
diff --git a/app/Parser.hs b/app/Parser.hs
index 1dd86ba..e6b7a7a 100644
--- a/app/Parser.hs
+++ b/app/Parser.hs
@@ -49,7 +49,7 @@ singleToks = ",;|()[]{}!"
 
 identParts = "_"
 
-notOpToks = "\'%" ++ identParts
+notOpToks = "\'" ++ identParts
 
 isOperatorlike x =
   (isSymbol x || isPunctuation x) && not (x `elem` singleToks ++ notOpToks)
@@ -162,20 +162,32 @@ free = (<* ws) -- we eat blanks _after_ the token.
 
 isNormalTokStr = (`notElem` [".", "[", "]", "(", "|", ")", "{", "}"])
 
+isNormalTok :: Lexeme -> Bool
 isNormalTok (Tok x) = isNormalTokStr x
-isNormalTok (QTok x _) = isNormalTokStr x
+isNormalTok (QTok _ _) = True
 isNormalTok _ = False
 
+isCallTok :: Lexeme -> Bool
+isCallTok (Tok x) =
+  all (\c -> not (isSymbol c) && not (isPunctuation c) || c `elem` identParts) x
+isCallTok _ = True
+
 unTok (Tok t) = t
 unTok (QTok t _) = t
 
 literal :: Parser PAST
-literal = Literal . unTok <$> free (satisfy isNormalTok <* notFollowedBy lParen)
+literal =
+  Literal . unTok <$>
+  free
+    (choice
+       [ satisfy isCallTok <* notFollowedBy (choice [lParen, lBrace])
+       , satisfy (\x -> not (isCallTok x) && isNormalTok x)
+       ])
 
 makeParams (Seq inner) = splitOn [Literal ","] inner
 
 call eb contents fmod = do
-  fn <- fmod . unTok <$> satisfy isNormalTok -- not free
+  fn <- fmod . unTok <$> satisfy isCallTok -- not free
   (Call fn [] <$ try eb) <|> (Call fn . makeParams <$> free contents)
 
 parens = Seq <$> (free lParen *> some seqItem <* free rParen)