refactoring (use RWS)

2 files changed, 93 insertions, 115 deletions

diff --git a/src/LambdaCube/Compiler/Lexer.hs b/src/LambdaCube/Compiler/Lexer.hs
index 9c75c675..2cbef453 100644
--- a/src/LambdaCube/Compiler/Lexer.hs
+++ b/src/LambdaCube/Compiler/Lexer.hs
@@ -22,41 +22,17 @@ import qualified Data.Set as Set
 import qualified Data.Map as Map
 
 import Control.Monad.Except
-import Control.Monad.Reader
-import Control.Monad.Writer
+import Control.Monad.RWS
 import Control.Arrow hiding ((<+>))
 import Control.Applicative
 import Control.DeepSeq
 
-import LambdaCube.Compiler.Pretty hiding (Doc, braces, parens)
-
-import Control.Monad.State
 import Text.Megaparsec
 import Text.Megaparsec.Lexer hiding (lexeme, symbol, space, negate, symbol', indentBlock)
 import Text.Megaparsec as Pr hiding (try, label, Message)
 import Text.Megaparsec.Pos
 
-runParserT'' p f = flip evalStateT (initialPos f) . runParserT p f
-
-runPT' p st = snd <$> flip evalStateT (initialPos ".....") (runParserT' p st)
-
-type P = ParsecT String (StateT SourcePos InnerP)
-
-indentMany' p = indentMS True p
-indentMany s p = reserved s >> indentMS True p
-indentSome s p = reserved s >> indentMS False p
-
-indentMS null p = (if null then option [] else id) $ do
-    checkIndent
-    lvl <- indentLevel
-    (if null then many else some) $ do
-        pos <- getPosition
-        guard (sourceColumn pos == lvl)
-        local (second $ const (sourceLine pos, sourceColumn pos)) p
-
-lexeme' sp p = checkIndent *> p <* (getPosition >>= put) <* sp
-
-checkIndent = asks snd >>= \(r, c) -> getPosition >>= \pos -> when (sourceColumn pos <= c && sourceLine pos /= r) $ fail "wrong indentation"
+import LambdaCube.Compiler.Pretty hiding (Doc, braces, parens)
 
 -------------------------------------------------------------------------------- parser utils
 
@@ -70,7 +46,7 @@ manyNM k n p = (:) <$> p <*> manyNM (k-1) (n-1) p
 
 -------------------------------------------------------------------------------- parser type
 
-type InnerP = WriterT [PostponedCheck] (Reader ((DesugarInfo, Namespace), (Int, Int){-indentation level-}))
+type P = ParsecT String (RWS ((DesugarInfo, Namespace), (Int, Int){-indentation level-}) [PostponedCheck] SourcePos)
 
 type PostponedCheck = Maybe String
 
@@ -86,6 +62,11 @@ dsInfo = asks $ fst . fst
 namespace :: P Namespace
 namespace = asks $ snd . fst
 
+runP_ r f p = (\(a, s, w) -> (a, w)) $ runRWS p (r, (0, 0)) (initialPos f)
+
+runP r f p s = runP_ r f $ runParserT p f s
+
+runP' r f p st = runP_ r f $ runParserT' p st
 
 -------------------------------------------------------------------------------- literals
 
@@ -178,7 +159,7 @@ _ `validate` _ = mempty
 
 sourceNameSI (RangeSI (Range a _)) = sourceName a
 
-sameSource r@(RangeSI {}) q@(RangeSI {}) = sourceNameSI r == sourceNameSI q
+sameSource r@RangeSI{} q@RangeSI{} = sourceNameSI r == sourceNameSI q
 sameSource _ _ = True
 
 class SourceInfo si where
@@ -315,6 +296,77 @@ getFixity :: DesugarInfo -> SName -> Fixity
 getFixity (fm, _) n = fromMaybe (InfixL, 9) $ Map.lookup n fm
 
 
