~jojo/Carth

61f5b5a79e2cac175af8ff624c86182eb7fa69fe — JoJo 1 year, 1 month ago 115ee21
Include macro expansion trace in SrcPos. Better err msgs!

    POS1: Error:
      CODE
    MESSAGE

    POS2: Note:
      CODE
    In expansion of macro.
10 files changed, 52 insertions(+), 26 deletions(-)

M TODO.org
M src/Check.hs
M src/Codegen.hs
M src/Err.hs
M src/Gen.hs
M src/Inferred.hs
M src/Lex.hs
M src/Macro.hs
M src/Parser.hs
M src/SrcPos.hs
M TODO.org => TODO.org +10 -0
@@ 733,3 733,13 @@ Features and other stuff to do/implement in/around Carth.
  }
  #+END_SRC
* INACTIVE Hygienic macros
* INACTIVE Destructors
  System to register a function as a destructor for a value, which can
  be used to destroy / close resources when the value is no longer
  used and garbage collection happens. It's not optimal that resources
  may stay open for quite a while after last usage, but it's better
  than *never* being closed.

  Example use case: We don't want to have to use linear types to
  manually destroy Lazy values when we're done with them, but we still
  need to make sure that their mutexes are destroyed at some point.

M src/Check.hs => src/Check.hs +1 -1
@@ 84,7 84,7 @@ checkCtors parent (Parsed.ConstructorDefs cs) =

builtinDataTypes :: Inferred.TypeDefs
builtinDataTypes = Map.fromList $ map
    (\(x, ps, cs) -> (x, (ps, map (first (WithPos (SrcPos "<builtin>" 0 0))) cs)))
    (\(x, ps, cs) -> (x, (ps, map (first (WithPos (SrcPos "<builtin>" 0 0 Nothing))) cs)))
    builtinDataTypes'

builtinConstructors :: Inferred.Ctors

M src/Codegen.hs => src/Codegen.hs +1 -1
@@ 195,7 195,7 @@ separateFunDefs = partitionWith $ \(lhs, WithPos dpos (ts, e)) -> case e of
genInit :: FilePath -> [VarDef] -> Gen' [Definition]
genInit moduleFp ds = do
    let name = mkName "carth_init"
    let pos = SrcPos moduleFp 1 1
    let pos = SrcPos moduleFp 1 1 Nothing
    let param = TypedVar "_" tUnit
    let genDefs =
            forM_ ds genDefineGlobVar *> commitFinalFuncBlock retVoid $> LLType.void

M src/Err.hs => src/Err.hs +6 -2
@@ 103,7 103,10 @@ printGenErr = \case
            ++ (" cannot be instantiated to type " ++ pretty t)

posd :: SrcPos -> Message -> IO ()
posd (pos@(SrcPos f lineN colN)) msg = do
posd = posd' "Error"

posd' :: String -> SrcPos -> Message -> IO ()
posd' kind (pos@(SrcPos f lineN colN inExp)) msg = do
    src <- readFile f
    let (lineN', colN') = (fromIntegral lineN, fromIntegral colN)
        lines' = lines src


