compiler: rework AST to add location to patterns

This solves #36. FIXME: * Lots of locations are still not accurate, esp. in desugarer; * Pattern context might not be good enough (or not added properly);
au-ts · Dec 22, 2016 · c7f2c20 · c7f2c20
1 parent 974a95f
commit c7f2c20
Show file tree

Hide file tree

Showing 14 changed files with 600 additions and 373 deletions.
diff --git a/cogent/src/Cogent/Desugar.hs b/cogent/src/Cogent/Desugar.hs
diff --git a/cogent/src/Cogent/DocGent.hs b/cogent/src/Cogent/DocGent.hs
@@ -1,36 +1,48 @@
 {-# LANGUAGE TupleSections, ImplicitParams #-}
 {-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell #-}
+
 module Cogent.DocGent where
-import Text.Blaze.Html.Renderer.String
-import Text.Parsec
-import Text.Hamlet
-import Control.Monad.State as S
-import Cogent.PrettyPrint
-import Cogent.Surface
+
 import Cogent.Common.Syntax
 import Cogent.Common.Types
-import Text.PrettyPrint.ANSI.Leijen (SimpleDoc(..), Pretty(..))
-import qualified Text.PrettyPrint.ANSI.Leijen as P
+import Cogent.PrettyPrint
+import Cogent.Reorganizer
+import Cogent.Surface
+import Cogent.Util
+
+import Control.Lens
+import Control.Monad.State as S
+import Data.Char (isLower, toUpper)
+import Data.Default
+import qualified Data.Foldable as F
+import Data.Function (on)
+import Data.List (intersperse, sortBy, groupBy)
+import qualified Data.Map as M
+import Data.Maybe
+import Data.Ord (comparing)
+import Data.String
+import Paths_cogent
 import System.Console.ANSI
+import System.Directory
+import System.FilePath
 import Text.Blaze
+import Text.Blaze.Html.Renderer.String
 import qualified Text.Blaze.Html5 as H
 import qualified Text.Blaze.Html5.Attributes as HA
-import qualified Data.Map as M
-import Data.String
-import Control.Lens
-import Data.List (intersperse, sortBy, groupBy)
-import Data.Ord(comparing)
-import Data.Function(on)
-import System.Directory
-import qualified Data.Foldable as F
-import Data.Maybe
+import Text.Hamlet
 import qualified Text.Pandoc as T
 import qualified Text.Pandoc.Walk as T
-import Data.Default
-import Data.Char (isLower, toUpper)
-import Paths_cogent
-import System.FilePath
-data SGRState = SGRState { _intensity :: ConsoleIntensity, _fg :: (ColorIntensity, Color), _bg :: (ColorIntensity, Color), _italics :: Bool, _underline :: Underlining }
+import Text.Parsec
+import Text.PrettyPrint.ANSI.Leijen (SimpleDoc(..), Pretty(..))
+import qualified Text.PrettyPrint.ANSI.Leijen as P
+
+data SGRState = SGRState { _intensity :: ConsoleIntensity
+                         , _fg :: (ColorIntensity, Color)
+                         , _bg :: (ColorIntensity, Color)
+                         , _italics :: Bool
+                         , _underline :: Underlining
+                         }
+
 makeLenses ''SGRState
 
 markdown :: (?knowns :: [(String, SourcePos)]) => String -> Html
@@ -165,7 +177,7 @@ data Type t =
             deriving (Show, Functor, Eq, Foldable, Traversable)
 -}
 
-data DocExpr = DE { unDE :: Expr RawType VarName DocExpr }
+data DocExpr = DE { unDE :: Expr RawType RawPatn RawIrrefPatn DocExpr }
              | DocFnCall FunName [Maybe RawType] Inline deriving Show
 
 instance ExprType DocExpr where
@@ -179,8 +191,9 @@ instance Pretty DocExpr where
   pretty (DocFnCall x [] note) = pretty note P.<> funname' x
   pretty (DocFnCall x ts note) = pretty note P.<> funname' x P.<> typeargs (map pretty ts)
 
-resolveNamesA :: [String] -> Alt VarName RawExpr -> Alt VarName DocExpr
-resolveNamesA lcls (Alt pv l e) = Alt pv l $ resolveNames (lcls ++ F.toList pv) e
+resolveNamesA :: [String] -> Alt RawPatn RawExpr -> Alt RawPatn DocExpr
+resolveNamesA lcls (Alt p l e) = Alt p l $ resolveNames (lcls ++ fvP p) e
+
 resolveNames :: [String] -> RawExpr -> DocExpr
 resolveNames lcls (RE (TypeApp v ts i)) | v `notElem` lcls = DocFnCall v ts i
                                         | otherwise        = DE (TypeApp v ts i)
@@ -190,13 +203,14 @@ resolveNames lcls (RE (Match e t alts)) = DE (Match (resolveNames lcls e) t (map
 resolveNames lcls (RE (Let bs e)) = let (lcls', bs') = resolveBinders lcls bs in DE (Let bs' $ resolveNames lcls' e)
 resolveNames lcls (RE e) = DE (fmap (resolveNames lcls) e)
 
-resolveBinders :: [String] -> [Binding RawType VarName RawExpr] -> ([String], [Binding RawType VarName DocExpr])
+resolveBinders :: [String] -> [Binding RawType RawIrrefPatn RawExpr] -> ([String], [Binding RawType RawIrrefPatn DocExpr])
 resolveBinders lcls [] = (lcls, [])
 resolveBinders lcls (x:xs) = let (lcls',x') = resolveBinder lcls x
                                  (lcls'', xs') = resolveBinders lcls' xs
                               in (lcls'',x':xs')
-resolveBinder :: [String] -> Binding RawType VarName RawExpr -> ([String], Binding RawType VarName DocExpr)
-resolveBinder lcls (Binding ip t e l) = (lcls ++ F.toList ip, Binding ip t (resolveNames lcls e) l)
+
+resolveBinder :: [String] -> Binding RawType RawIrrefPatn RawExpr -> ([String], Binding RawType RawIrrefPatn DocExpr)
+resolveBinder lcls (Binding ip t e l) = (lcls ++ fvIP ip, Binding ip t (resolveNames lcls e) l)
 
 adjustSGRs :: SGR -> S.State SGRState ()
 adjustSGRs Reset = put defaultState
@@ -222,7 +236,7 @@ makeHtml content = [shamlet| <pre class="source bg-Dull-Black">#{content}|]
 
 
 
-genDoc :: (?knowns :: [(String, SourcePos)]) => (SourcePos, DocString, TopLevel LocType VarName LocExpr) -> Html
+genDoc :: (?knowns :: [(String, SourcePos)]) => (SourcePos, DocString, TopLevel LocType LocPatn LocExpr) -> Html
 genDoc (p,s,x@(Include {})) = error "Impossible!"
 genDoc (p,s,x@(IncludeStd {})) = error "Impossible!"
 genDoc (p,s,x@(TypeDec n ts t)) =
@@ -239,8 +253,9 @@ genDoc (p,s,x@(TypeDec n ts t)) =
 genDoc (p,s,x@(FunDef n pt as)) =
     let n' x = [shamlet|<table><td class='fg-Vivid-Green'><a name='#{n}'><b>#{n}</b></a></td><td class='spaced'>:</td><td class='spaced'>#{x}</td> |]
         pt' = prettyPT pt
-        md     = markdown s
-        str = runState (displayHTML (prettyPrint id $ return $ prettyFunDef False n pt $ map (resolveNamesA [] . fmap stripLocE) as )) defaultState
+        md  = markdown s
+        str = flip runState defaultState $ 
+                displayHTML (prettyPrint id $ return $ prettyFunDef False n pt $ map (resolveNamesA [] . fmap stripLocE . ffmap stripLocP) as)
         source = makeHtml $ fst str
      in
         [shamlet|
@@ -359,7 +374,7 @@ rawTemplate body = [shamlet|
 |]
 
 
-foreach ::  (?knowns :: [(String,SourcePos)]) => (SourcePos, DocString, TopLevel LocType VarName LocExpr) -> (SourcePos, Html)
+foreach ::  (?knowns :: [(String,SourcePos)]) => (SourcePos, DocString, TopLevel LocType LocPatn LocExpr) -> (SourcePos, Html)
 foreach (p, d, t) = (p,  genDoc (p,d,t))
 
 titleFor :: SourcePos -> IO String
@@ -392,7 +407,7 @@ sourcePosDiv p = do
       raw = rawFileNameFor p
    in [shamlet|<div .sourcepos><a href='#{raw}##{c}'>#{f}:#{c}</a>|]
 
-docGent :: [(SourcePos, DocString, TopLevel LocType VarName LocExpr)] -> IO ()
+docGent :: [(SourcePos, DocString, TopLevel LocType LocPatn LocExpr)] -> IO ()
 docGent input = let
                     ?knowns = mapMaybe toKnown input
                 in let

diff --git a/cogent/src/Cogent/Glue.hs b/cogent/src/Cogent/Glue.hs
@@ -138,7 +138,7 @@ data CgState = CgState { _cTypeDefs    :: [(CG.StrlType, CG.CId)]
                        , _globalOracle :: Integer
                        }
 
-data GlState = GlState { _tcDefs   :: [SR.TopLevel SR.RawType TC.TypedName TC.TypedExpr]
+data GlState = GlState { _tcDefs   :: [SR.TopLevel SR.RawType TC.TypedPatn TC.TypedExpr]
                        , _tcState  :: TcState
                        , _dsState  :: DsState
                        , _icState  :: IcState
@@ -508,7 +508,7 @@ glue s typnames mode filenames = liftA (M.toList . M.fromListWith (flip (++)) .
                                                          , L.map fst ds')]
                     Left err  -> hoistEither . Left $ err
 
-mkGlState :: [SR.TopLevel SR.RawType TC.TypedName TC.TypedExpr]
+mkGlState :: [SR.TopLevel SR.RawType TC.TypedPatn TC.TypedExpr]
           -> TC.TCState
           -> Last (DS.Typedefs, DS.Constants, [CC.CoreConst CC.UntypedExpr])
           -> M.Map FunName CC.FunctionType

diff --git a/cogent/src/Cogent/Parser.hs b/cogent/src/Cogent/Parser.hs
@@ -69,31 +69,33 @@ avoidInitial = do whiteSpace; p <- sourceColumn <$> getPosition; guard (p > 1)
 
 
 -- TODO: add support for patterns like `_ {f1, f2}', where the record name is anonymous / zilinc
-irrefutablePattern = avoidInitial >>
+irrefutablePattern :: Parser LocIrrefPatn t
+irrefutablePattern = avoidInitial >> LocIrrefPatn <$> getPosition <*>
              (variableOrRecord <$> variableName <*> optionMaybe (braces recAssignsAndOrWildcard)
          <|> tuple <$> parens (commaSep irrefutablePattern)
          <|> PUnboxedRecord <$ reservedOp "#" <*> braces recAssignsAndOrWildcard
          <|> PUnderscore <$ reservedOp "_")
        <?> "irrefutable pattern"
   where tuple [] = PUnitel
-        tuple [e] = e
-        tuple es  = PTuple es
+        tuple [LocIrrefPatn _ p] = p
+        tuple ps  = PTuple ps
         variableOrRecord v Nothing = PVar v
         variableOrRecord v (Just rs) = PTake v rs
-        recordAssignment = (\p n m -> (n, fromMaybe (PVar n) m))
+        recordAssignment = (\p n m -> (n, fromMaybe (LocIrrefPatn p $ PVar n) m))
                         <$> getPosition <*> variableName <*> optionMaybe (reservedOp "=" *> irrefutablePattern)
                         <?> "record assignment pattern"
         wildcard = reservedOp ".." >> return Nothing
         recAssign = Just <$> recordAssignment
         recAssignsAndOrWildcard = ((:[]) <$> wildcard)
-                              <|> ((:) <$> recAssign <*> ((++) <$> many (try (comma >> recAssign)) <*> (liftM maybeToList . optionMaybe) (comma >> wildcard)))
+                              <|> ((:) <$> recAssign <*> ((++) <$> many (try (comma >> recAssign))
+                                                               <*> (liftM maybeToList . optionMaybe) (comma >> wildcard)))
 
-pattern = avoidInitial >>
+pattern = avoidInitial >> LocPatn <$> getPosition <*>
             (PBoolLit <$> boolean
          <|> PCon <$> typeConName <*> many irrefutablePattern
          <|> PIntLit <$> integer
          <|> PCharLit <$> charLiteral
-         <|> try (parens pattern)
+         <|> try (patnOfLP <$> parens pattern)
          <|> PIrrefutable <$> irrefutablePattern)
        <?> "pattern"
 
@@ -104,10 +106,10 @@ boolean = True <$ reserved "True"
 
 -- A hack to handle boolean matching exhaustivity :)
 matchExpr m =  flip fmap (matchExpr' m) (\case
-  (LocExpr p (Match e bs [Alt (PBoolLit True) a e1, Alt (PBoolLit False) a' e2])) ->
-     LocExpr p (Match e bs [Alt (PBoolLit True) a e1, Alt (PIrrefutable (PUnderscore)) a' e2])
-  (LocExpr p (Match e bs [Alt (PBoolLit False) a e1, Alt (PBoolLit True) a' e2])) ->
-     LocExpr p (Match e bs [Alt (PBoolLit False) a e1, Alt (PIrrefutable (PUnderscore)) a' e2])
+  (LocExpr p (Match e bs [Alt (LocPatn p1 (PBoolLit True )) a e1, Alt (LocPatn p2 (PBoolLit False)) a' e2])) ->
+   LocExpr p (Match e bs [Alt (LocPatn p1 (PBoolLit True )) a e1, Alt (LocPatn p2 (PIrrefutable (LocIrrefPatn p2 PUnderscore))) a' e2])
+  (LocExpr p (Match e bs [Alt (LocPatn p1 (PBoolLit False)) a e1, Alt (LocPatn p2 (PBoolLit True )) a' e2])) ->
+   LocExpr p (Match e bs [Alt (LocPatn p1 (PBoolLit False)) a e1, Alt (LocPatn p2 (PIrrefutable (LocIrrefPatn p2 PUnderscore))) a' e2])
   e -> e)
 
 matchExpr' m = do
@@ -271,14 +273,14 @@ kindSignature = do n <- variableName
 docBlock = do whiteSpace; _ <- try (reservedOp "@@"); x <- manyTill anyChar (newline); whiteSpace; return x
 
 toplevel = getPosition >>= \p ->
-                 (p, "",) <$>  DocBlock <$> unlines <$> many1 docBlock
+                 (p, "",) <$> DocBlock <$> unlines <$> many1 docBlock
              <|> toplevel'
 
 toplevel' = do
   docs <- unlines . fromMaybe [] <$> optionMaybe (many1 docHunk)
   p <- getPosition
   when (sourceColumn p > 1) $ fail "toplevel entries should start at column 1"
-  (p,docs,) <$> (try(Include <$ reserved "include" <*> stringLiteral)
+  (p,docs,) <$> (try (Include <$ reserved "include" <*> stringLiteral)
         <|> IncludeStd <$ reserved "include" <*> angles (many (noneOf "\r\n>"))
         <|> typeDec <$ reserved "type" <*> typeConName <*> many (avoidInitial >> variableName) <*> optionMaybe (reservedOp "=" *> monotype)
         <|> do n <- variableName
@@ -299,7 +301,8 @@ toplevel' = do
       c <- sourceColumn <$> getPosition
       reservedOp "|"
       sepByAligned1 (alternative c) (reservedOp "|") c
-    functionSingle = Alt <$> (PIrrefutable <$> irrefutablePattern) <*> pure Regular <* reservedOp "=" <*> expr 1
+    functionSingle = Alt <$> (LocPatn <$> getPosition <*> (PIrrefutable <$> irrefutablePattern))
+                         <*> pure Regular <* reservedOp "=" <*> expr 1
 
 type Parser a t = ParsecT String t Identity a
 
@@ -326,7 +329,7 @@ program = whiteSpace *> many1 toplevel <* eof
 --   We can conclude that the search path for b is independent of where a was found
 
 parseWithIncludes :: FilePath -> [FilePath]
-                  -> IO (Either String ([(SourcePos, DocString,TopLevel LocType VarName LocExpr)], [PP.LocPragma]))
+                  -> IO (Either String ([(SourcePos, DocString, TopLevel LocType LocPatn LocExpr)], [PP.LocPragma]))
 parseWithIncludes f paths = do
   r <- newIORef S.empty
   loadTransitive' r f paths "."  -- relative to orig, we're in orig
@@ -336,7 +339,7 @@ parseWithIncludes f paths = do
 -- paths: search paths, relative to origin
 -- ro: the path of the current file, relative to original dir
 loadTransitive' :: IORef (S.Set FilePath) -> FilePath -> [FilePath] -> FilePath
-                -> IO (Either String ([(SourcePos, DocString,TopLevel LocType VarName LocExpr)], [PP.LocPragma]))
+                -> IO (Either String ([(SourcePos, DocString, TopLevel LocType LocPatn LocExpr)], [PP.LocPragma]))
 loadTransitive' r fp paths ro = do
   let fps = map (flip combine fp) (ro:paths)  -- all file paths need to search
       fpdir = takeDirectory (combine ro fp)
@@ -355,9 +358,9 @@ loadTransitive' r fp paths ro = do
                         return $ fmap (second (pragmas ++) . mconcat) . sequence $ defs'
 
   where
-    transitive :: (SourcePos, DocString, TopLevel LocType VarName LocExpr)
+    transitive :: (SourcePos, DocString, TopLevel LocType LocPatn LocExpr)
                -> FilePath
-               -> IO (Either String ([(SourcePos, DocString, TopLevel LocType VarName LocExpr)], [PP.LocPragma]))
+               -> IO (Either String ([(SourcePos, DocString, TopLevel LocType LocPatn LocExpr)], [PP.LocPragma]))
     transitive (p,d,Include x) curr = loadTransitive' r x (map (combine curr) paths) curr
     transitive (p,d,IncludeStd x) curr = do filepath <- (getStdIncFullPath x); loadTransitive' r filepath (map (combine curr) paths) curr
     transitive x _ = return (Right ([x],[]))
@@ -372,3 +375,4 @@ parseFromFile :: Parser a () -> FilePath -> IO (Either ParseError a)
 parseFromFile p fname = do
   input <- readFile fname
   return $ runP p () (if __cogent_ffull_src_path then fname else takeFileName fname) input
+