+----------------------------------------------------------- operators and identifiers
+
+reservedOp name = lexeme $ try $ string name *> notFollowedBy opLetter
+
+reserved name = lexeme $ try $ string name *> notFollowedBy identLetter
+
+expect msg p i = i >>= \n -> if (p n) then unexpected (msg ++ " " ++ show n) else return n
+
+identifier ident = lexeme $ try $ expect "reserved word" (`Set.member` theReservedNames) ident
+
+operator oper = lexeme $ try $ trCons <$> expect "reserved operator" (`Set.member` theReservedOpNames) oper
+  where
+    trCons ":" = "Cons"
+    trCons x = x
+
+theReservedOpNames = Set.fromList ["::","..","=","\\","|","<-","->","@","~","=>"]
+
+theReservedNames = Set.fromList $
+    ["let","in","case","of","if","then","else"
+    ,"data","type"
+    ,"class","default","deriving","do","import"
+    ,"infix","infixl","infixr","instance","module"
+    ,"newtype","where"
+    ,"primitive"
+    -- "as","qualified","hiding"
+    ] ++
+    ["foreign","import","export","primitive"
+    ,"_ccall_","_casm_"
+    ,"forall"
+    ]
+
+----------------------------------------------------------- indentation, white space, symbols
+
+checkIndent = asks snd >>= \(r, c) -> getPosition >>= \pos -> when (sourceColumn pos <= c && sourceLine pos /= r) $ fail "wrong indentation"
+
+indentMS null p = (if null then option [] else id) $ do
+    checkIndent
+    lvl <- indentLevel
+    (if null then many else some) $ do
+        pos <- getPosition
+        guard (sourceColumn pos == lvl)
+        local (second $ const (sourceLine pos, sourceColumn pos)) p
+
+lexeme' sp p = checkIndent *> p <* (getPosition >>= put) <* sp
+
+lexeme = lexeme' whiteSpace
+
+symbol = symbol' whiteSpace
+
+symbol' sp name
+    = lexeme' sp (string name)
+
+whiteSpace = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")
+
+simpleSpace
+    = skipSome (satisfy isSpace)
+
+oneLineComment
+    =  try (string "--" >> many (char '-') >> notFollowedBy opLetter)
+    >> skipMany (satisfy (/= '\n'))
+
+multiLineComment = try (string "{-") *> inCommentMulti
+
+inCommentMulti
+    =   try (() <$ string "-}")
+    <|> multiLineComment         *> inCommentMulti
+    <|> skipSome (noneOf "{}-")  *> inCommentMulti
+    <|> oneOf "{}-"              *> inCommentMulti
+    <?> "end of comment"
+
+
 ----------------------------------------------------------------------
 ----------------------------------------------------------------------
 -- modified version of
@@ -491,77 +543,4 @@ parseLit = lexeme $ charLiteral <|> stringLiteral <|> natFloat
             ; seq n (return n)
             }
 