@@ 118,7 121,7 @@ posd (pos@(SrcPos f lineN colN)) msg = do
        pad = length lineNS + 1
        s = either (const rest) fst (parse' (match tokentree) "" rest)
    putStrLn $ unlines
        [ prettySrcPos pos ++ ": Error:"
        [ prettySrcPos pos ++ ": " ++ kind ++ ":"
        , indent pad ++ "|"
        , lineNS ++ " | " ++ line
        -- Find the span (end-pos) of the item in the source by applying the same


@@ 126,3 129,4 @@ posd (pos@(SrcPos f lineN colN)) msg = do
        , indent pad ++ "|" ++ indent (colN') ++ replicate (length s) '^'
        , msg
        ]
    maybe (pure ()) (\pos2 -> posd' "Note" pos2 "In expansion of macro.") inExp

M src/Gen.hs => src/Gen.hs +2 -2
@@ 178,7 178,7 @@ genFunDef (name, fvs, dpos, ptv@(TypedVar px pt), genBody) = do
                    (\(TypedVar x _, i) -> emitReg x =<< extractvalue captures [i])
                    (zip fvs [0 ..])
                pure (zip fvs captureVals)
    defineSrcPos funScopeMdRef (SrcPos _ line col, mdId) = do
    defineSrcPos funScopeMdRef (SrcPos _ line col _, mdId) = do
        let loc =
                LLOp.DILocation
                    $ LLOp.Location (fromIntegral line) (fromIntegral col)


@@ 196,7 196,7 @@ genFunDef (name, fvs, dpos, ptv@(TypedVar px pt), genBody) = do
                )
            )
    funMetadataSubprog =
        let SrcPos path line _ = dpos
        let SrcPos path line _ _ = dpos
            -- TODO: Maybe only define this once and cache MDRef somewhere?
            fileNode =
                    let (dir, file) = splitFileName path

M src/Inferred.hs => src/Inferred.hs +2 -2
@@ 134,12 134,12 @@ ftv = \case

builtinExterns :: Map String (Type, SrcPos)
builtinExterns = Map.fromList $ map
    (second (, SrcPos "<builtin>" 0 0))
    (second (, SrcPos "<builtin>" 0 0 Nothing))
    [("GC_malloc", tfun (TPrim TNatSize) (TBox tByte))]

builtinVirtuals :: Map String Scheme
builtinVirtuals =
    let tv a = TVExplicit (Parsed.Id (WithPos (SrcPos "<builtin>" 0 0) a))
    let tv a = TVExplicit (Parsed.Id (WithPos (SrcPos "<builtin>" 0 0 Nothing) a))
        tva = tv "a"
        ta = TVar tva
        tvb = tv "b"

M src/Lex.hs => src/Lex.hs +3 -1
@@ 209,5 209,7 @@ space = Lexer.space Char.space1 (Lexer.skipLineComment ";") empty

getSrcPos :: Lexer SrcPos
getSrcPos = fmap
    (\(SourcePos f l c) -> SrcPos f (fromIntegral (unPos l)) (fromIntegral (unPos c)))
    (\(SourcePos f l c) ->
        SrcPos f (fromIntegral (unPos l)) (fromIntegral (unPos c)) Nothing
    )
    getSourcePos

M src/Macro.hs => src/Macro.hs +16 -10
@@ 6,6 6,7 @@ import Control.Applicative
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Data.Bifunctor
import Data.Map (Map)
import qualified Data.Map as Map



@@ 16,10 17,10 @@ import Parser
type Rules = [([TokenTree], [TokenTree])]
type Macros = Map String Rules
type Bindings = Map String TokenTree'
type Expand = ReaderT Bindings (StateT Macros (Except (SrcPos, String)))
type Expand = ReaderT (Bindings, Maybe SrcPos) (StateT Macros (Except (SrcPos, String)))

expandMacros :: [TokenTree] -> Except (SrcPos, String) [TokenTree]
expandMacros tts = evalStateT (runReaderT (toplevels tts) Map.empty) Map.empty
expandMacros tts = evalStateT (runReaderT (toplevels tts) (Map.empty, Nothing)) Map.empty

toplevels :: [TokenTree] -> Expand [TokenTree]
toplevels = fmap concat . mapM toplevel


@@ 47,19 48,24 @@ validateRules :: Rules -> Expand ()
validateRules _ = pure ()

expand :: TokenTree -> Expand [TokenTree]
expand tt@(WithPos tpos tt') = do
    bs <- ask
expand (WithPos tpos tt') = do
    (bs, expPos) <- ask
    ms <- get
    let tpos' = tpos { inExpansion = expPos }
    let tt = WithPos tpos' tt'
    let par ctor tts = fmap (pure . WithPos tpos' . ctor) (expands tts)
    case tt' of
        Lit _ -> pure [tt]
        Small x -> case Map.lookup x bs of
            Just xtt -> pure [WithPos tpos xtt]
            Just xtt -> pure [WithPos tpos' xtt]
            Nothing -> pure [tt]
        Big _ -> pure [tt]
        Keyword _ -> pure [tt]
        Parens (WithPos _ (Small x) : tts) | Just m <- Map.lookup x ms -> do
            tts' <- expands tts
            applyMacro tpos tts' m
        Parens (WithPos _ (Small x) : tts1) | Just m <- Map.lookup x ms -> do
            tts2 <- expands tts1
            local (second (const (Just tpos'))) $ do
                tts3 <- applyMacro tpos' tts2 m
                expands tts3
        Parens tts -> par Parens tts
        Brackets tts -> par Brackets tts
        Braces tts -> par Braces tts


@@ 72,7 78,6 @@ expand tt@(WithPos tpos tt') = do
            Nothing -> throwError (epos, "Unbound macro pattern variable")
        Ellipsis (WithPos epos _) ->
            throwError (epos, "Can only ellipsis splice macro pattern variable")
    where par ctor tts = fmap (pure . WithPos tpos . ctor) (expands tts)

expands :: [TokenTree] -> Expand [TokenTree]
expands = fmap concat . mapM expand


@@ 81,7 86,8 @@ applyMacro :: SrcPos -> [TokenTree] -> Rules -> Expand [TokenTree]
applyMacro appPos args = \case
    [] -> throwError (appPos, "No rule matched in application of macro")
    (params, template) : rules -> case matchRule (map unpos params, args) of
        Just bindings -> local (Map.union (Map.fromList bindings)) (expands template)
        Just bindings ->
            local (first (Map.union (Map.fromList bindings))) (expands template)
        Nothing -> applyMacro appPos args rules
  where
    matchRule = \case

M src/Parser.hs => src/Parser.hs +1 -1
@@ 36,7 36,7 @@ instance Semigroup Err where
                          (Set.union (errExpecteds e1) (errExpecteds e2))

instance Monoid Err where
    mempty = Err 0 (SrcPos "<dummy>" 0 0) Set.empty
    mempty = Err 0 (SrcPos "<dummy>" 0 0 Nothing) Set.empty

data St = St { stCount :: Word, stOuterPos :: SrcPos, stInput :: [TokenTree] }


M src/SrcPos.hs => src/SrcPos.hs +10 -6
@@ 6,11 6,15 @@ import Text.Megaparsec.Pos
import Data.Data


data SrcPos = SrcPos
    { srcName :: FilePath
    , srcLine :: Word
    , srcColumn :: Word
    } deriving (Show, Eq, Ord, Data)
-- TODO: macro invocation stack
data SrcPos =
    SrcPos { srcName :: FilePath
           , srcLine :: Word
           , srcColumn :: Word
           , inExpansion :: Maybe SrcPos
           }
    deriving (Show, Eq, Ord, Data)


data WithPos a = WithPos SrcPos a deriving (Data)



@@ 38,5 42,5 @@ unpos :: WithPos a -> a
unpos (WithPos _ a) = a

prettySrcPos :: SrcPos -> String
prettySrcPos (SrcPos f l c) =
prettySrcPos (SrcPos f l c _) =
    sourcePosPretty (SourcePos f (mkPos (fromIntegral l)) (mkPos (fromIntegral c)))