------------------------------------------------------------
--- Operators & reserved ops
------------------------------------------------------------
-reservedOp name =
-    lexeme $ try $
-    do{ string name
-      ; notFollowedBy opLetter <?> ("end of " ++ show name)
-      }
-
-operator oper =
-    lexeme $ try $ trCons <$> expect "reserved operator" (`Set.member` theReservedOpNames) oper
-  where
-    trCons ":" = "Cons"
-    trCons x = x
-
-theReservedOpNames = Set.fromList ["::","..","=","\\","|","<-","->","@","~","=>"]
-
-expect msg p i = i >>= \n -> if (p n) then unexpected (msg ++ " " ++ show n) else return n
-
------------------------------------------------------------
--- Identifiers & Reserved words
------------------------------------------------------------
-reserved name =
-    lexeme $ try $
-    do{ string name
-      ; notFollowedBy identLetter <?> ("end of " ++ show name)
-      }
-
-identifier ident =
-    lexeme $ try $ expect "reserved word" (`Set.member` theReservedNames) ident
-
-theReservedNames = Set.fromList $
-    ["let","in","case","of","if","then","else"
-    ,"data","type"
-    ,"class","default","deriving","do","import"
-    ,"infix","infixl","infixr","instance","module"
-    ,"newtype","where"
-    ,"primitive"
-    -- "as","qualified","hiding"
-    ] ++
-    ["foreign","import","export","primitive"
-    ,"_ccall_","_casm_"
-    ,"forall"
-    ]
-
------------------------------------------------------------
--- White space & symbols
------------------------------------------------------------
-
-lexeme = lexeme' whiteSpace
-
-symbol = symbol' whiteSpace
-
-symbol' sp name
-    = lexeme' sp (string name)
-
-whiteSpace = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")
-
-simpleSpace
-    = skipSome (satisfy isSpace)
-
-oneLineComment
-    =  try (string "--" >> many (char '-') >> notFollowedBy opLetter)
-    >> skipMany (satisfy (/= '\n'))
-
-multiLineComment = try (string "{-") *> inCommentMulti
-
-inCommentMulti
-    =   try (() <$ string "-}")
-    <|> multiLineComment         *> inCommentMulti
-    <|> skipSome (noneOf "{}-") *> inCommentMulti
-    <|> oneOf "{}-"              *> inCommentMulti
-    <?> "end of comment"
 
diff --git a/src/LambdaCube/Compiler/Parser.hs b/src/LambdaCube/Compiler/Parser.hs
index 3b2ab687..b69fe7a4 100644
--- a/src/LambdaCube/Compiler/Parser.hs
+++ b/src/LambdaCube/Compiler/Parser.hs
@@ -354,8 +354,8 @@ parseTerm prec = withRange setSI $ case prec of
                 t' <- dbf' fe <$> parseTerm PrecLam
                 ge <- dsInfo
                 return $ foldr (uncurry (patLam id ge)) t' ts
-     <|> compileCase <$ reserved "case" <*> dsInfo <*> parseETerm PrecLam <*> do
-            indentSome "of" $ do
+     <|> compileCase <$ reserved "case" <*> dsInfo <*> parseETerm PrecLam <* reserved "of" <*> do
+            indentMS False $ do
                 (fe, p) <- longPattern
                 (,) p <$> parseRHS (dbf' fe) "->"
 --     <|> compileGuardTree id id <$> dsInfo <*> (Alts <$> parseSomeGuards (const True))
@@ -383,7 +383,7 @@ parseTerm prec = withRange setSI $ case prec of
             ) <|> mkList <$> namespace <*> pure [])
      <|> mkTuple <$> namespace <*> parens (commaSep $ parseTerm PrecLam)
      <|> mkRecord <$> braces (commaSep $ (,) <$> lowerCase <* symbol ":" <*> parseTerm PrecLam)
-     <|> mkLets True <$> dsInfo <*> parseDefs xSLabelEnd (indentMany "let") <* reserved "in" <*> parseTerm PrecLam
+     <|> mkLets True <$ reserved "let" <*> dsInfo <*> parseDefs xSLabelEnd <* reserved "in" <*> parseTerm PrecLam
   where
     level pr f = parseTerm pr >>= \t -> option t $ f t
 
@@ -758,7 +758,7 @@ parseDef =
                     ( if mk then Just nps' else Nothing
                     , foldr (uncurry SPi) (foldl SAppV (SGlobal x) $ downToS (length ts') $ length ts) ts')
             (af, cs) <- option (True, []) $
-                 do fmap ((,) True) $ indentMany "where" $ second ((,) Nothing . dbf' npsd) <$> typedIds Nothing
+                 do fmap ((,) True) $ (reserved "where" >>) $ indentMS True $ second ((,) Nothing . dbf' npsd) <$> typedIds Nothing
              <|> (,) False <$ reservedOp "=" <*>
                       sepBy1 ((,) <$> (pure <$> parseSIName upperCase)
                                   <*> do  do braces $ mkConTy True . second (zipWith (\i (v, e) -> (v, dbf_ i npsd e)) [0..])
@@ -771,21 +771,21 @@ parseDef =
  <|> do indentation (reserved "class") $ do
             x <- parseSIName $ typeNS upperCase
             (nps, ts) <- telescope (Just SType)
-            cs <- option [] $ indentMany "where" $ typedIds Nothing
+            cs <- option [] $ (reserved "where" >>) $ indentMS True $ typedIds Nothing
             return $ pure $ Class x (map snd ts) (concatMap (\(vs, t) -> (,) <$> vs <*> pure (dbf' nps t)) cs)
  <|> do indentation (reserved "instance") $ typeNS $ do
             constraints <- option [] $ try "constraint" $ getTTuple' <$> parseTerm PrecOp <* reservedOp "=>"
             x <- parseSIName upperCase
             (nps, args) <- telescopePat
-            checkPattern nps
-            cs <- expNS $ option [] $ indentSome "where" $ dbFunAlt nps <$> funAltDef varId
+            checkPattern nps            
+            cs <- expNS $ option [] $ reserved "where" *> indentMS False (dbFunAlt nps <$> funAltDef varId)
             pure . Instance x ({-todo-}map snd args) (dbff (nps <> [x]) <$> constraints) <$> compileFunAlts' id{-TODO-} cs
  <|> do indentation (try "type family" $ reserved "type" >> reserved "family") $ typeNS $ do
             x <- parseSIName upperCase
             (nps, ts) <- telescope (Just SType)
             t <- dbf' nps <$> parseType (Just SType)
             option {-open type family-}[TypeFamily x ts t] $ do
-                cs <- indentMany "where" $ funAltDef $ mfilter (== snd x) upperCase
+                cs <- (reserved "where" >>) $ indentMS True $ funAltDef $ mfilter (== snd x) upperCase
                 -- closed type family desugared here
                 compileFunAlts False id SLabelEnd [TypeAnn x $ addParamsS ts t] cs
  <|> do indentation (try "type instance" $ reserved "type" >> reserved "instance") $ typeNS $ pure <$> funAltDef upperCase
@@ -817,10 +817,10 @@ parseRHS fe tok = fmap (fmap (fe *** fe) +++ fe) $ do
   <|> do
     reservedOp tok
     rhs <- parseTerm PrecLam
-    f <- option id $ mkLets True <$> dsInfo <*> parseDefs xSLabelEnd (indentMany "where")
+    f <- option id $ mkLets True <$ reserved "where" <*> dsInfo <*> parseDefs xSLabelEnd
     return $ Right $ f rhs
 
-parseDefs lend p = p parseDef >>= compileFunAlts' lend . concat
+parseDefs lend = indentMS True parseDef >>= compileFunAlts' lend . concat
 
 funAltDef parseName = do   -- todo: use ns to determine parseName
     (n, (fee, tss)) <-
@@ -1084,16 +1084,15 @@ parseModule f str = do
       { extensions    = exts
       , moduleImports = [("Prelude", ImportAllBut []) | NoImplicitPrelude `notElem` exts] ++ idefs
       , moduleExports = join $ snd <$> header
-      , definitions   = \ge -> first (show +++ id) $ flip runReader ((ge, ns), (0,0)) . runWriterT $ runPT' (parseDefs SLabelEnd indentMany' <* eof) st
+      , definitions   = \ge -> first ((show +++ id) . snd) $ runP' (ge, ns) f (parseDefs SLabelEnd <* eof) st
       , sourceCode    = str
       }
 
 parseLC :: MonadError ErrorMsg m => FilePath -> String -> m Module
 parseLC f str
     = either (throwError . ErrorMsg . show) return
-    . flip runReader ((error "globalenv used", Namespace (Just ExpLevel) True), (0,0))
-    . fmap fst . runWriterT
-    . runParserT'' (parseModule f str) f
+    . fst
+    . runP (error "globalenv used", Namespace (Just ExpLevel) True) f (parseModule f str)
     $ str
 
 -------------------------------------------------------------------------------- pretty print