From c82d0e09a30cc4328fbd5ab46a8842fbecf68d5e Mon Sep 17 00:00:00 2001 From: Kristian Larsson Date: Wed, 20 May 2026 23:15:11 +0200 Subject: [PATCH 1/6] Store parser payloads as Text Parser and source-carrying compiler paths still stored many source-derived payloads as String. Convert those payloads to Text so the parsed AST can retain source slices instead of expanding each identifier, literal, and diagnostic payload into boxed character lists. Update consumers that print, serialize, complete, and report those values. Add the parser heap benchmark used for large generated modules. --- compiler/acton/test_incremental.hs | 4 +- compiler/lib/bench/ParserHeapBench.hs | 174 +++++++++ compiler/lib/package.yaml.in | 16 +- compiler/lib/src/Acton/BuildSpec.hs | 17 +- compiler/lib/src/Acton/CodeGen.hs | 28 +- compiler/lib/src/Acton/Compile.hs | 60 ++-- compiler/lib/src/Acton/Completion.hs | 9 +- compiler/lib/src/Acton/Diagnostics.hs | 12 +- compiler/lib/src/Acton/DocPrinter.hs | 88 ++--- compiler/lib/src/Acton/Env.hs | 3 +- compiler/lib/src/Acton/NameInfo.hs | 34 +- compiler/lib/src/Acton/Names.hs | 4 +- compiler/lib/src/Acton/Normalizer.hs | 7 +- compiler/lib/src/Acton/Parser.hs | 438 ++++++++++++----------- compiler/lib/src/Acton/Printer.hs | 21 +- compiler/lib/src/Acton/SourceProvider.hs | 14 +- compiler/lib/src/Acton/Syntax.hs | 56 +-- compiler/lib/src/Acton/TypeEnv.hs | 9 +- compiler/lib/src/Acton/Types.hs | 27 +- compiler/lib/src/InterfaceFiles.hs | 13 +- compiler/lib/test/ActonSpec.hs | 78 ++-- compiler/lsp-server/Main.hs | 8 +- 22 files changed, 680 insertions(+), 440 deletions(-) create mode 100644 compiler/lib/bench/ParserHeapBench.hs diff --git a/compiler/acton/test_incremental.hs b/compiler/acton/test_incremental.hs index fd8ff949a..aaf571092 100644 --- a/compiler/acton/test_incremental.hs +++ b/compiler/acton/test_incremental.hs @@ -1209,7 +1209,7 @@ p27_overlay_source_provider = testCase "27-overlay snapshots drive readModuleTas _ <- buildOutIn proj actAAbs <- canonicalizePath actA bytes <- B.readFile actAAbs - let text = T.unpack (TE.decodeUtf8 bytes) + let text = TE.decodeUtf8 bytes snapSame = Source.SourceSnapshot { Source.ssText = text , Source.ssBytes = bytes @@ -1233,7 +1233,7 @@ p27_overlay_source_provider = testCase "27-overlay snapshots drive readModuleTas Compile.TyTask{} -> pure () _ -> assertFailure "expected TyTask when overlay matches header" let textDiff = "\"\"\"Overlay doc\"\"\"\naaa = 2\n" - bytesDiff = TE.encodeUtf8 (T.pack textDiff) + bytesDiff = TE.encodeUtf8 textDiff snapDiff = Source.SourceSnapshot { Source.ssText = textDiff , Source.ssBytes = bytesDiff diff --git a/compiler/lib/bench/ParserHeapBench.hs b/compiler/lib/bench/ParserHeapBench.hs new file mode 100644 index 000000000..14ca644e4 --- /dev/null +++ b/compiler/lib/bench/ParserHeapBench.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings #-} + +module Main where + +import qualified Acton.Parser as Parser +import qualified Acton.Syntax as A + +import Control.DeepSeq +import Control.Exception +import Control.Monad +import qualified Data.ByteString as BS +import Data.IORef +import Data.Int +import qualified Data.Text as T +import Data.Text (Text) +import qualified Data.Text.Encoding as TE +import GHC.Stats +import System.Clock +import System.CPUTime +import System.Environment +import System.Exit +import System.Mem +import Text.Printf + +data Measurement = Measurement + { mLabel :: String + , mLiveBytes :: Integer + , mExtra :: String + } + +data Timing = Timing + { tWallNs :: Integer + , tCpuPs :: Integer + , tAllocated :: Integer + } + +main :: IO () +main = do + enabled <- getRTSStatsEnabled + unless enabled $ do + putStrLn "RTS stats are disabled; run with +RTS -T -RTS" + exitFailure + files <- getArgs + when (null files) $ do + putStrLn "usage: parser-heap-bench FILE.act [...]" + exitFailure + _ <- parseAst "" "" + performMajorGC + forM_ files measureFile + +measureFile :: FilePath -> IO () +measureFile file = do + diskBytes <- BS.length <$> BS.readFile file + putStrLn $ "file " ++ file ++ " bytes " ++ show diskBytes + (topStmts, timing) <- measureParseTiming file + printf "parse wall %.3f s cpu %.3f s allocated %.3f MiB %d top stmts\n" + (nsToSeconds (tWallNs timing)) + (psToSeconds (tCpuPs timing)) + (bytesToMiB (tAllocated timing)) + topStmts + ms <- sequence + [ measureSource file + , measureAstOnly file + , measureAstAndSource file + ] + forM_ ms $ \m -> + printf "%-18s %12d bytes %.3f MiB %s\n" + (mLabel m) + (mLiveBytes m) + (bytesToMiB (mLiveBytes m)) + (mExtra m) + putStrLn "" + +measureParseTiming :: FilePath -> IO (Int, Timing) +measureParseTiming file = do + src <- readSource file + evaluate (rnf src) + performMajorGC + timed $ do + m <- parseAst file src + return (length (A.mbody m)) + +measureSource :: FilePath -> IO Measurement +measureSource file = + measured "source" $ do + src <- readSource file + evaluate (rnf src) + return (src, show (sourceLength src) ++ " chars") + +measureAstOnly :: FilePath -> IO Measurement +measureAstOnly file = + measured "AST only" $ do + m <- parseFile file + return (m, show (length (A.mbody m)) ++ " top stmts") + +measureAstAndSource :: FilePath -> IO Measurement +measureAstAndSource file = + measured "AST + source" $ do + src <- readSource file + evaluate (rnf src) + m <- parseAst file src + return ((m, src), show (length (A.mbody m)) ++ " top stmts") + +measured :: NFData a => String -> IO (a, String) -> IO Measurement +measured label build = do + performMajorGC + base <- liveBytes + (x, extra) <- build + evaluate (rnf x) + ref <- newIORef (Just x) + performMajorGC + after <- liveBytes + keep <- readIORef ref + evaluate (case keep of + Just _ -> () + Nothing -> ()) + writeIORef ref Nothing + performMajorGC + return Measurement + { mLabel = label + , mLiveBytes = toInteger after - toInteger base + , mExtra = extra + } + +timed :: NFData a => IO a -> IO (a, Timing) +timed action = do + stats0 <- getRTSStats + cpu0 <- getCPUTime + wall0 <- getTime Monotonic + x <- action + evaluate (rnf x) + wall1 <- getTime Monotonic + cpu1 <- getCPUTime + stats1 <- getRTSStats + return (x, Timing + { tWallNs = timeSpecNs (wall1 - wall0) + , tCpuPs = toInteger (cpu1 - cpu0) + , tAllocated = toInteger (allocated_bytes stats1 - allocated_bytes stats0) + }) + +parseFile :: FilePath -> IO A.Module +parseFile file = do + src <- readSource file + evaluate (rnf src) + parseAst file src + +parseAst :: FilePath -> Text -> IO A.Module +parseAst file src = do + m <- Parser.parseModule (A.modName ["heap_probe"]) file src Nothing + evaluate (rnf m) + return m + +readSource :: FilePath -> IO Text +readSource file = TE.decodeUtf8 <$> BS.readFile file + +sourceLength :: Text -> Int +sourceLength = T.length + +liveBytes :: IO Int64 +liveBytes = do + stats <- getRTSStats + return (fromIntegral (gcdetails_live_bytes (gc stats))) + +timeSpecNs :: TimeSpec -> Integer +timeSpecNs t = toInteger (sec t) * 1000000000 + toInteger (nsec t) + +nsToSeconds :: Integer -> Double +nsToSeconds n = fromIntegral n / 1000000000 + +psToSeconds :: Integer -> Double +psToSeconds n = fromIntegral n / 1000000000000 + +bytesToMiB :: Integer -> Double +bytesToMiB n = fromIntegral n / (1024 * 1024) diff --git a/compiler/lib/package.yaml.in b/compiler/lib/package.yaml.in index bd74185ae..a5c0739a8 100644 --- a/compiler/lib/package.yaml.in +++ b/compiler/lib/package.yaml.in @@ -105,8 +105,8 @@ tests: - -with-rtsopts=-N executables: - kinds-bench: - main: KindsBench.hs + parser-heap-bench: + main: ParserHeapBench.hs source-dirs: bench other-modules: [] dependencies: @@ -114,7 +114,7 @@ executables: ghc-options: - -threaded - -rtsopts - - '"-with-rtsopts=-N -A64M"' + - -with-rtsopts=-T types-bench: main: TypesBench.hs source-dirs: bench @@ -125,3 +125,13 @@ executables: - -threaded - -rtsopts - '"-with-rtsopts=-N -A64M"' + kinds-bench: + main: KindsBench.hs + source-dirs: bench + other-modules: [] + dependencies: + - libacton + ghc-options: + - -threaded + - -rtsopts + - '"-with-rtsopts=-N -A64M"' diff --git a/compiler/lib/src/Acton/BuildSpec.hs b/compiler/lib/src/Acton/BuildSpec.hs index 5c47160a7..1d3d78d14 100644 --- a/compiler/lib/src/Acton/BuildSpec.hs +++ b/compiler/lib/src/Acton/BuildSpec.hs @@ -21,6 +21,7 @@ import Data.Map (Map) import Data.Char (isSpace) import Data.Maybe (catMaybes, fromMaybe, isNothing, mapMaybe) import qualified Data.List as L +import qualified Data.Text as T import qualified Control.Exception as E import System.IO.Unsafe (unsafePerformIO) @@ -298,7 +299,7 @@ srcLocToPair NoLoc = Nothing srcLocToPair (Loc s e) = Just (s,e) patternVarName :: S.Pattern -> Maybe String -patternVarName (S.PVar _ (S.Name _ v) _) = Just v +patternVarName (S.PVar _ v _) = Just (S.rawstr v) patternVarName (S.PParen _ p) = patternVarName p patternVarName _ = Nothing @@ -336,8 +337,8 @@ findBodyOffsetsFromAST content varName (S.Module _ _ _ stmts) = Nothing -> Nothing where firstDictLoc [] = Nothing - firstDictLoc (S.Assign _ [S.PVar _ (S.Name _ v) _] (S.Dict l _) : rest) - | v == varName = srcLocToPair l <|> firstDictLoc rest + firstDictLoc (S.Assign _ [S.PVar _ v _] (S.Dict l _) : rest) + | S.rawstr v == varName = srcLocToPair l <|> firstDictLoc rest firstDictLoc (_:rest) = firstDictLoc rest -- Given a range [s,e) covering the dict, return the inner body [s+1,e-1]. -- We assume the Acton parser locates the Dict to start at '{' and end @@ -352,7 +353,7 @@ findBodyOffsetsFromAST content varName (S.Module _ _ _ stmts) = parseModuleForSpec :: String -> Either String S.Module parseModuleForSpec content = let qn = S.ModName [] -- anonymous module - in case unsafePerformIO (E.try (AP.parseModule qn "Build.act" content Nothing) :: IO (Either E.SomeException S.Module)) of + in case unsafePerformIO (E.try (AP.parseModule qn "Build.act" (T.pack content) Nothing) :: IO (Either E.SomeException S.Module)) of Left e -> Left (show e) Right m -> Right m @@ -559,7 +560,7 @@ renderTuple pairs = -- Minimal Expr builders used for value rendering mkStr :: String -> S.Expr -mkStr s = S.Strings NoLoc [s] +mkStr s = S.Strings NoLoc [T.pack s] mkOptions :: Map String String -> S.Expr mkOptions mp = S.Dict NoLoc [ S.Assoc (mkStr k) (mkStr v) | (k,v) <- Map.toList mp ] mkList :: [String] -> S.Expr @@ -567,11 +568,11 @@ mkList xs = S.List NoLoc [ S.Elem (mkStr x) | x <- xs ] exprToSimpleString :: S.Expr -> Maybe String -exprToSimpleString (S.Strings _ [s]) = Just s +exprToSimpleString (S.Strings _ [s]) = Just (T.unpack s) exprToSimpleString _ = Nothing exprToFingerprint :: S.Expr -> Maybe String -exprToFingerprint (S.Int _ _ lexeme) = Just lexeme +exprToFingerprint (S.Int _ _ lexeme) = Just (T.unpack lexeme) exprToFingerprint (S.Paren _ e) = exprToFingerprint e exprToFingerprint _ = Nothing @@ -632,7 +633,7 @@ tupleToZig _ = Nothing kwdToMap :: S.KwdArg -> Map.Map String S.Expr kwdToMap S.KwdNil = Map.empty -kwdToMap (S.KwdArg (S.Name _ n) e rest) = Map.insert n e (kwdToMap rest) +kwdToMap (S.KwdArg n e rest) = Map.insert (S.rawstr n) e (kwdToMap rest) kwdToMap (S.KwdStar _) = Map.empty exprToOptions :: S.Expr -> Maybe (Map.Map String String) diff --git a/compiler/lib/src/Acton/CodeGen.hs b/compiler/lib/src/Acton/CodeGen.hs index 89b0c4abc..8c02d5bf4 100644 --- a/compiler/lib/src/Acton/CodeGen.hs +++ b/compiler/lib/src/Acton/CodeGen.hs @@ -16,6 +16,7 @@ module Acton.CodeGen where import qualified Data.Set import qualified Data.List +import qualified Data.Text as T import qualified Acton.Env import Utils import Pretty @@ -695,7 +696,7 @@ instance Gen PosArg where gen env PosNil = empty -formatLit (Strings l ss) = Strings l [format $ concat ss] +formatLit (Strings l ss) = Strings l [T.pack (format (concatMap T.unpack ss))] where format [] = [] format ('%':s) = '%' : flags s format (c:s) = c : format s @@ -720,7 +721,7 @@ formatLit (Strings l ss) = Strings l [format $ concat ss] conv0 s = conv s conv (t:s) = t : format s -castLit env (Strings l ss) p = format (concat ss) p +castLit env (Strings l ss) p = format (concatMap T.unpack ss) p where format [] p = empty format ('%':s) p = flags s p format (c:s) p = format s p @@ -911,16 +912,17 @@ instance Gen Expr where | NClass{} <- findQName n env = newcon' env n | otherwise = genQName env n gen env (Int _ i str) - | i < 0 = gen env primToBigInt2 <> parens (doubleQuotes $ text str) -- negative → string - | i <= 9223372036854775807 = gen env primToBigInt <> parens (text (str++"UL")) -- fits i64 → toB_bigint - | i <= 18446744073709551615 = gen env primToU64 <> parens (text (str++"UL")) -- fits u64 → toB_u64 - | otherwise = gen env primToBigInt2 <> parens (doubleQuotes $ text str) -- large → string - gen env (Float _ _ str) = gen env primToFloat <> parens (text str) + | i < 0 = gen env primToBigInt2 <> parens (doubleQuotes $ text str') -- negative → string + | i <= 9223372036854775807 = gen env primToBigInt <> parens (text (str'++"UL")) -- fits i64 → toB_bigint + | i <= 18446744073709551615 = gen env primToU64 <> parens (text (str'++"UL")) -- fits u64 → toB_u64 + | otherwise = gen env primToBigInt2 <> parens (doubleQuotes $ text str') -- large → string + where str' = T.unpack str + gen env (Float _ _ str) = gen env primToFloat <> parens (text (T.unpack str)) gen env (Bool _ True) = gen env qnTrue gen env (Bool _ False) = gen env qnFalse gen env (None _) = gen env qnNone - gen env e@Strings{} = gen env primToStr <> parens(hsep (map pretty (sval e))) - gen env e@BStrings{} = gen env primToBytes <> parens( hsep (map pretty es) <> comma <+>text(show(length(read(concat es) :: String)))) + gen env e@Strings{} = gen env primToStr <> parens(hsep (map (pretty . T.unpack) (sval e))) + gen env e@BStrings{} = gen env primToBytes <> parens( hsep (map (pretty . T.unpack) es) <> comma <+>text(show(length(read(concatMap T.unpack es) :: String)))) where es = sval e gen env (Call l (TApp _ e@(Var _ mk) _) p@(PosArg w (PosArg (Set _ es) PosNil)) KwdNil) | mk == primMkSet = text "B_mk_set" <> parens (pretty (length es) <> comma <+> gen env w <> hsep [comma <+> gen env e | e <- es]) @@ -979,13 +981,13 @@ instance Gen Expr where gen env (UnBox _ (IsInstance _ e c)) = gen env primISINSTANCE0 <> parens(gen env e <> comma <+> genQName env c) - gen env (UnBox t (Int _ n s)) = text (s++ suffix t) + gen env (UnBox t (Int _ n s)) = text (T.unpack s ++ suffix t) where suffix t | t == tInt = "LL" | t == tU64 = "UL" | otherwise = "" - gen env (UnBox _ (Float _ x s)) = text s + gen env (UnBox _ (Float _ x s)) = text (T.unpack s) gen env (UnBox _ (Bool _ b)) = if b then text "true" else text "false" gen env (UnBox _ v@(Var _ (NoQ n))) | isUnboxed n = gen env v @@ -997,7 +999,7 @@ gencFunCall env nm [] = text nm <> parens empty gencFunCall env nm (x : xs) = text nm <> parens (gen env x <> hsep [ comma <+> gen env x | x <- xs ]) genUnboxedInt env [Int _ n s, None _] _ - = text s + = text (T.unpack s) genUnboxedInt env _ c = parens (gen env c) <> text "->val" instance Gen OpArg where @@ -1015,7 +1017,7 @@ binPretty op = pretty op augPretty EuDivA = text "/=" augPretty op = pretty op -genStr env s = text $ head $ sval s +genStr env s = text $ T.unpack $ head $ sval s genBool env e = genExp env tBool e where t = typeOf env e diff --git a/compiler/lib/src/Acton/Compile.hs b/compiler/lib/src/Acton/Compile.hs index 51791bf40..67b457e8d 100644 --- a/compiler/lib/src/Acton/Compile.hs +++ b/compiler/lib/src/Acton/Compile.hs @@ -235,6 +235,8 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Map as M import Data.Ord (Down(..)) import qualified Data.Set +import qualified Data.Text as T +import Data.Text (Text) import Data.Time.Clock (UTCTime) import Data.Word (Word8, Word32, Word64) import Error.Diagnose (Diagnostic) @@ -893,20 +895,20 @@ filterActFile file = -- | Turn a list of (location, message) pairs into diagnostics. -- Used to normalize errors from different compiler subsystems. -errsToDiagnostics :: String -> FilePath -> String -> [(SrcLoc, String)] -> [Diagnostic String] +errsToDiagnostics :: String -> FilePath -> Text -> [(SrcLoc, String)] -> [Diagnostic String] errsToDiagnostics errKind filename src errs = [ Diag.actErrToDiagnostic errKind filename src loc msg | (loc, msg) <- errs ] -- | Emit diagnostics when a dependency .ty file is missing or unreadable. -- Anchors the error to the owning module's filename for consistent reporting. -missingIfaceDiagnostics :: A.ModName -> String -> A.ModName -> [Diagnostic String] +missingIfaceDiagnostics :: A.ModName -> Text -> A.ModName -> [Diagnostic String] missingIfaceDiagnostics ownerMn src missingMn = errsToDiagnostics "Compilation error" (modNameToFilename ownerMn) src [(NoLoc, "Type interface file not found or unreadable for " ++ modNameToString missingMn)] -- | Parse a module from source text, returning diagnostics on failure. -- Wraps parser, context, and indentation errors into a uniform format. -parseActSource :: C.CompileOptions -> A.ModName -> FilePath -> String -> Maybe (ParseProgress -> IO ()) -> IO (Either [Diagnostic String] A.Module) +parseActSource :: C.CompileOptions -> A.ModName -> FilePath -> Text -> Maybe (ParseProgress -> IO ()) -> IO (Either [Diagnostic String] A.Module) parseActSource opts mn actFile srcContent mOnProgress = do let parseModule | C.parse_serial opts = Acton.Parser.parseModuleSerial @@ -921,7 +923,7 @@ parseActSource opts mn actFile srcContent mOnProgress = do wrapProgress onProgress completed total = onProgress (ParseProgress completed total) - handleParseBundle :: ParseErrorBundle String CustomParseError -> IO (Either [Diagnostic String] A.Module) + handleParseBundle :: ParseErrorBundle Text CustomParseError -> IO (Either [Diagnostic String] A.Module) handleParseBundle bundle = return $ Left [Diag.parseDiagnosticFromBundle actFile srcContent bundle] @@ -945,7 +947,7 @@ parseActSource opts mn actFile srcContent mOnProgress = do parseActHeaderSnapshot :: A.ModName -> FilePath -> Source.SourceSnapshot - -> IO (Either [Diagnostic String] ([A.ModName], Maybe String)) + -> IO (Either [Diagnostic String] ([A.ModName], Maybe Text)) parseActHeaderSnapshot mn actFile snap = do cwd <- getCurrentDirectory let displayFile = makeRelative cwd actFile @@ -1018,7 +1020,7 @@ readSourceFileMeta path = do data BackInput = BackInput { biTypeEnv :: Acton.Env.Env0 , biTypedMod :: A.Module - , biSrc :: String + , biSrc :: Text , biImplHash :: B.ByteString } @@ -1031,7 +1033,7 @@ data BackJob = BackJob data FrontResult = FrontResult { frIfaceTE :: [(A.Name, I.NameInfo)] , frImps :: [A.ModName] - , frDoc :: Maybe String + , frDoc :: Maybe Text , frPubHash :: B.ByteString , frNameHashes :: [InterfaceFiles.NameHashInfo] , frFrontTime :: Maybe TimeSpec @@ -1040,8 +1042,8 @@ data FrontResult = FrontResult , frBackJob :: Maybe BackJob } -data CompileTask = ParseTask { name :: A.ModName, src :: String, srcBytes :: B.ByteString, sourceMeta :: Maybe InterfaceFiles.SourceFileMeta, parseImports :: [A.ModName] } - | ActonTask { name :: A.ModName, src :: String, srcBytes :: B.ByteString, sourceMeta :: Maybe InterfaceFiles.SourceFileMeta, atree:: A.Module } +data CompileTask = ParseTask { name :: A.ModName, src :: Text, srcBytes :: B.ByteString, sourceMeta :: Maybe InterfaceFiles.SourceFileMeta, parseImports :: [A.ModName] } + | ActonTask { name :: A.ModName, src :: Text, srcBytes :: B.ByteString, sourceMeta :: Maybe InterfaceFiles.SourceFileMeta, atree:: A.Module } | TyTask { name :: A.ModName , tyHash :: B.ByteString -- raw source bytes hash , tyPubHash :: B.ByteString -- module public hash @@ -1050,7 +1052,7 @@ data CompileTask = ParseTask { name :: A.ModName, src :: String, srcBytes , tyNameHashes :: [InterfaceFiles.NameHashInfo] , tyRoots :: [A.Name] , tyTests :: [String] - , tyDoc :: Maybe String + , tyDoc :: Maybe Text , iface :: I.NameInfo , typed :: A.Module } @@ -1264,15 +1266,15 @@ data ModuleHead , mhNameHashes :: [InterfaceFiles.NameHashInfo] , mhRoots :: [A.Name] , mhTests :: [String] - , mhDoc :: Maybe String + , mhDoc :: Maybe Text } | SrcHead { mhName :: A.ModName - , mhSrc :: String + , mhSrc :: Text , mhBytes :: B.ByteString , mhSourceMeta :: Maybe InterfaceFiles.SourceFileMeta , mhSrcImports :: [A.ModName] - , mhDoc :: Maybe String + , mhDoc :: Maybe Text } | HeadError { mhName :: A.ModName @@ -1448,7 +1450,7 @@ readModuleDoc :: Source.SourceProvider -> C.CompileOptions -> Paths -> String - -> IO (Maybe (A.ModName, Maybe String)) + -> IO (Maybe (A.ModName, Maybe Text)) readModuleDoc sp gopts opts paths actFile = do h <- readModuleHeader sp gopts opts paths actFile return $ case h of @@ -1531,7 +1533,7 @@ quiet gopts opts = C.quiet gopts || altOutput opts -- | Read an interface from a .ty file and return its NameInfo and public hash. -- This is used when a module is deemed fresh and we want to avoid reparsing. -readIfaceFromTy :: Paths -> A.ModName -> String -> Maybe B.ByteString -> IO (Either [Diagnostic String] ([A.ModName], [(A.Name, I.NameInfo)], Maybe String, B.ByteString)) +readIfaceFromTy :: Paths -> A.ModName -> Text -> Maybe B.ByteString -> IO (Either [Diagnostic String] ([A.ModName], [(A.Name, I.NameInfo)], Maybe Text, B.ByteString)) readIfaceFromTy paths mn src mHash = do mty <- Acton.Env.findTyFile (searchPath paths) mn case mty of @@ -1620,7 +1622,7 @@ runFrontPasses :: C.GlobalOptions -> Paths -> Acton.Env.Env0 -> A.Module - -> String + -> Text -> B.ByteString -> Maybe InterfaceFiles.SourceFileMeta -> (A.ModName -> IO (Maybe B.ByteString)) @@ -1652,11 +1654,13 @@ runFrontPasses gopts opts paths env0 parsed srcContent srcBytes sourceMeta resol handleTypeError :: Acton.TypeEnv.TypeError -> IO (Either [Diagnostic String] FrontResult) handleTypeError err = - return $ Left [Acton.TypeEnv.mkErrorDiagnostic filename srcContent (Acton.TypeEnv.typeReport err filename srcContent)] + let srcString = T.unpack srcContent + in return $ Left [Acton.TypeEnv.mkErrorDiagnostic filename srcString (Acton.TypeEnv.typeReport err filename srcString)] handleTypeErrors :: Acton.Types.TypeErrors -> IO (Either [Diagnostic String] FrontResult) handleTypeErrors (Acton.Types.TypeErrors errs) = - return $ Left [ Acton.TypeEnv.mkErrorDiagnostic filename srcContent (Acton.TypeEnv.typeReport err filename srcContent) + let srcString = T.unpack srcContent + in return $ Left [ Acton.TypeEnv.mkErrorDiagnostic filename srcString (Acton.TypeEnv.typeReport err filename srcString) | err <- errs ] @@ -1962,7 +1966,7 @@ runBackPasses gopts opts paths backInput shouldWrite = do let hexHash = B.unpack $ Base16.encode (biImplHash backInput) emitLines = not (C.dbg_no_lines opts) - (n,h,c) <- Acton.CodeGen.generate liftEnv relSrcBase (biSrc backInput) emitLines boxed hexHash + (n,h,c) <- Acton.CodeGen.generate liftEnv relSrcBase (T.unpack (biSrc backInput)) emitLines boxed hexHash timeCodeGen <- getTime Monotonic let finish = do timeEnd <- getTime Monotonic @@ -2303,7 +2307,7 @@ compileTasks sp gopts opts rootPaths rootProj tasks callbacks = do readTyFile = do tyRes <- (try :: IO a -> IO (Either SomeException a)) $ InterfaceFiles.readFile tyFile case tyRes of - Left _ -> return (Left (missingIfaceDiagnostics mn "" mn)) + Left _ -> return (Left (missingIfaceDiagnostics mn T.empty mn)) Right ty -> return (Right ty) mkBackJob env1 tmod srcText moduleImplHash = BackJob @@ -2339,11 +2343,11 @@ compileTasks sp gopts opts rootPaths rootProj tasks callbacks = do Nothing -> getNameHashMapCached paths m missingNameHashDiagnostics qn = - errsToDiagnostics "Compilation error" (modNameToFilename mn) "" + errsToDiagnostics "Compilation error" (modNameToFilename mn) T.empty [(NoLoc, "Hash info missing for " ++ prstr qn)] missingDepHashDiagnostics label qn users = - errsToDiagnostics "Compilation error" (modNameToFilename mn) "" + errsToDiagnostics "Compilation error" (modNameToFilename mn) T.empty [(NoLoc, label ++ " hash missing for " ++ prstr qn ++ users)] checkMissingImports imps = do @@ -2383,7 +2387,7 @@ compileTasks sp gopts opts rootPaths rootProj tasks callbacks = do then return (Right ()) else do let missingSorted = Data.List.sortOn modNameToString (Data.Set.toList missing) - diags = concatMap (\depMn -> missingIfaceDiagnostics mn "" depMn) missingSorted + diags = concatMap (\depMn -> missingIfaceDiagnostics mn T.empty depMn) missingSorted return (Left diags) collectDiags results = @@ -2442,7 +2446,7 @@ compileTasks sp gopts opts rootPaths rootProj tasks callbacks = do resolveNameHashInfo m n = do hm <- resolveNameHashMap' m case hm of - Nothing -> return (Left (missingIfaceDiagnostics mn "" m)) + Nothing -> return (Left (missingIfaceDiagnostics mn T.empty m)) Just hmap -> case M.lookup n hmap of Just info -> return (Right info) @@ -2518,7 +2522,7 @@ compileTasks sp gopts opts rootPaths rootProj tasks callbacks = do ParseErrorTask{ parseDiagnostics = diags } -> return (key, Left diags) _ | C.only_build optsT -> do ifaceRes <- case taskCurrent of - TyTask{ tyPubHash = h } -> readIfaceFromTy paths mn "" (Just h) + TyTask{ tyPubHash = h } -> readIfaceFromTy paths mn T.empty (Just h) ParseTask{ src = srcContent } -> readIfaceFromTy paths mn srcContent Nothing ActonTask{ src = srcContent } -> readIfaceFromTy paths mn srcContent Nothing case ifaceRes of @@ -2715,8 +2719,8 @@ compileTasks sp gopts opts rootPaths rootProj tasks callbacks = do when (C.verbose gopts) $ ccOnInfo callbacks (" Fresh " ++ modNameToString mn ++ ": using cached .ty") ifaceRes <- case taskCurrent of - TyTask{ tyPubHash = h } -> readIfaceFromTy paths mn "" (Just h) - _ -> readIfaceFromTy paths mn "" Nothing + TyTask{ tyPubHash = h } -> readIfaceFromTy paths mn T.empty (Just h) + _ -> readIfaceFromTy paths mn T.empty Nothing case ifaceRes of Left diags -> return (key, Left diags) Right (imps, ifaceTE, mdoc, ih) -> do @@ -3962,7 +3966,7 @@ modNameToString (A.ModName names) = intercalate "." (map nameToString names) -- | Render a name identifier to a plain string. nameToString :: A.Name -> String -nameToString (A.Name _ s) = s +nameToString = A.rawstr -- | Check whether a NameInfo represents a root-eligible actor. diff --git a/compiler/lib/src/Acton/Completion.hs b/compiler/lib/src/Acton/Completion.hs index f56440252..ebd434899 100644 --- a/compiler/lib/src/Acton/Completion.hs +++ b/compiler/lib/src/Acton/Completion.hs @@ -30,6 +30,7 @@ import Data.Char (isAlpha, isAlphaNum, isSpace) import Data.List (find, findIndex, intercalate, isPrefixOf, nubBy) import Data.Maybe (listToMaybe, mapMaybe) import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T import qualified InterfaceFiles as IF import Text.Megaparsec (eof, runParser) @@ -626,7 +627,7 @@ shallowModule searchPath env m applyImport = do Just (ms, te, mdoc) -> return $ applyImport te (Env.addMod m ms te mdoc env) -readModuleInterface :: [FilePath] -> S.ModName -> IO (Maybe ([S.ModName], I.TEnv, Maybe String)) +readModuleInterface :: [FilePath] -> S.ModName -> IO (Maybe ([S.ModName], I.TEnv, Maybe T.Text)) readModuleInterface searchPath m = do mty <- Env.findTyFile searchPath m case mty of @@ -844,7 +845,7 @@ detailOf info = docOfInfo :: I.NameInfo -> Maybe String docOfInfo info = - cleanDoc $ + cleanDoc $ fmap T.unpack $ case info of I.NDef _ _ doc -> doc I.NSig _ _ doc -> doc @@ -894,13 +895,13 @@ typeTCon env typ = parseTypeText :: Env.Env0 -> String -> Maybe S.Type parseTypeText env raw = - case runParser (St.evalStateT (P.ttype <* eof) P.initState) "" raw of + case runParser (St.evalStateT (P.ttype <* eof) P.initState) "" (T.pack raw) of Left _ -> Nothing Right typ -> Just (Env.unalias env typ) parseImports :: FilePath -> String -> IO [S.Import] parseImports fileName src = do - res <- E.try (P.parseModuleHeader fileName src) + res <- E.try (P.parseModuleHeader fileName (T.pack src)) case res of Left (_ :: E.SomeException) -> return [] Right (imps, _) -> return imps diff --git a/compiler/lib/src/Acton/Diagnostics.hs b/compiler/lib/src/Acton/Diagnostics.hs index 2b9047bd1..6e1fe1274 100644 --- a/compiler/lib/src/Acton/Diagnostics.hs +++ b/compiler/lib/src/Acton/Diagnostics.hs @@ -18,6 +18,8 @@ import qualified Data.List.NonEmpty as NE import Text.Read (readMaybe) import Data.Char (isDigit, isSpace) import qualified Data.Set as S +import qualified Data.Text as T +import Data.Text (Text) import Text.Megaparsec (PosState(..), reachOffset) import Text.Megaparsec.Error (ParseErrorBundle(..), parseErrorPretty, bundleErrors, errorBundlePretty, ShowErrorComponent(..), ParseError(..), errorOffset, parseErrorTextPretty, ErrorFancy(..)) @@ -93,7 +95,7 @@ customParseErrorToDiagnostic (OtherError msg) = (msg, -- | Convert Megaparsec parse errors to diagnose format -- Handles syntax errors from the parsing phase with rich error information -- like expected/unexpected tokens and parse positions. -parseDiagnosticFromBundle :: String -> String -> ParseErrorBundle String CustomParseError -> Diagnostic String +parseDiagnosticFromBundle :: String -> Text -> ParseErrorBundle Text CustomParseError -> Diagnostic String parseDiagnosticFromBundle filename src bundle = let -- Extract the first error (most relevant) firstError = NE.head (bundleErrors bundle) @@ -127,20 +129,20 @@ parseDiagnosticFromBundle filename src bundle = report = Err (Just "Parse error") msg [(position, This prettyMsg)] hints diagnostic = addReport mempty report - in addFile diagnostic filename src + in addFile diagnostic filename (T.unpack src) -- | Convert CustomParseException to diagnostic format directly -- CustomParseExceptions are essentially an exception container for -- CustomParseError, so extract the error and convert that -customParseExceptionToDiagnostic :: String -> String -> CustomParseException -> Diagnostic String +customParseExceptionToDiagnostic :: String -> Text -> CustomParseException -> Diagnostic String customParseExceptionToDiagnostic filename src (CustomParseException loc customErr) = customParseErrorDiagnostic "Syntax error" filename src loc customErr -- | Convert CustomParseError to Diagnostic -- This is used by tests to ensure consistent error formatting -customParseErrorDiagnostic :: String -> String -> String -> SrcLoc -> CustomParseError -> Diagnostic String +customParseErrorDiagnostic :: String -> String -> Text -> SrcLoc -> CustomParseError -> Diagnostic String customParseErrorDiagnostic errKind filename src srcLoc customErr = let (msg, hints) = customParseErrorToDiagnostic customErr (line, col, endCol) = case srcLoc of @@ -162,7 +164,7 @@ customParseErrorDiagnostic errKind filename src srcLoc customErr = position = Position (line, col) (line, endCol) filename report = Err (Just errKind) msg [(position, This msg)] hints diagnostic = addReport mempty report - in addFile diagnostic filename src + in addFile diagnostic filename (T.unpack src) -- | Convert Acton compiler errors to diagnose format -- Classic Acton errors consist of (loc, msg). Wrap in OtherError and convert to diff --git a/compiler/lib/src/Acton/DocPrinter.hs b/compiler/lib/src/Acton/DocPrinter.hs index adb97932d..dc0a871fc 100644 --- a/compiler/lib/src/Acton/DocPrinter.hs +++ b/compiler/lib/src/Acton/DocPrinter.hs @@ -11,7 +11,7 @@ -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, OverloadedStrings #-} module Acton.DocPrinter ( -- * Main documentation functions printAsciiDoc @@ -34,6 +34,8 @@ import Data.Ord (comparing) import Data.Char (isDigit) import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Text (Text) import System.FilePath ((), (<.>), joinPath) @@ -54,9 +56,9 @@ docModuleWithTypes (NModule _ tenv mdocstring) (Module qn _ _ stmts) = in header $+$ bodyDoc $+$ blank $+$ docTopLevelWithTypes tenv stmts -- | Split docstring into first line (title) and rest -splitDocstring :: String -> (String, Maybe String) +splitDocstring :: Text -> (String, Maybe String) splitDocstring s = - let ls = lines s + let ls = lines (T.unpack s) in case ls of [] -> ("", Nothing) [l] -> (l, Nothing) @@ -85,7 +87,7 @@ extractTopLevelWithTypes tenv (With _ _ body) = concatMap (extractTopLevelWithTy extractTopLevelWithTypes _ _ = [] -- | Extract docstring from NameInfo -extractNameDocstring :: NameInfo -> Maybe String +extractNameDocstring :: NameInfo -> Maybe Text extractNameDocstring (NDef _ _ mdoc) = mdoc extractNameDocstring (NSig _ _ mdoc) = mdoc extractNameDocstring (NAct _ _ _ _ mdoc) = mdoc @@ -135,7 +137,7 @@ docDeclWithTypes tenv (Def _ n q p k a b d x ddoc) = header = text "##" <+> text "`" <> pretty n <> text "`" <> genericsDoc <> paramsWithTypes <> docRetTypeFormatted retType docstrDoc = case docstr of - Just ds -> blank $+$ text ds + Just ds -> blank $+$ text (T.unpack ds) Nothing -> empty in header $+$ docstrDoc where @@ -206,7 +208,7 @@ docDeclWithTypes tenv (Actor _ n q p k b ddoc) = Nothing -> ddoc header = text "##" <+> text "*actor*" <+> text "`" <> pretty n <> text "`" <> docGenerics q <> docParamsWithTypes p k docstrDoc = case docstr of - Just ds -> blank $+$ text ds + Just ds -> blank $+$ text (T.unpack ds) Nothing -> empty in header $+$ docstrDoc @@ -220,7 +222,7 @@ docDeclWithTypes tenv (Class _ n q a b ddoc) = Nothing -> ddoc header = text "##" <+> text "*class*" <+> text "`" <> pretty n <> text "`" <> docGenerics q <> docAncestors a docstrDoc = case docstr of - Just ds -> blank $+$ text ds + Just ds -> blank $+$ text (T.unpack ds) Nothing -> empty methods = docClassBodyWithTypes tenv b in header $+$ docstrDoc $+$ @@ -236,7 +238,7 @@ docDeclWithTypes tenv (Protocol _ n q a b ddoc) = Nothing -> ddoc header = text "##" <+> text "*protocol*" <+> text "`" <> pretty n <> text "`" <> docGenerics q <> docAncestors a docstrDoc = case docstr of - Just ds -> blank $+$ text ds + Just ds -> blank $+$ text (T.unpack ds) Nothing -> empty methods = docProtocolBodyWithTypes tenv b in header $+$ docstrDoc $+$ @@ -248,7 +250,7 @@ docDeclWithTypes tenv (Extension _ q c a b ddoc) = docstr = ddoc header = text "##" <+> text "*extension*" <+> text "`" <> pretty c <> text "`" <> docGenerics q <> docAncestors a docstrDoc = case docstr of - Just ds -> blank $+$ text ds + Just ds -> blank $+$ text (T.unpack ds) Nothing -> empty in header $+$ docstrDoc @@ -382,7 +384,7 @@ docMethodWithTypes tenv (Def _ n q p k a b _ _ ddoc) = signature = text "-" <+> text "`" <> pretty n <> text "`" <> docGenerics q <> paramsWithTypes <> docRetTypeFormatted (if isJust retType then retType else a) docstr = case ddoc of - Just ds -> nest 2 (text ds) + Just ds -> nest 2 (text (T.unpack ds)) Nothing -> empty in signature $+$ (if isEmpty docstr then empty else blank $+$ docstr) @@ -548,7 +550,7 @@ collectUglyTypeVarsFromType _ = [] createTypeVarMapping :: [Name] -> [(Name, Name)] createTypeVarMapping uglyNames = zip uglyNames niceNames where - niceNames = [Name NoLoc [c] | c <- ['A'..'Z']] + niceNames = [name [c] | c <- ['A'..'Z']] -- | Replace ugly type vars with nice names in a type cleanupTypeVars :: [(Name, Name)] -> Type -> Type @@ -623,7 +625,7 @@ docDeclUnified useStyle tenv decl@(Def _ n q p k a b d x ddoc) = header = text (bold useStyle) <> pretty n <> text (reset useStyle) <> genericsDoc <> paramsWithTypes <> docRetTypeStyled useStyle useStyle retType docstrDoc = case docstr of - Just ds -> nest 2 (text ds) + Just ds -> nest 2 (text (T.unpack ds)) Nothing -> empty in header $+$ (if isEmpty docstrDoc then empty else docstrDoc) where @@ -729,7 +731,7 @@ docDeclUnified useStyle tenv (Actor _ n q p k b ddoc) = text (bold useStyle) <> pretty n <> text (reset useStyle) <> docGenerics q <> paramsWithTypes docstrDoc = case docstr of - Just ds -> nest 2 (text ds) + Just ds -> nest 2 (text (T.unpack ds)) Nothing -> empty in header $+$ (if isEmpty docstrDoc then empty else docstrDoc) where @@ -783,7 +785,7 @@ docDeclUnified useStyle tenv (Class _ n q a b ddoc) = text (bold useStyle) <> pretty n <> text (reset useStyle) <> docGenerics q <> docAncestors a docstrDoc = case docstr of - Just ds -> nest 2 (text ds) + Just ds -> nest 2 (text (T.unpack ds)) Nothing -> empty -- Document methods and attributes (attrs, methods) = extractClassMembers b @@ -804,7 +806,7 @@ docDeclUnified useStyle tenv (Class _ n q a b ddoc) = Nothing -> empty -- Document a method signature - docMethodUnified :: Bool -> TEnv -> Name -> (Name, QBinds, PosPar, KwdPar, Maybe Type, Maybe String) -> Doc + docMethodUnified :: Bool -> TEnv -> Name -> (Name, QBinds, PosPar, KwdPar, Maybe Type, Maybe Text) -> Doc docMethodUnified useStyle tenv className (methodName, q, p, k, retType, docstr) = let (paramsWithTypes, inferredRetType) = -- Try to get type info from TEnv @@ -828,7 +830,7 @@ docDeclUnified useStyle tenv (Class _ n q a b ddoc) = header = text (bold useStyle) <> pretty methodName <> text (reset useStyle) <> docGenerics q <> paramsWithTypes <> showRetType docstrDoc = case docstr of - Just ds -> text ds + Just ds -> text (T.unpack ds) Nothing -> empty in header $+$ (if isEmpty docstrDoc then empty else nest 2 docstrDoc) where @@ -890,7 +892,7 @@ docDeclUnified useStyle tenv (Protocol _ n q a b ddoc) = text (bold useStyle) <> pretty n <> text (reset useStyle) <> docGenerics q <> docAncestors a docstrDoc = case docstr of - Just ds -> nest 2 (text ds) + Just ds -> nest 2 (text (T.unpack ds)) Nothing -> empty -- Document protocol methods methods = extractProtocolMethods b @@ -900,7 +902,7 @@ docDeclUnified useStyle tenv (Protocol _ n q a b ddoc) = in header $+$ (if isEmpty docstrDoc then empty else docstrDoc) $+$ methodsDoc where -- Document a protocol method - docProtocolMethod :: (Name, QBinds, PosPar, KwdPar, Maybe Type, Maybe String) -> Doc + docProtocolMethod :: (Name, QBinds, PosPar, KwdPar, Maybe Type, Maybe Text) -> Doc docProtocolMethod (methodName, q, p, k, retType, docstr) = -- Protocol methods are just signatures let header = pretty methodName <> text ":" <+> @@ -908,7 +910,7 @@ docDeclUnified useStyle tenv (Protocol _ n q a b ddoc) = Just t -> pretty (SimplifiedType t) Nothing -> text "()" docstrDoc = case docstr of - Just ds -> nest 2 (text ds) + Just ds -> nest 2 (text (T.unpack ds)) Nothing -> empty in header $+$ (if isEmpty docstrDoc then empty else docstrDoc) @@ -919,7 +921,7 @@ docDeclUnified useStyle tenv (Extension _ q c a b ddoc) = header = text (cyan useStyle ++ "extension" ++ reset useStyle) <+> pretty c <> docAncestors a docstrDoc = case docstr of - Just ds -> nest 2 (text ds) + Just ds -> nest 2 (text (T.unpack ds)) Nothing -> empty in header $+$ (if isEmpty docstrDoc then empty else docstrDoc) @@ -1040,7 +1042,7 @@ docMethodStyled useBold useColor (Def _ n q p k a b _ _ ddoc) = let signature = nest 2 $ text "- " <> text (bold useBold) <> pretty n <> text (reset useBold) <> docGenerics q <> docParamsStyledAscii useBold useColor p k <> docRetTypeStyled useBold useColor a docstr = case ddoc of - Just ds -> nest 4 (text ds) + Just ds -> nest 4 (text (T.unpack ds)) Nothing -> empty in signature $+$ (if isEmpty docstr then empty else docstr) @@ -1066,7 +1068,7 @@ docMethodStyledWithTypes useBold useColor tenv (Def _ n q p k a b _ _ ddoc) = docGenerics q <> paramsWithTypes <> docRetTypeStyled useBold useColor (if isJust retType then retType else a) docstr = case ddoc of - Just ds -> nest 4 (text ds) + Just ds -> nest 4 (text (T.unpack ds)) Nothing -> empty in signature $+$ (if isEmpty docstr then empty else docstr) @@ -2497,7 +2499,7 @@ docDeclHtmlWithTypesAndClassesAndModule tenv currentModule classNames decl = header = text "

" <> pretty n <> text "" <> constraintsDoc <> genericsDoc <> paramsWithTypes <> actualRetType <> text "

" docstr = case ddoc of - Just ds -> text "
" <> text (nl2br $ htmlEscape ds) <> text "
" + Just ds -> text "
" <> text (nl2br $ htmlEscape (T.unpack ds)) <> text "
" Nothing -> empty in header $+$ docstr @@ -2520,7 +2522,7 @@ docDeclHtmlWithTypesAndClassesAndModule tenv currentModule classNames decl = header = text "

actor " <> pretty n <> text "" <> genericsDoc <> paramsWithTypes <> text "

" docstr = case ddoc of - Just ds -> text "
" <> text (nl2br $ htmlEscape ds) <> text "
" + Just ds -> text "
" <> text (nl2br $ htmlEscape (T.unpack ds)) <> text "
" Nothing -> empty -- Process actor body to extract public constants, internal attributes and methods body = docActorBodyHtmlWithGenericsTypesAndClassesModule tenv curMod allGenerics classNames b @@ -2539,7 +2541,7 @@ docDeclHtmlWithTypesAndClassesAndModule tenv currentModule classNames decl = header = text "

text (nstr n) <> text "\" class=\"type-context\">class " <> pretty n <> text "" <> genericsDoc <> docAncestorsHtmlWithGenericsAndClassesModule curMod generics classNames a <> text "

" docstr = case ddoc of - Just ds -> text "
" <> text (nl2br $ htmlEscape ds) <> text "
" + Just ds -> text "
" <> text (nl2br $ htmlEscape (T.unpack ds)) <> text "
" Nothing -> empty methods = docClassBodyHtmlWithGenericsTypesAndClassesModule tenv curMod generics classNames b in text "
" $+$ @@ -2557,7 +2559,7 @@ docDeclHtmlWithTypesAndClassesAndModule tenv currentModule classNames decl = header = text "

protocol " <> pretty n <> text "" <> genericsDoc <> docAncestorsHtmlWithGenericsAndClassesModule curMod generics classNames a <> text "

" docstr = case ddoc of - Just ds -> text "
" <> text (nl2br $ htmlEscape ds) <> text "
" + Just ds -> text "
" <> text (nl2br $ htmlEscape (T.unpack ds)) <> text "
" Nothing -> empty methods = docProtocolBodyHtmlWithGenericsTypesAndClassesModule tenv curMod generics classNames b in text "
" $+$ @@ -2574,7 +2576,7 @@ docDeclHtmlWithTypesAndClassesAndModule tenv currentModule classNames decl = header = text "

extension " <> pretty c <> text "" <> genericsDoc <> docAncestorsHtmlWithGenericsAndClassesModule curMod generics classNames a <> text "

" docstr = case ddoc of - Just ds -> text "
" <> text (nl2br $ htmlEscape ds) <> text "
" + Just ds -> text "
" <> text (nl2br $ htmlEscape (T.unpack ds)) <> text "
" Nothing -> empty methods = docClassBodyHtmlWithGenericsTypesAndClassesModule tenv curMod generics classNames b in text "
" $+$ @@ -2632,7 +2634,7 @@ docDeclHtmlWithTypesAndClasses tenv classNames (Def _ n q p k a b d x ddoc) = Just info -> extractNameDocstring info _ -> Nothing docstr = case mdocstring of - Just ds -> text "
" <> text (nl2br $ htmlEscape ds) <> text "
" + Just ds -> text "
" <> text (nl2br $ htmlEscape (T.unpack ds)) <> text "
" Nothing -> empty in header $+$ docstr where @@ -2654,7 +2656,7 @@ docDeclHtmlWithTypesAndClasses tenv classNames (Actor _ n q p k b ddoc) = Just info -> extractNameDocstring info _ -> Nothing docstr = case mdocstring of - Just ds -> text "
" <> text (nl2br $ htmlEscape ds) <> text "
" + Just ds -> text "
" <> text (nl2br $ htmlEscape (T.unpack ds)) <> text "
" Nothing -> empty -- Process actor body to extract attributes and methods body = docActorBodyHtmlWithGenericsTypesAndClasses tenv allGenerics classNames b @@ -2671,7 +2673,7 @@ docDeclHtmlWithTypesAndClasses tenv classNames (Class _ n q a b ddoc) = Just info -> extractNameDocstring info _ -> Nothing docstr = case mdocstring of - Just ds -> text "
" <> text (nl2br $ htmlEscape ds) <> text "
" + Just ds -> text "
" <> text (nl2br $ htmlEscape (T.unpack ds)) <> text "
" Nothing -> empty methods = docClassBodyHtmlWithGenericsTypesAndClasses tenv generics classNames b in header $+$ docstr $+$ @@ -2688,7 +2690,7 @@ docDeclHtmlWithTypesAndClasses tenv classNames (Protocol _ n q a b ddoc) = Just info -> extractNameDocstring info _ -> Nothing docstr = case mdocstring of - Just ds -> text "
" <> text (nl2br $ htmlEscape ds) <> text "
" + Just ds -> text "
" <> text (nl2br $ htmlEscape (T.unpack ds)) <> text "
" Nothing -> empty methods = docProtocolBodyHtmlWithGenericsTypesAndClasses tenv generics classNames b in header $+$ docstr $+$ @@ -2702,7 +2704,7 @@ docDeclHtmlWithTypesAndClasses tenv classNames (Extension _ q c a b ddoc) = docGenericsHtmlWithHighlight generics q <> docAncestorsHtmlWithGenericsAndClasses generics classNames a <> text "" mdocstring = Nothing -- Extensions don't have their own docstrings in TEnv docstr = case mdocstring of - Just ds -> text "
" <> text (nl2br $ htmlEscape ds) <> text "
" + Just ds -> text "
" <> text (nl2br $ htmlEscape (T.unpack ds)) <> text "
" Nothing -> empty in header $+$ docstr where @@ -2913,7 +2915,7 @@ docAncestorsHtmlWithGenericsAndClassesModule curMod generics classNames (a:_) = in text "(" <> text (renderTypeWithGenericsConstraintsAndClassesAndModule curMod generics [] classNames (TCon NoLoc tc)) <> text ")" -- | Extract class members (attributes and methods) from a class body -extractClassMembers :: Suite -> ([(Name, Maybe Type)], [(Name, QBinds, PosPar, KwdPar, Maybe Type, Maybe String)]) +extractClassMembers :: Suite -> ([(Name, Maybe Type)], [(Name, QBinds, PosPar, KwdPar, Maybe Type, Maybe Text)]) extractClassMembers stmts = foldr extractMember ([], []) stmts where extractMember (Assign _ [PVar _ n _] _) (attrs, methods) = ((n, Nothing) : attrs, methods) @@ -2931,7 +2933,7 @@ extractClassMembers stmts = foldr extractMember ([], []) stmts extractDeclMember _ acc = acc -- | Extract actor members (public constants, internal attributes, and methods) from an actor body -extractActorMembers :: Suite -> ([(Name, Maybe Type)], [(Name, Maybe Type)], [(Name, QBinds, PosPar, KwdPar, Maybe Type, Maybe String)]) +extractActorMembers :: Suite -> ([(Name, Maybe Type)], [(Name, Maybe Type)], [(Name, QBinds, PosPar, KwdPar, Maybe Type, Maybe Text)]) extractActorMembers stmts = foldr extractMember ([], [], []) stmts where extractMember (Assign _ [PVar _ n ann] _) (publics, internals, methods) = ((n, ann) : publics, internals, methods) @@ -2949,7 +2951,7 @@ extractActorMembers stmts = foldr extractMember ([], [], []) stmts extractDeclMember _ acc = acc -- | Extract protocol methods from a protocol body -extractProtocolMethods :: Suite -> [(Name, QBinds, PosPar, KwdPar, Maybe Type, Maybe String)] +extractProtocolMethods :: Suite -> [(Name, QBinds, PosPar, KwdPar, Maybe Type, Maybe Text)] extractProtocolMethods stmts = foldr extractMethod [] stmts where extractMethod (Decl _ decls) methods = foldr extractDeclMethod methods decls @@ -3029,7 +3031,7 @@ docActorBodyHtmlWithGenericsTypesAndClassesModule tenv curMod generics className text "
" in publicDocs $+$ internalDocs $+$ methodDocs -docMethodHtmlWithGenericsTypesAndClassesModule :: TEnv -> ModName -> Set Name -> Set Name -> (Name, QBinds, PosPar, KwdPar, Maybe Type, Maybe String) -> Doc +docMethodHtmlWithGenericsTypesAndClassesModule :: TEnv -> ModName -> Set Name -> Set Name -> (Name, QBinds, PosPar, KwdPar, Maybe Type, Maybe Text) -> Doc docMethodHtmlWithGenericsTypesAndClassesModule tenv curMod generics classNames (n, q, p, k, ret, docstr) = let nl2br = intercalate "
" . lines inferredParams = case lookup n tenv of @@ -3049,7 +3051,7 @@ docMethodHtmlWithGenericsTypesAndClassesModule tenv curMod generics classNames ( text "
" <> pretty n <> text "" <> genericsDoc <> params <> docRetTypeHtmlWithGenericsConstraintsAndClassesModule curMod allGenerics [] classNames retType <> text "
" methodDoc = case docstr of - Just ds -> text "
" <> text (nl2br $ htmlEscape ds) <> text "
" + Just ds -> text "
" <> text (nl2br $ htmlEscape (T.unpack ds)) <> text "
" Nothing -> empty in methodSig $+$ methodDoc $+$ text "
" @@ -3341,12 +3343,12 @@ docActorBodyHtmlWithGenericsTypesAndClasses tenv generics classNames stmts = text "
" <> pretty n <> text "" <> genericsDoc <> params <> docRetTypeHtmlWithGenericsConstraintsAndClasses allGenerics [] classNames retType <> text "
" methodDoc = case docstr of - Just ds -> text "
" <> text (nl2br $ htmlEscape ds) <> text "
" + Just ds -> text "
" <> text (nl2br $ htmlEscape (T.unpack ds)) <> text "
" Nothing -> empty in methodSig $+$ methodDoc $+$ text "
" -- | Partition actor members into public constants, internal attributes, and methods -partitionActorMembersHtmlWithGenericsTypesAndClasses :: TEnv -> Set Name -> Set Name -> Suite -> ([Doc], [Doc], [(Name, QBinds, PosPar, KwdPar, Maybe Type, Maybe String)]) +partitionActorMembersHtmlWithGenericsTypesAndClasses :: TEnv -> Set Name -> Set Name -> Suite -> ([Doc], [Doc], [(Name, QBinds, PosPar, KwdPar, Maybe Type, Maybe Text)]) partitionActorMembersHtmlWithGenericsTypesAndClasses tenv generics classNames stmts = foldl partition ([], [], []) stmts where partition (publics, internals, methods) (Assign _ [PVar _ n ann] _) = @@ -3480,7 +3482,7 @@ docMethodHtmlWithGenericsTypesAndClasses tenv generics classNames (Def _ n q p k signature = text "
" <> pretty n <> text "" <> docGenericsHtmlWithHighlight methodGenerics q <> paramsWithTypes <> actualRetType <> text "
" docstr = case ddoc of - Just ds -> text "
" <> text (nl2br $ htmlEscape ds) <> text "
" + Just ds -> text "
" <> text (nl2br $ htmlEscape (T.unpack ds)) <> text "
" Nothing -> empty in text "
  • " <> signature <> docstr <> text "
    • " where @@ -3502,7 +3504,7 @@ modNameToString :: ModName -> String modNameToString (ModName names) = intercalate "." (map nstr names) -- | Generate HTML documentation index for a list of modules -generateDocIndex :: FilePath -> [(ModName, Maybe String)] -> IO () +generateDocIndex :: FilePath -> [(ModName, Maybe Text)] -> IO () generateDocIndex docDir tasks = do let indexFile = docDir "index.html" sortedTasks = sortBy (comparing (\(mn,_) -> modNameToString mn)) tasks @@ -3531,14 +3533,14 @@ generateDocIndex docDir tasks = do ] writeFileUtf8Atomic indexFile indexHtml where - generateModuleEntry :: (ModName, Maybe String) -> [String] + generateModuleEntry :: (ModName, Maybe Text) -> [String] generateModuleEntry (mn, mDoc) = let modPaths = modPath mn -- Use different name to avoid shadowing modName = modNameToString mn htmlFile = if null modPaths then "unnamed.html" else joinPath (init modPaths) last modPaths <.> "html" - docString = maybe "" (takeWhile (/= '\n')) mDoc + docString = maybe "" (takeWhile (/= '\n') . T.unpack) mDoc in [ "
  • " , " " , " " ++ modName ++ "" diff --git a/compiler/lib/src/Acton/Env.hs b/compiler/lib/src/Acton/Env.hs index 28edbf58c..b158a8eca 100644 --- a/compiler/lib/src/Acton/Env.hs +++ b/compiler/lib/src/Acton/Env.hs @@ -26,6 +26,7 @@ import Control.Monad import Control.Monad.Except import qualified Data.HashMap.Strict as M import qualified Data.Set as S +import Data.Text (Text) import Acton.Syntax import Acton.Builtin @@ -358,7 +359,7 @@ selfQuant n q = QBind tvSelf [tc] : q setMod :: ModName -> EnvF x -> EnvF x setMod m env = env{ thismod = Just m } -addMod :: ModName -> [ModName] -> TEnv -> Maybe String -> EnvF x -> EnvF x +addMod :: ModName -> [ModName] -> TEnv -> Maybe Text -> EnvF x -> EnvF x addMod m ms newte mdoc env = env{ modules = addM ns (modules env) } where ModName ns = m diff --git a/compiler/lib/src/Acton/NameInfo.hs b/compiler/lib/src/Acton/NameInfo.hs index 6adde7958..b8b3844c8 100644 --- a/compiler/lib/src/Acton/NameInfo.hs +++ b/compiler/lib/src/Acton/NameInfo.hs @@ -19,6 +19,8 @@ import qualified Data.Binary import GHC.Generics (Generic) import Data.Typeable import qualified Data.HashMap.Strict as M +import qualified Data.Text as T +import Data.Text (Text) import Prelude hiding ((<>)) import Utils @@ -50,16 +52,16 @@ type TEnv = [(Name, NameInfo)] data NameInfo = NVar Type | NSVar Type - | NDef TSchema Deco (Maybe String) - | NSig TSchema Deco (Maybe String) - | NAct QBinds PosRow KwdRow TEnv (Maybe String) - | NClass QBinds [WTCon] TEnv (Maybe String) - | NProto QBinds [WTCon] TEnv (Maybe String) - | NExt QBinds TCon [WTCon] TEnv [Name] (Maybe String) + | NDef TSchema Deco (Maybe Text) + | NSig TSchema Deco (Maybe Text) + | NAct QBinds PosRow KwdRow TEnv (Maybe Text) + | NClass QBinds [WTCon] TEnv (Maybe Text) + | NProto QBinds [WTCon] TEnv (Maybe Text) + | NExt QBinds TCon [WTCon] TEnv [Name] (Maybe Text) | NTVar Kind CCon [PCon] | NAlias QName | NMAlias ModName - | NModule [ModName] TEnv (Maybe String) + | NModule [ModName] TEnv (Maybe Text) | NReserved deriving (Eq,Show,Read,Generic,NFData) @@ -70,16 +72,16 @@ type HTEnv = M.HashMap Name HNameInfo data HNameInfo = HNVar Type | HNSVar Type - | HNDef TSchema Deco (Maybe String) - | HNSig TSchema Deco (Maybe String) - | HNAct QBinds PosRow KwdRow TEnv (Maybe String) - | HNClass QBinds [WTCon] TEnv (Maybe String) - | HNProto QBinds [WTCon] TEnv (Maybe String) - | HNExt QBinds TCon [WTCon] TEnv [Name] (Maybe String) + | HNDef TSchema Deco (Maybe Text) + | HNSig TSchema Deco (Maybe Text) + | HNAct QBinds PosRow KwdRow TEnv (Maybe Text) + | HNClass QBinds [WTCon] TEnv (Maybe Text) + | HNProto QBinds [WTCon] TEnv (Maybe Text) + | HNExt QBinds TCon [WTCon] TEnv [Name] (Maybe Text) | HNTVar Kind CCon [PCon] | HNAlias QName | HNMAlias ModName - | HNModule [ModName] HTEnv (Maybe String) + | HNModule [ModName] HTEnv (Maybe Text) | HNReserved deriving (Eq, Show, Read, Generic) @@ -271,9 +273,9 @@ prettyOrPass te | otherwise = doc where doc = pretty te -prettyDocstring :: Maybe String -> Doc +prettyDocstring :: Maybe Text -> Doc prettyDocstring Nothing = empty -prettyDocstring (Just docstring) = text "\"\"\"" <> text docstring <> text "\"\"\"" +prettyDocstring (Just docstring) = text "\"\"\"" <> text (T.unpack docstring) <> text "\"\"\"" instance VFree NameInfo where vfree (NVar t) = vfree t diff --git a/compiler/lib/src/Acton/Names.hs b/compiler/lib/src/Acton/Names.hs index 850dd332d..22de97c93 100644 --- a/compiler/lib/src/Acton/Names.hs +++ b/compiler/lib/src/Acton/Names.hs @@ -30,7 +30,7 @@ isUnboxed (Internal BoxPass _ _) = True isUnboxed _ = False -self = Name NoLoc "self" +self = name "self" localName n = Derived n suffixLocal newactName n = Derived n suffixNewact @@ -144,7 +144,7 @@ methods b = [ n | Decl _ ds <- b, Def{dname=n} <- ds ] statevars b = concat [ bound ps | VarAssign _ ps _ <- b ] -isHidden n@(Name _ str) = length (takeWhile (=='_') str) == 1 || n == resumeKW || n == cleanupKW +isHidden n@Name{} = length (takeWhile (=='_') (rawstr n)) == 1 || n == resumeKW || n == cleanupKW isHidden _ = True notHidden = filter (not . isHidden) diff --git a/compiler/lib/src/Acton/Normalizer.hs b/compiler/lib/src/Acton/Normalizer.hs index 53d806376..e77dbc3fd 100644 --- a/compiler/lib/src/Acton/Normalizer.hs +++ b/compiler/lib/src/Acton/Normalizer.hs @@ -22,6 +22,7 @@ import Acton.QuickType import Acton.Prim import Acton.Builtin import Data.List +import qualified Data.Text as T import Pretty import Utils import Control.Monad.State.Strict @@ -175,9 +176,9 @@ normPat env p@(PList _ ps pt) = do v <- newName "lst" return (pVar v $ conv t, ss) where normList v n (p:ps) pt = s : normList v (n+1) ps pt where s = Assign NoLoc [p] (eCall (eDot (eQVar qnIndexed) getitemKW) - [eVar v, Int NoLoc n (show n)]) + [eVar v, eInt n]) normList v n [] (Just p) = [Assign NoLoc [p] (eCall (eDot (eQVar qnSliceable) getsliceKW) - [eVar v, Int NoLoc n (show n), None NoLoc, None NoLoc])] + [eVar v, eInt n, None NoLoc, None NoLoc])] normList v n [] Nothing = [] t = typeOf env p @@ -482,7 +483,7 @@ instance Norm Decl where norm env d = error ("norm unexpected: " ++ prstr d) -catStrings ss = map (quote . escape '"') ss +catStrings ss = map (T.pack . quote . escape '"' . T.unpack) ss where escape c [] = [] escape c ('\\':x:xs) = '\\' : x : escape c xs escape c (x:xs) diff --git a/compiler/lib/src/Acton/Parser.hs b/compiler/lib/src/Acton/Parser.hs index 7e064774f..ad5774ee2 100644 --- a/compiler/lib/src/Acton/Parser.hs +++ b/compiler/lib/src/Acton/Parser.hs @@ -31,6 +31,8 @@ import Data.List (isPrefixOf) import Data.Maybe (fromMaybe) import Data.Void import Data.Char +import qualified Data.Text as T +import Data.Text (Text) import qualified Data.List.NonEmpty as N import qualified Data.Set as Set import GHC.Conc (getNumCapabilities) @@ -117,12 +119,12 @@ tr msg p = do Left err -> trace ("failure "++msg ++": "++show err) (parseError err) Right ok -> trace ("success "++msg++": "++show ok) (return ok) -makeReport ps src = errReport (map setSpan ps) src +makeReport ps src = errReport (map setSpan ps) (T.unpack src) where setSpan (loc, msg) = (extractSrcSpan loc src, msg) --- Main parsing and error message functions ------------------------------------------------------ -parseModule :: S.ModName -> String -> String -> Maybe (Int -> Int -> IO ()) -> IO S.Module +parseModule :: S.ModName -> String -> Text -> Maybe (Int -> Int -> IO ()) -> IO S.Module parseModule qn fileName fileContent mReportProgress = do let contentWithNewline = addFinalNewline fileContent (is, mdoc, bodyStart) <- @@ -137,7 +139,7 @@ parseModule qn fileName fileContent mReportProgress = do reportFinalParseProgress contentWithNewline mReportProgress return $ S.Module qn is mdoc suite -parseModuleSerial :: S.ModName -> String -> String -> Maybe (Int -> Int -> IO ()) -> IO S.Module +parseModuleSerial :: S.ModName -> String -> Text -> Maybe (Int -> Int -> IO ()) -> IO S.Module parseModuleSerial qn fileName fileContent mReportProgress = do let contentWithNewline = addFinalNewline fileContent st <- parserStateWithProgress contentWithNewline mReportProgress @@ -145,28 +147,28 @@ parseModuleSerial qn fileName fileContent mReportProgress = do Left err -> Control.Exception.throw err Right (i,mdoc,s) -> return $ S.Module qn i mdoc s -parseModuleImports :: String -> String -> IO [S.Import] +parseModuleImports :: String -> Text -> IO [S.Import] parseModuleImports fileName fileContent = fst <$> parseModuleHeader fileName fileContent -parseModuleHeader :: String -> String -> IO ([S.Import], Maybe String) +parseModuleHeader :: String -> Text -> IO ([S.Import], Maybe Text) parseModuleHeader fileName fileContent = let contentWithNewline = addFinalNewline fileContent in case runParser (St.evalStateT import_input initState) fileName contentWithNewline of Left err -> Control.Exception.throw err Right res -> return res -addFinalNewline :: String -> String +addFinalNewline :: Text -> Text addFinalNewline s - | null s || last s == '\n' = s - | otherwise = s ++ "\n" + | T.null s || T.last s == '\n' = s + | otherwise = T.snoc s '\n' -- parseTest file = snd (unsafePerformIO (do cont <- readFile file; parseModule (S.modName ["test"]) file cont)) -parseTestStr p str = case runParser (St.evalStateT p initState) "" str of +parseTestStr p str = case runParser (St.evalStateT p initState) "" (T.pack str) of Left err -> putStrLn (errorBundlePretty err) Right t -> print t -extractSrcSpan :: SrcLoc -> String -> SrcSpan +extractSrcSpan :: SrcLoc -> Text -> SrcSpan extractSrcSpan NoLoc src = SpanEmpty extractSrcSpan (Loc l r) src = sp where Right sp = runParser (St.evalStateT (extractP l r) initState) "" src @@ -196,7 +198,7 @@ data ParseProgressReporter = ParseProgressReporter , pprReport :: Int -> Int -> IO () } -type Parser = St.StateT ParserState (Parsec CustomParseError String) +type Parser = St.StateT ParserState (Parsec CustomParseError Text) pushCtx ctx st = st { psContexts = ctx : psContexts st } popCtx st = st { psContexts = tail (psContexts st) } @@ -204,20 +206,20 @@ getCtxs = psContexts initState = ParserState [] Nothing -parserStateWithProgress :: String -> Maybe (Int -> Int -> IO ()) -> IO ParserState +parserStateWithProgress :: Text -> Maybe (Int -> Int -> IO ()) -> IO ParserState parserStateWithProgress contentWithNewline mReportProgress = case mReportProgress of Nothing -> return initState Just reportProgress -> do lastPercent <- newIORef 0 - return initState { psProgress = Just (ParseProgressReporter (length contentWithNewline) lastPercent reportProgress) } + return initState { psProgress = Just (ParseProgressReporter (T.length contentWithNewline) lastPercent reportProgress) } -reportFinalParseProgress :: String -> Maybe (Int -> Int -> IO ()) -> IO () +reportFinalParseProgress :: Text -> Maybe (Int -> Int -> IO ()) -> IO () reportFinalParseProgress contentWithNewline mReportProgress = case mReportProgress of Nothing -> return () Just reportProgress -> - let total = length contentWithNewline + let total = T.length contentWithNewline in reportProgress total total reportParseProgress :: Parser () @@ -356,12 +358,12 @@ sc1 = void $ do optional (char '\\' *> eol *> sc0) "" where sc0 = L.space (void $ takeWhile1P Nothing f) lineCmnt empty f x = x == ' ' || x == '\t' - lineCmnt = L.skipLineComment "#" + lineCmnt = L.skipLineComment (T.pack "#") -- Whitespace consumer, which *does* consume also newlines. -- Used inside parentheses/brackets/braces sc2 :: Parser () -sc2 = L.space space1 (L.skipLineComment "#") empty +sc2 = L.space space1 (L.skipLineComment (T.pack "#")) empty currSC = ifPar sc2 sc1 @@ -471,8 +473,11 @@ locate (Loc l _) = setOffset l lexeme:: Parser a -> Parser a lexeme p = p <* currSC -symbol :: String -> Parser String -symbol str = lexeme (string str) +stringS :: String -> Parser Text +stringS = string . T.pack + +symbol :: String -> Parser Text +symbol str = lexeme (stringS str) newline1 :: Parser [S.Stmt] newline1 = const [] <$> (eol *> sc2) @@ -531,7 +536,7 @@ strings = addLoc $ -- This will be parsed as a single string literal, not two separate ones. bytesLiteral :: Parser S.Expr -bytesLiteral = S.BStrings NoLoc . concat <$> some bytesLiteralCombo +bytesLiteral = S.BStrings NoLoc . map T.pack . concat <$> some bytesLiteralCombo -- | b"" and rb"" bytesLiteralCombo :: Parser [String] @@ -539,13 +544,13 @@ bytesLiteralCombo = plainbytesLiteral <|> rawbytesLiteral "bytes literal" -- | Raw string literals (r"...") that don't support interpolation rawStringLiteral :: Parser S.Expr -rawStringLiteral = S.Strings NoLoc . concat <$> some rawstrLiteral "string literal" +rawStringLiteral = S.Strings NoLoc . map T.pack . concat <$> some rawstrLiteral "string literal" -- Docstring parser - parses strings with normal escape handling but no interpolation docstringLiteral :: Parser S.Expr docstringLiteral = (do parts <- some docstringPlainLiteral - return $ S.Strings NoLoc [concat (concat parts)] + return $ S.Strings NoLoc [T.pack (concat (concat parts))] ) "docstring" where docstringPlainLiteral = @@ -594,9 +599,9 @@ concatStringLiterals singleStringParser = do combinedExprs = concat exprLists if null combinedExprs - then return $ S.Strings NoLoc [combinedFormat] + then return $ S.Strings NoLoc [T.pack combinedFormat] else return $ S.BinOp NoLoc - (S.Strings NoLoc [combinedFormat]) + (S.Strings NoLoc [T.pack combinedFormat]) S.Mod (if length combinedExprs == 1 then head combinedExprs @@ -604,11 +609,11 @@ concatStringLiterals singleStringParser = do where -- Extract format string and expressions from each part extractParts :: S.Expr -> (String, [S.Expr]) - extractParts (S.Strings _ ss) = (concat ss, []) + extractParts (S.Strings _ ss) = (concatMap T.unpack ss, []) extractParts (S.BinOp _ (S.Strings _ [fmt]) S.Mod expr) = case expr of - S.Tuple _ args _ -> (fmt, tupleToList args) - e -> (fmt, [e]) + S.Tuple _ args _ -> (T.unpack fmt, tupleToList args) + e -> (T.unpack fmt, [e]) extractParts _ = ("", []) -- Should not happen -- Convert tuple arguments to list @@ -635,19 +640,19 @@ buildFormatString (ExprPart _ fmt : rest) = "%" ++ fmt ++ buildFormatString rest parseInterpolatedString :: String -> String -> (Int -> Parser StringPart) -> Parser S.Expr parseInterpolatedString startQuote endQuote textPartParser = lexeme $ do startLoc <- getOffset - try $ string startQuote + try $ stringS startQuote let startQuoteCharOffset = startLoc + (length startQuote - length endQuote) let stringPart = choice [ -- Escaped braces - handle these BEFORE expression parsing - try (string "{{" >> return (TextPart "{")), - try (string "}}" >> return (TextPart "}")), + try (stringS "{{" >> return (TextPart "{")), + try (stringS "}}" >> return (TextPart "}")), -- Expression parts (now without the notFollowedBy check) try exprPart, -- Regular text textPartParser startQuoteCharOffset ] parts <- many stringPart - string endQuote <|> do + stringS endQuote <|> do -- If we couldn't parse the closing quote, check why currentPos <- getOffset nextChar <- lookAhead (optional anySingle) @@ -667,12 +672,12 @@ parseInterpolatedString startQuote endQuote textPartParser = lexeme $ do -- No expressions found, create a regular string let textContent = concat [s | TextPart s <- parts] -- Apply hex splitting to handle cases like "\x48ello" -> ["\x48", "ello"] - return $ S.Strings NoLoc (hexSplitString textContent) + return $ S.Strings NoLoc (map T.pack (hexSplitString textContent)) else do -- Found expressions, create interpolated string format let formatStr = buildFormatString parts result = S.BinOp NoLoc - (S.Strings NoLoc [formatStr]) + (S.Strings NoLoc [T.pack formatStr]) S.Mod (if length exprs == 1 then head exprs @@ -686,7 +691,7 @@ parseTextPart quoteStr isTriple handleNewlines startOfString = do -- Use existing escape sequence parsers with better error handling try (char '\\' >> choice [ -- Escaped quotes - handle quote-specific escaping - try (string quoteStr >> return quoteStr), + try (stringS quoteStr >> return quoteStr), -- Use existing escape parsers for consistency and better error messages try hexEscape, @@ -702,7 +707,7 @@ parseTextPart quoteStr isTriple handleNewlines startOfString = do -- Handle newlines in triple-quoted strings if handleNewlines - then try (string "\n" >> return "\\n") + then try (stringS "\n" >> return "\\n") else empty, -- Handle quotes in triple-quoted strings @@ -787,12 +792,12 @@ exprPart = do then do -- Handle center alignment by using str.center() method let widthExpr = case widthInfo of - Just w -> S.Int NoLoc (read w) w - Nothing -> S.Int NoLoc 0 "0" + Just w -> S.Int NoLoc (read w) (T.pack w) + Nothing -> S.Int NoLoc 0 (T.pack "0") -- First convert the expression to a string - strExpr = S.Call NoLoc (S.Var NoLoc (S.NoQ (S.Name NoLoc "str"))) (S.PosArg parsedExpr S.PosNil) S.KwdNil + strExpr = S.Call NoLoc (S.Var NoLoc (S.NoQ (S.name "str"))) (S.PosArg parsedExpr S.PosNil) S.KwdNil -- Then call the center method on the string - centerMethod = S.Dot NoLoc strExpr (S.Name NoLoc "center") + centerMethod = S.Dot NoLoc strExpr (S.name "center") -- Call center(width) centeredExpr = S.Call NoLoc centerMethod (S.PosArg widthExpr S.PosNil) S.KwdNil return centeredExpr @@ -803,7 +808,7 @@ exprPart = do -- This allows printf to apply the format directly to the value return parsedExpr -- For normal formatting, convert to str - else return $ S.Call NoLoc (S.Var NoLoc (S.NoQ (S.Name NoLoc "str"))) (S.PosArg parsedExpr S.PosNil) S.KwdNil + else return $ S.Call NoLoc (S.Var NoLoc (S.NoQ (S.name "str"))) (S.PosArg parsedExpr S.PosNil) S.KwdNil return $ ExprPart finalExpr fmt @@ -975,7 +980,8 @@ hexSplitString s -- Invalid hex escape, keep as-is process (h1:h2:rest) ('x':'\\':acc) chunks process (c:cs) acc chunks = process cs (c:acc) chunks - isHex c = c `elem` "0123456789abcdefABCDEF" + isHex :: Char -> Bool + isHex c = c `elem` ("0123456789abcdefABCDEF" :: String) newlineEscape = "" <$ newline @@ -1050,7 +1056,7 @@ rawstrLiteral = rawLiteral ((:[]) <$> anySingle) "r" stringTempl :: String -> Parser String -> Parser String -> String -> Parser [String] stringTempl q single esc prefix = do startLoc <- getOffset - _ <- string (prefix++q) + _ <- stringS (prefix++q) -- For single-quoted strings, guard against newline before closing quote let startQuoteOffset = startLoc + length prefix guardedSingle = if length q == 1 @@ -1063,7 +1069,7 @@ stringTempl q single esc prefix = do parseException (Loc startQuoteOffset pos) (MissingClosingQuote q) _ -> single else single - content <- manyTillEsc guardedSingle esc (string q closingQuoteError startLoc q) + content <- manyTillEsc guardedSingle esc (stringS q closingQuoteError startLoc q) currSC -- Apply lexeme whitespace consumption return $ hexSplitString . concat $ content where @@ -1071,7 +1077,7 @@ stringTempl q single esc prefix = do | quote `elem` ["\"\"\"", "'''"] = "closing triple quote " ++ quote ++ " for string starting at position " ++ show startLoc | otherwise = "closing quote " ++ quote ++ " for string" -manyTillEsc, someTillEsc :: Parser String -> Parser String -> Parser String -> Parser [String] +manyTillEsc, someTillEsc :: Parser String -> Parser String -> Parser a -> Parser [String] manyTillEsc p esc end = (const [] <$> end) <|> (someTillEsc p esc end) someTillEsc p esc end = do @@ -1084,7 +1090,7 @@ someTillEsc p esc end = do -- Reserved words, other symbols and names ---------------------------------------------------------- rword :: String -> Parser () -rword w = (lexeme . try) (string w *> notFollowedBy (alphaNumChar <|> char '_')) +rword w = (lexeme . try) (stringS w *> notFollowedBy (alphaNumChar <|> char '_')) comma = symbol "," "comma" colon = symbol ":" @@ -1101,35 +1107,40 @@ vbar = symbol "|" -- Parser for operator that is a prefix of another operator -- Slightly hackish; depends on the (presently true) fact that chars in argument to oneOf are -- the only chars that can follow directly after the prefix operator in a longer operator name. -opPref :: String -> Parser String -opPref op = (lexeme . try) (string op <* notFollowedBy (oneOf "<>=/*")) +opPref :: String -> Parser Text +opPref op = (lexeme . try) (stringS op <* notFollowedBy (oneOf "<>=/*")) singleStar = (lexeme . try) (char '*' <* notFollowedBy (char '*')) -identifier :: Parser String +identifier :: Parser Text identifier = (lexeme . try) $ do off <- getOffset - c <- satisfy (\c -> isAlpha c || c=='_') "identifier" - cs <- hidden (takeWhileP Nothing (\c -> isAlphaNum c || c=='_')) - let x = c:cs - if S.isKeyword x - then parseError (TrivialError off (Just (Tokens (N.fromList x))) (Set.fromList [Label (N.fromList "identifier")])) + void $ lookAhead (satisfy (\c -> isAlpha c || c == '_') "identifier") + x <- takeWhile1P (Just "identifier") (\c -> isAlphaNum c || c=='_') + if S.isKeywordText x + then parseError (TrivialError off (Just (Tokens (N.fromList (T.unpack x)))) (Set.fromList [Label (N.fromList "identifier")])) else return x name, escname, tvarname :: Parser S.Name name = do off <- getOffset x <- identifier - if isUpper (head x) && all isDigit (tail x) - then parseError (FancyError off (Set.fromList [ErrorCustom (TypeVariableNameError x)])) - else return $ S.Name (Loc off (off+length x)) x + if isTypeVarName x + then parseError (FancyError off (Set.fromList [ErrorCustom (TypeVariableNameError (T.unpack x))])) + else return $ S.Name (Loc off (off + T.length x)) x -escname = name <|> addLoc (S.Name NoLoc . head <$> plainstrLiteral) -- Assumes an escname cannot contain hex escape sequences +escname = name <|> addLoc (S.name . head <$> plainstrLiteral) -- Assumes an escname cannot contain hex escape sequences tvarname = do off <- getOffset x <- identifier - if isUpper (head x) && all isDigit (tail x) - then return $ S.Name (Loc off (off+length x)) x - else parseError (TrivialError off (Just (Tokens (N.fromList x))) (Set.fromList [Label (N.fromList ("type variable (upper case letter optionally followed by digits)"))])) + if isTypeVarName x + then return $ S.Name (Loc off (off + T.length x)) x + else parseError (TrivialError off (Just (Tokens (N.fromList (T.unpack x)))) (Set.fromList [Label (N.fromList ("type variable (upper case letter optionally followed by digits)"))])) + +isTypeVarName :: Text -> Bool +isTypeVarName x = + case T.uncons x of + Just (c,cs) -> isUpper c && T.all isDigit cs + Nothing -> False module_name :: Parser S.ModName module_name = do @@ -1151,20 +1162,20 @@ qual_name = do --- Helper functions for parenthesised forms ----------------------------------- parens, brackets, braces :: Parser a -> Parser a -parens p = withCtx PAR (L.symbol sc2 "(" *> p <* (char ')' "closing ')'")) <* currSC +parens p = withCtx PAR (L.symbol sc2 (T.pack "(") *> p <* (char ')' "closing ')'")) <* currSC -brackets p = withCtx PAR (L.symbol sc2 "[" *> p <* (char ']' "closing ']'")) <* currSC +brackets p = withCtx PAR (L.symbol sc2 (T.pack "[") *> p <* (char ']' "closing ']'")) <* currSC -braces p = withCtx PAR (L.symbol sc2 "{" *> p <* (char '}' "closing '}'")) <* currSC +braces p = withCtx PAR (L.symbol sc2 (T.pack "{") *> p <* (char '}' "closing '}'")) <* currSC --- Top-level parsers ------------------------------------------------------------ -module_docstring :: Parser String +module_docstring :: Parser Text module_docstring = do S.Strings _ ss <- addLoc docstringLiteral - return (unescapeString (concat ss)) + return (T.pack (unescapeString (concatMap T.unpack ss))) -file_input :: Parser ([S.Import], Maybe String, S.Suite) +file_input :: Parser ([S.Import], Maybe Text, S.Suite) file_input = sc2 *> do -- Allow optional module docstring before imports mbDocstring <- optional (try (L.nonIndented sc2 module_docstring <* eol <* sc2)) @@ -1176,12 +1187,12 @@ file_input = sc2 *> do -- (((,) <$> imports <*> withCtx TOP top_suite) <* eof) -import_input :: Parser ([S.Import], Maybe String) +import_input :: Parser ([S.Import], Maybe Text) import_input = do (is, mbDocstring, _) <- module_header_with_offset return (is, mbDocstring) -module_header_with_offset :: Parser ([S.Import], Maybe String, Int) +module_header_with_offset :: Parser ([S.Import], Maybe Text, Int) module_header_with_offset = sc2 *> do mbDocstring <- optional (try (L.nonIndented sc2 module_docstring <* eol <* sc2)) is <- imports @@ -1220,7 +1231,7 @@ data SourceSpan = SourceSpan !Int !Int deriving (Eq, Show) data TopLevelChunk = TopLevelChunk { chunkSpan :: !SourceSpan - , chunkInput :: String + , chunkInput :: Text , chunkLine :: !Int } deriving (Eq, Show) @@ -1233,7 +1244,7 @@ data ScanMode = ScanString data ChunkScanState = ChunkScanState { scanActiveStart :: Maybe Int - , scanActiveInput :: Maybe String + , scanActiveInput :: Maybe Text , scanActiveLine :: Maybe Int , scanDepth :: Int , scanModes :: [ScanMode] @@ -1245,10 +1256,10 @@ data ChunkScanState = ChunkScanState , scanPrev2 :: Maybe Char } deriving (Eq, Show) -scanTopLevelChunks :: String -> Int -> (TopLevelChunk -> IO ()) -> IO (Either ChunkScanError ()) +scanTopLevelChunks :: Text -> Int -> (TopLevelChunk -> IO ()) -> IO (Either ChunkScanError ()) scanTopLevelChunks src start emit - | start < 0 || start > length src = return (Left (ChunkScanError NoLoc "invalid module body offset")) - | otherwise = go start (drop start src) initScan + | start < 0 || start > T.length src = return (Left (ChunkScanError NoLoc "invalid module body offset")) + | otherwise = go start (T.drop start src) initScan where initScan = ChunkScanState { scanActiveStart = Nothing @@ -1261,27 +1272,29 @@ scanTopLevelChunks src start emit , scanContinued = False , scanBackslash = False , scanPrev1 = charBefore start - , scanPrev2 = if start >= 2 then Just (src !! (start - 2)) else Nothing + , scanPrev2 = if start >= 2 then Just (T.index src (start - 2)) else Nothing } charBefore 0 = Nothing - charBefore n = Just (src !! (n - 1)) - - startLine = 1 + length (filter (== '\n') (take start src)) - - go i [] st = do - emitOpenChunk i st - return (Right ()) - go i xs@(c:_) st - | startsBoundary c st = - openChunk i xs st >>= scanCode i xs - | scanActiveStart st == Nothing - && null (scanModes st) - && scanDepth st == 0 - && not (isTriviaStart c) = - return (Left (ChunkScanError (Loc i (i + 1)) "non-top-level text before first chunk")) - | otherwise = - scanStep i xs st + charBefore n = Just (T.index src (n - 1)) + + startLine = 1 + T.count (T.singleton '\n') (T.take start src) + + go i xs st = + case T.uncons xs of + Nothing -> do + emitOpenChunk i st + return (Right ()) + Just (c, _) + | startsBoundary c st -> + openChunk i xs st >>= scanCode i xs + | scanActiveStart st == Nothing + && null (scanModes st) + && scanDepth st == 0 + && not (isTriviaStart c) -> + return (Left (ChunkScanError (Loc i (i + 1)) "non-top-level text before first chunk")) + | otherwise -> + scanStep i xs st startsBoundary c st = scanAtLineStart st && @@ -1305,7 +1318,7 @@ scanTopLevelChunks src start emit Just s | s < i -> emit (TopLevelChunk (SourceSpan s i) - (fromMaybe [] (scanActiveInput st)) + (fromMaybe T.empty (scanActiveInput st)) (fromMaybe (scanLine st) (scanActiveLine st))) _ -> return () @@ -1314,97 +1327,106 @@ scanTopLevelChunks src start emit [] -> scanCode i xs st _ -> scanString i xs st - scanCode i xs@(c:_) st - | c == '#' = - skipComment i xs st { scanBackslash = False } - | Just (mode, qlen) <- stringStartMode xs st = - let (_, rest, st') = consumeMany False qlen i xs st - in go (i + qlen) rest st' { scanModes = mode : scanModes st', scanBackslash = False } - | c `elem` "([{" = - let (_, rest, st') = consumeMany True 1 i xs st { scanDepth = scanDepth st + 1 } - in go (i + 1) rest st' - | c `elem` ")]}" = - let depth' = max 0 (scanDepth st - 1) - (_, rest, st') = consumeMany True 1 i xs st { scanDepth = depth' } - in go (i + 1) rest st' - | otherwise = - let (_, rest, st') = consumeMany True 1 i xs st - in go (i + 1) rest st' - - scanString i [] st = go i [] st - scanString i xs@(c:_) st = + scanCode i xs st = + case T.uncons xs of + Nothing -> go i T.empty st + Just (c, _) + | c == '#' -> + skipComment i xs st { scanBackslash = False } + | Just (mode, qlen) <- stringStartMode xs st -> + let (_, rest, st') = consumeMany False qlen i xs st + in go (i + qlen) rest st' { scanModes = mode : scanModes st', scanBackslash = False } + | c `elem` "([{" -> + let (_, rest, st') = consumeMany True 1 i xs st { scanDepth = scanDepth st + 1 } + in go (i + 1) rest st' + | c `elem` ")]}" -> + let depth' = max 0 (scanDepth st - 1) + (_, rest, st') = consumeMany True 1 i xs st { scanDepth = depth' } + in go (i + 1) rest st' + | otherwise -> + let (_, rest, st') = consumeMany True 1 i xs st + in go (i + 1) rest st' + + scanString i xs st = case scanModes st of [] -> scanCode i xs st mode:rest | scanInterpDepth mode == 0 -> scanStringText i xs mode rest st | otherwise -> scanInterpolation i xs mode rest st - scanStringText i xs@(c:_) mode rest st - | c == '\\' = - let n = case xs of - _:_:_ -> 2 - _ -> 1 - (_, xs', st') = consumeMany False n i xs st - in go (i + n) xs' st' - | scanInterpolate mode && startsWith "{{" xs = - let (_, xs', st') = consumeMany False 2 i xs st - in go (i + 2) xs' st' - | scanInterpolate mode && startsWith "}}" xs = - let (_, xs', st') = consumeMany False 2 i xs st - in go (i + 2) xs' st' - | scanInterpolate mode && c == '{' = - let mode' = mode { scanInterpDepth = 1 } - (_, xs', st') = consumeMany False 1 i xs st { scanModes = mode' : rest } - in go (i + 1) xs' st' - | Just n <- tripleInterpolatedQuoteText xs mode = - let (_, xs', st') = consumeMany False n i xs st - in go (i + n) xs' st' - | closesString xs mode = - let n = if scanTriple mode then 3 else 1 - (_, xs', st') = consumeMany False n i xs st { scanModes = rest } - in go (i + n) xs' st' - | otherwise = - let (_, xs', st') = consumeMany False 1 i xs st - in go (i + 1) xs' st' - - scanInterpolation i xs@(c:_) mode rest st - | c == '#' = - skipComment i xs st - | Just (nested, qlen) <- stringStartMode xs st = - let (_, xs', st') = consumeMany False qlen i xs st - in go (i + qlen) xs' st' { scanModes = nested : scanModes st' } - | c == '{' = - let mode' = mode { scanInterpDepth = scanInterpDepth mode + 1 } - (_, xs', st') = consumeMany False 1 i xs st { scanModes = mode' : rest } - in go (i + 1) xs' st' - | c == '}' = - let depth' = scanInterpDepth mode - 1 - modes' = if depth' == 0 then mode { scanInterpDepth = 0 } : rest - else mode { scanInterpDepth = depth' } : rest - (_, xs', st') = consumeMany False 1 i xs st { scanModes = modes' } - in go (i + 1) xs' st' - | otherwise = - let (_, xs', st') = consumeMany False 1 i xs st - in go (i + 1) xs' st' - - stringStartMode xs@(q:_) st - | q == '"' || q == '\'' = - let triple = startsWith [q, q, q] xs - raw = scanPrev1 st == Just 'r' || - (scanPrev2 st == Just 'r' && scanPrev1 st == Just 'b') - bytes = scanPrev1 st == Just 'b' || - (scanPrev2 st == Just 'r' && scanPrev1 st == Just 'b') - interpolate = not raw && not bytes - qlen = if triple then 3 else 1 - in Just (ScanString q triple interpolate 0, qlen) - | otherwise = Nothing - stringStartMode [] _ = Nothing + scanStringText i xs mode rest st = + case T.uncons xs of + Nothing -> go i T.empty st + Just (c, _) + | c == '\\' -> + let n = case xs of + _ | T.length xs >= 2 -> 2 + _ -> 1 + (_, xs', st') = consumeMany False n i xs st + in go (i + n) xs' st' + | scanInterpolate mode && startsWith "{{" xs -> + let (_, xs', st') = consumeMany False 2 i xs st + in go (i + 2) xs' st' + | scanInterpolate mode && startsWith "}}" xs -> + let (_, xs', st') = consumeMany False 2 i xs st + in go (i + 2) xs' st' + | scanInterpolate mode && c == '{' -> + let mode' = mode { scanInterpDepth = 1 } + (_, xs', st') = consumeMany False 1 i xs st { scanModes = mode' : rest } + in go (i + 1) xs' st' + | Just n <- tripleInterpolatedQuoteText xs mode -> + let (_, xs', st') = consumeMany False n i xs st + in go (i + n) xs' st' + | closesString xs mode -> + let n = if scanTriple mode then 3 else 1 + (_, xs', st') = consumeMany False n i xs st { scanModes = rest } + in go (i + n) xs' st' + | otherwise -> + let (_, xs', st') = consumeMany False 1 i xs st + in go (i + 1) xs' st' + + scanInterpolation i xs mode rest st = + case T.uncons xs of + Nothing -> go i T.empty st + Just (c, _) + | c == '#' -> + skipComment i xs st + | Just (nested, qlen) <- stringStartMode xs st -> + let (_, xs', st') = consumeMany False qlen i xs st + in go (i + qlen) xs' st' { scanModes = nested : scanModes st' } + | c == '{' -> + let mode' = mode { scanInterpDepth = scanInterpDepth mode + 1 } + (_, xs', st') = consumeMany False 1 i xs st { scanModes = mode' : rest } + in go (i + 1) xs' st' + | c == '}' -> + let depth' = scanInterpDepth mode - 1 + modes' = if depth' == 0 then mode { scanInterpDepth = 0 } : rest + else mode { scanInterpDepth = depth' } : rest + (_, xs', st') = consumeMany False 1 i xs st { scanModes = modes' } + in go (i + 1) xs' st' + | otherwise -> + let (_, xs', st') = consumeMany False 1 i xs st + in go (i + 1) xs' st' + + stringStartMode xs st = + case T.uncons xs of + Just (q, _) + | q == '"' || q == '\'' -> + let triple = startsWith [q, q, q] xs + raw = scanPrev1 st == Just 'r' || + (scanPrev2 st == Just 'r' && scanPrev1 st == Just 'b') + bytes = scanPrev1 st == Just 'b' || + (scanPrev2 st == Just 'r' && scanPrev1 st == Just 'b') + interpolate = not raw && not bytes + qlen = if triple then 3 else 1 + in Just (ScanString q triple interpolate 0, qlen) + _ -> Nothing closesString xs mode | scanTriple mode = startsWith (replicate 3 (scanQuote mode)) xs - | otherwise = case xs of - c:_ -> c == scanQuote mode - [] -> False + | otherwise = case T.uncons xs of + Just (c, _) -> c == scanQuote mode + Nothing -> False tripleInterpolatedQuoteText xs mode | scanTriple mode && scanInterpolate mode = @@ -1414,24 +1436,28 @@ scanTopLevelChunks src start emit _ -> Nothing | otherwise = Nothing - quoteRunLength q = length . takeWhile (== q) + quoteRunLength q = T.length . T.takeWhile (== q) - startsWith prefix xs = prefix `isPrefixOf` xs + startsWith prefix xs = T.pack prefix `T.isPrefixOf` xs - skipComment i [] st = go i [] st - skipComment i xs@(c:_) st - | c == '\n' = - let (_, xs', st') = consumeMany False 1 i xs st - in go (i + 1) xs' st' - | otherwise = - let (_, xs', st') = consumeMany False 1 i xs st - in skipComment (i + 1) xs' st' + skipComment i xs st = + case T.uncons xs of + Nothing -> go i T.empty st + Just (c, _) + | c == '\n' -> + let (_, xs', st') = consumeMany False 1 i xs st + in go (i + 1) xs' st' + | otherwise -> + let (_, xs', st') = consumeMany False 1 i xs st + in skipComment (i + 1) xs' st' consumeMany _ 0 i xs st = (i, xs, st) - consumeMany track n i (c:cs) st = - let st' = advance track c st - in consumeMany track (n - 1) (i + 1) cs st' - consumeMany _ _ i [] st = (i, [], st) + consumeMany track n i xs st = + case T.uncons xs of + Just (c, cs) -> + let st' = advance track c st + in consumeMany track (n - 1) (i + 1) cs st' + Nothing -> (i, T.empty, st) advance track c st = let stPrev = st { scanPrev2 = scanPrev1 st, scanPrev1 = Just c } @@ -1451,7 +1477,7 @@ scanTopLevelChunks src start emit else scanBackslash st } -parseTopLevelChunk :: String -> String -> TopLevelChunk -> IO (Either Control.Exception.SomeException [S.Stmt]) +parseTopLevelChunk :: String -> Text -> TopLevelChunk -> IO (Either Control.Exception.SomeException [S.Stmt]) parseTopLevelChunk fileName fileContent chunk = do parsed <- tryNonAsync $ Control.Exception.evaluate $ @@ -1478,11 +1504,11 @@ data ChunkProgressEvent = ChunkProgressDone Int | ChunkProgressStop data ChunkProgress = ChunkProgress (Chan ChunkProgressEvent) (Async ()) -parseTopLevelChunks :: String -> String -> Int -> Maybe (Int -> Int -> IO ()) -> IO [[S.Stmt]] +parseTopLevelChunks :: String -> Text -> Int -> Maybe (Int -> Int -> IO ()) -> IO [[S.Stmt]] parseTopLevelChunks fileName fileContent bodyStart mReportProgress = do ncap <- getNumCapabilities let nworkers = max 1 ncap - withChunkProgress mReportProgress (length fileContent) bodyStart $ \progress -> do + withChunkProgress mReportProgress (T.length fileContent) bodyStart $ \progress -> do let window = max 1 (10 * nworkers) slots <- newQSem window workQ <- newChan @@ -2042,7 +2068,7 @@ data_stmt = addLoc $ assertDef l "data" S.Data NoLoc Nothing <$> suite DATA s -suiteWithDocstring :: CTX -> Pos -> Parser (S.Suite, Maybe String) +suiteWithDocstring :: CTX -> Pos -> Parser (S.Suite, Maybe Text) suiteWithDocstring c p = do withCtx c colon withCtx c (indentSuiteWithDocstring p <|> (simple_stmt_with_docstring <* reportParseProgress)) @@ -2058,7 +2084,7 @@ suite c p = do p1 <- L.indentGuard sc1 GT p concat <$> some (stmtAtIndent p1) -indentSuiteWithDocstring :: Pos -> Parser (S.Suite, Maybe String) +indentSuiteWithDocstring :: Pos -> Parser (S.Suite, Maybe Text) indentSuiteWithDocstring p = do newline1 p1 <- L.indentGuard sc1 GT p @@ -2066,7 +2092,7 @@ indentSuiteWithDocstring p = do rest <- concat <$> many (stmtAtIndent p1) return (firstStmts ++ rest, mbDoc) -stmtAtIndentWithDocstring :: Pos -> Parser (S.Suite, Maybe String) +stmtAtIndentWithDocstring :: Pos -> Parser (S.Suite, Maybe Text) stmtAtIndentWithDocstring p1 = do p2 <- L.indentLevel case compare p1 p2 of @@ -2084,7 +2110,7 @@ stmtAtIndent p1 = do EQ -> stmt <* reportParseProgress GT -> L.incorrectIndent GT p2 p1 -stmtWithDocstring :: Parser (S.Suite, Maybe String) +stmtWithDocstring :: Parser (S.Suite, Maybe Text) stmtWithDocstring = ( ((\s -> ([s], Nothing)) <$> compound_stmt) <|> try ((\s -> ([s], Nothing)) <$> (signature <* newline1)) @@ -2092,7 +2118,7 @@ stmtWithDocstring = ( <|> simple_stmt_with_docstring ) "statement" -simple_stmt_with_docstring :: Parser (S.Suite, Maybe String) +simple_stmt_with_docstring :: Parser (S.Suite, Maybe Text) simple_stmt_with_docstring = ( do (mbDoc, firstStmts) <- try docstringSmallStmt <|> ((\s -> (Nothing, [s])) <$> small_stmt) @@ -2102,11 +2128,11 @@ simple_stmt_with_docstring = ( return (firstStmts ++ rest, mbDoc) ) "simple statement" -docstringSmallStmt :: Parser (Maybe String, S.Suite) +docstringSmallStmt :: Parser (Maybe Text, S.Suite) docstringSmallStmt = do S.Strings _ ss <- addLoc docstringLiteral _ <- lookAhead (void (char ';') <|> void eol <|> eof) - return (Just (unescapeString (concat ss)), []) + return (Just (T.pack (unescapeString (concatMap T.unpack ss))), []) unescapeString :: String -> String @@ -2172,7 +2198,7 @@ unop name op = do let el = lop `upto` S.eloc i in i{ S.eloc = el , S.ival = negate (S.ival i) - , S.lexeme = '-' : S.lexeme i } + , S.lexeme = T.cons '-' (S.lexeme i) } -- TODO: should loc cover operator + operand here?? _ -> S.UnOp (S.eloc e) op e @@ -2305,11 +2331,11 @@ atom_expr = do return $ maybe (S.Dict NoLoc []) id mbe) <|> var <|> isinstance - <|> (try ((\f -> S.Imaginary NoLoc f (show f ++ "j")) <$> lexeme (L.float <* string "j"))) - <|> (try ((\f -> S.Float NoLoc f (show f)) <$> lexeme L.float)) - <|> (\i -> S.Int NoLoc i ("0o"++showOct i "")) <$> (string "0o" *> lexeme L.octal) - <|> (\i -> S.Int NoLoc i ("0x"++showHex i "")) <$> (string "0x" *> lexeme L.hexadecimal) - <|> (\i -> S.Int NoLoc i (show i)) <$> (lexeme L.decimal) + <|> (try ((\f -> S.Imaginary NoLoc f (T.pack (show f ++ "j"))) <$> lexeme (L.float <* stringS "j"))) + <|> (try ((\f -> S.Float NoLoc f (T.pack (show f))) <$> lexeme L.float)) + <|> (\i -> S.Int NoLoc i (T.pack ("0o"++showOct i ""))) <$> (stringS "0o" *> lexeme L.octal) + <|> (\i -> S.Int NoLoc i (T.pack ("0x"++showHex i ""))) <$> (stringS "0x" *> lexeme L.hexadecimal) + <|> (\i -> S.Int NoLoc i (T.pack (show i))) <$> (lexeme L.decimal) <|> (S.Ellipsis <$> rwordLoc "...") <|> (S.None <$> rwordLoc "None") <|> (S.NotImplemented <$> rwordLoc "NotImplemented") @@ -2378,7 +2404,7 @@ atom_expr = do return (\a -> maybe (S.DotI (loc a `upto` l) a i) (const $ S.RestI (loc a `upto` l) a i) mb) strdot = do (l,ss) <- withLoc plainstrLiteral - return (\a -> S.Dot (loc a `upto` l) a (S.Name l (head ss))) + return (\a -> S.Dot (loc a `upto` l) a (S.Name l (T.pack (head ss)))) -- Parse slice or index: try slice first since it can start with expr sliceOrIndex = try sliceParser <|> indexParser @@ -2532,7 +2558,7 @@ tschema = addLoc $ ttype :: Parser S.Type ttype = addLoc ( rword "None" *> return (S.TNone NoLoc) - <|> (S.TVar NoLoc . S.TV S.KType) <$> (S.Name <$> rwordLoc "Self" <*> return "Self") + <|> (S.TVar NoLoc . S.TV S.KType) <$> (S.Name <$> rwordLoc "Self" <*> return (T.pack "Self")) <|> S.TOpt NoLoc <$> (qmark *> ttype) <|> try (do mbfx <- optional effect (p,k) <- parens funrows diff --git a/compiler/lib/src/Acton/Printer.hs b/compiler/lib/src/Acton/Printer.hs index 6401a87a8..a0f289b91 100644 --- a/compiler/lib/src/Acton/Printer.hs +++ b/compiler/lib/src/Acton/Printer.hs @@ -17,6 +17,7 @@ module Acton.Printer (module Acton.Printer, module Pretty) where import Utils import Pretty import Acton.Syntax +import qualified Data.Text as T import Prelude hiding ((<>)) @@ -38,14 +39,14 @@ prettySuite ss = nest 4 $ vcat $ map pretty ss joinSections :: [Doc] -> Doc joinSections = vcat . punctuate blank . filter (not . isEmpty) -prettyModDoc :: Maybe String -> Doc +prettyModDoc :: Maybe T.Text -> Doc prettyModDoc Nothing = empty -prettyModDoc (Just doc) = text "\"\"\"" <> text (escapeDocstring doc) <> text "\"\"\"" +prettyModDoc (Just doc) = text "\"\"\"" <> text (escapeDocstring (T.unpack doc)) <> text "\"\"\"" -- Pretty print a suite with optional docstring at the beginning -prettyDocSuite :: Maybe String -> Suite -> Doc +prettyDocSuite :: Maybe T.Text -> Suite -> Doc prettyDocSuite Nothing ss = prettySuite ss -prettyDocSuite (Just doc) ss = nest 4 $ vcat $ text "\"\"\"" <> text (escapeDocstring doc) <> text "\"\"\"" : map pretty ss +prettyDocSuite (Just doc) ss = nest 4 $ vcat $ text "\"\"\"" <> text (escapeDocstring (T.unpack doc)) <> text "\"\"\"" : map pretty ss -- Escape special characters in docstrings for pretty printing escapeDocstring :: String -> String @@ -166,15 +167,15 @@ prettyAtom e instance Pretty Expr where pretty (Var _ n) = pretty n - pretty (Int _ _ str) = text str - pretty (Float _ _ str) = text str - pretty (Imaginary _ _ str) = text str + pretty (Int _ _ str) = text (T.unpack str) + pretty (Float _ _ str) = text (T.unpack str) + pretty (Imaginary _ _ str) = text (T.unpack str) pretty (Bool _ v) = pretty v pretty (None _) = text "None" pretty (NotImplemented _) = text "NotImplemented" pretty (Ellipsis _) = text "..." - pretty (Strings _ ss) = hsep (map (pretty . show) ss) - pretty (BStrings _ ss) = hsep (map (\s -> text " b" <> pretty s) ss) + pretty (Strings _ ss) = hsep (map (pretty . show . T.unpack) ss) + pretty (BStrings _ ss) = hsep (map (\s -> text " b" <> pretty (T.unpack s)) ss) pretty (Call _ e ps ks) = prettyAtom e <> parens (pretty (ps,ks)) pretty (TApp _ e ts) = pretty e <> text "@" <> brackets (commaSep pretty ts) pretty (Let _ ss e) = text "let:" $+$ prettySuite ss $+$ text "in" <+> pretty e @@ -280,7 +281,7 @@ instance Pretty QName where -- pretty (NoQ n) = char '~' <> pretty n pretty (NoQ n) = pretty n pretty (GName m n) - | ModName [Name _ "$"] <- m = text ("$" ++ rawstr n) + | m == ModName [name "$"] = text ("$" ++ rawstr n) | otherwise = pretty m <> dot <> pretty n instance Pretty ModRef where diff --git a/compiler/lib/src/Acton/SourceProvider.hs b/compiler/lib/src/Acton/SourceProvider.hs index b43b58867..eb34ec00e 100644 --- a/compiler/lib/src/Acton/SourceProvider.hs +++ b/compiler/lib/src/Acton/SourceProvider.hs @@ -10,14 +10,15 @@ module Acton.SourceProvider ) where import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import Data.Time.Clock (UTCTime) import System.Directory (getModificationTime) -import System.IO (IOMode(ReadMode), hGetContents, hSetEncoding, openFile, utf8) -- | Snapshot of a file's contents. -- The same contents are available as decoded text and raw bytes. data SourceSnapshot = SourceSnapshot - { ssText :: String -- ^ UTF-8 decoded text view. + { ssText :: T.Text -- ^ UTF-8 decoded text view. , ssBytes :: B.ByteString -- ^ Raw bytes for hashing or byte-precise work. , ssIsOverlay :: Bool -- ^ True when the snapshot comes from an overlay. } @@ -43,8 +44,8 @@ diskSourceProvider = SourceProvider { spReadOverlay = \_ -> return Nothing , spReadFile = \path -> do - txt <- readFileUtf8 path bytes <- B.readFile path + let txt = TE.decodeUtf8 bytes return SourceSnapshot { ssText = txt , ssBytes = bytes @@ -52,10 +53,3 @@ diskSourceProvider = } , spGetModTime = getModificationTime } - --- | Read a UTF-8 text file without altering newlines or encoding. -readFileUtf8 :: FilePath -> IO String -readFileUtf8 path = do - h <- openFile path ReadMode - hSetEncoding h utf8 - hGetContents h diff --git a/compiler/lib/src/Acton/Syntax.hs b/compiler/lib/src/Acton/Syntax.hs index 10a59dfcb..2feadc16d 100644 --- a/compiler/lib/src/Acton/Syntax.hs +++ b/compiler/lib/src/Acton/Syntax.hs @@ -19,6 +19,8 @@ import qualified Data.Binary import qualified Data.Set import qualified Data.HashMap.Strict as M import qualified Data.Hashable +import qualified Data.Text as T +import Data.Text (Text) import Data.Char import GHC.Generics (Generic) import Control.DeepSeq @@ -27,7 +29,7 @@ import Prelude hiding((<>)) version :: [Int] version = [0,17] -data Module = Module { modname::ModName, imps::[Import], mdoc::Maybe String, mbody::Suite } deriving (Eq,Show,Generic,NFData) +data Module = Module { modname::ModName, imps::[Import], mdoc::Maybe Text, mbody::Suite } deriving (Eq,Show,Generic,NFData) data Import = Import { iloc::SrcLoc, moduls::[ModuleItem] } | FromImport { iloc::SrcLoc, modul::ModRef, items::[ImportItem] } @@ -59,24 +61,24 @@ data Stmt = Expr { sloc::SrcLoc, expr::Expr } | Decl { sloc::SrcLoc, decls::[Decl] } deriving (Show,Read,NFData,Generic) -data Decl = Def { dloc::SrcLoc, dname:: Name, qbinds::QBinds, pos::PosPar, kwd::KwdPar, ann::Maybe Type, dbody::Suite, deco::Deco, dfx::TFX, ddoc::Maybe String } - | Actor { dloc::SrcLoc, dname:: Name, qbinds::QBinds, pos::PosPar, kwd::KwdPar, dbody::Suite, ddoc::Maybe String } - | Class { dloc::SrcLoc, dname:: Name, qbinds::QBinds, bounds::[TCon], dbody::Suite, ddoc::Maybe String } - | Protocol { dloc::SrcLoc, dname:: Name, qbinds::QBinds, bounds::[PCon], dbody::Suite, ddoc::Maybe String } +data Decl = Def { dloc::SrcLoc, dname:: Name, qbinds::QBinds, pos::PosPar, kwd::KwdPar, ann::Maybe Type, dbody::Suite, deco::Deco, dfx::TFX, ddoc::Maybe Text } + | Actor { dloc::SrcLoc, dname:: Name, qbinds::QBinds, pos::PosPar, kwd::KwdPar, dbody::Suite, ddoc::Maybe Text } + | Class { dloc::SrcLoc, dname:: Name, qbinds::QBinds, bounds::[TCon], dbody::Suite, ddoc::Maybe Text } + | Protocol { dloc::SrcLoc, dname:: Name, qbinds::QBinds, bounds::[PCon], dbody::Suite, ddoc::Maybe Text } -- | Extension { dloc::SrcLoc, dqname::QName, qbinds::QBinds, bounds::[PCon], dbody::Suite } - | Extension { dloc::SrcLoc, qbinds::QBinds, tycon::TCon, bounds::[PCon], dbody::Suite, ddoc::Maybe String } + | Extension { dloc::SrcLoc, qbinds::QBinds, tycon::TCon, bounds::[PCon], dbody::Suite, ddoc::Maybe Text } deriving (Show,Read,NFData,Generic) data Expr = Var { eloc::SrcLoc, var::QName } - | Int { eloc::SrcLoc, ival::Integer, lexeme::String } - | Float { eloc::SrcLoc, dval::Double, lexeme::String } - | Imaginary { eloc::SrcLoc, dval::Double, lexeme::String } + | Int { eloc::SrcLoc, ival::Integer, lexeme::Text } + | Float { eloc::SrcLoc, dval::Double, lexeme::Text } + | Imaginary { eloc::SrcLoc, dval::Double, lexeme::Text } | Bool { eloc::SrcLoc, bval::Bool } | None { eloc::SrcLoc } | NotImplemented{ eloc::SrcLoc } | Ellipsis { eloc::SrcLoc } - | Strings { eloc::SrcLoc, sval::[String] } - | BStrings { eloc::SrcLoc, sval::[String] } + | Strings { eloc::SrcLoc, sval::[Text] } + | BStrings { eloc::SrcLoc, sval::[Text] } | Call { eloc::SrcLoc, fun::Expr, pargs::PosArg, kargs::KwdArg } | Let { eloc::SrcLoc, suit::Suite, exp1::Expr } | TApp { eloc::SrcLoc, fun::Expr, targs::[Type] } @@ -123,12 +125,12 @@ type Target = Expr data Prefix = Globvar | Xistvar | Tempvar | Witness | NormPass | CPSPass | LLiftPass | BoxPass deriving (Eq,Ord,Show,Read,Generic,NFData) -data Name = Name SrcLoc String | Derived Name Name | Internal Prefix String Int deriving (Generic,Show,NFData) +data Name = Name SrcLoc Text | Derived Name Name | Internal Prefix String Int deriving (Generic,Show,NFData) nloc (Name l _) = l nloc _ = NoLoc -nstr (Name _ s) = esc s +nstr (Name _ s) = esc (T.unpack s) where esc (c:'_':s) | isUpper c = c : {- 'X' : -} '_' : esc s esc (c:s) = c : esc s @@ -148,10 +150,10 @@ nstr (Internal p s i) = prefix p ++ "_" ++ unique i ++ s unique 0 = "" unique i = show i -rawstr (Name _ s) = s +rawstr (Name _ s) = T.unpack s rawstr n = nstr n -name = Name NoLoc +name = Name NoLoc . T.pack nWild = name "_" @@ -295,7 +297,7 @@ eDot e n = Dot NoLoc e n eDotI e i = DotI NoLoc e i eNone = None NoLoc eCond e b e' = Cond NoLoc e b e' -eInt n = Int NoLoc n (show n) +eInt n = Int NoLoc n (T.pack (show n)) eBool b = Bool NoLoc b eBinOp e o e' = BinOp NoLoc e o e' eLambda nts e = Lambda NoLoc (pospar nts) KwdNIL e fxPure @@ -357,7 +359,7 @@ tFun0 ps t = tFun fxPure (foldr posRow posNil ps) kwdNil t tSelf = TVar NoLoc tvSelf tvSelf = TV KType nSelf -nSelf = Name NoLoc "Self" +nSelf = name "Self" fxSelf = TV KFX nSelf @@ -750,7 +752,7 @@ instance Eq Type where -- show n = show (nstr n) instance Read Name where - readsPrec p str = [ (Name NoLoc s, str') | (s,str') <- readsPrec p str ] + readsPrec p str = [ (Name NoLoc (T.pack s), str') | (s,str') <- readsPrec p str ] -- Helpers ------------------ @@ -771,14 +773,24 @@ unop op e = UnOp l0 op e binop e1 op e2 = BinOp l0 e1 op e2 cmp e1 op e2 = CompOp l0 e1 [OpArg op e2] -mkStringLit s = Strings l0 ['\'' : s ++ "\'"] +mkStringLit s = Strings l0 [T.pack ('\'' : s ++ "\'")] isIdent s@(c:cs) = isAlpha c && all isAlphaNum cs && not (isKeyword s) where isAlpha c = c `elem` ['a'..'z'] || c `elem` ['A'..'Z'] || c == '_' isAlphaNum c = isAlpha c || c `elem` ['0'..'9'] -isKeyword x = x `Data.Set.member` rws - where rws = Data.Set.fromDistinctAscList [ +isKeyword x = x `Data.Set.member` keywordSet + +isKeywordText x = x `Data.Set.member` keywordTextSet + +keywordSet :: Data.Set.Set String +keywordSet = Data.Set.fromList keywordStrings + +keywordTextSet :: Data.Set.Set Text +keywordTextSet = Data.Set.fromList (map T.pack keywordStrings) + +keywordStrings :: [String] +keywordStrings = [ "False","None","NotImplemented","Self","True","action","actor","after","and","as", "assert","async","await","break","class","continue","def","del","elif","else", "except","extension","finally","for","from","if","import","in","is","isinstance", @@ -803,7 +815,7 @@ hasNotImpl ss = any isNotImpl ss -- Check for __cleanup__ method on actor hasCleanup ss = any isCleanup ss -isCleanup (Def _ n _ _ _ _ _ _ _ _) = n == Name NoLoc "__cleanup__" +isCleanup (Def _ n _ _ _ _ _ _ _ _) = n == name "__cleanup__" isNotImpl (Expr _ e) = e == eNotImpl isNotImpl (Assign _ _ e) = e == eNotImpl diff --git a/compiler/lib/src/Acton/TypeEnv.hs b/compiler/lib/src/Acton/TypeEnv.hs index f7fe359bf..f9a0adc9a 100644 --- a/compiler/lib/src/Acton/TypeEnv.hs +++ b/compiler/lib/src/Acton/TypeEnv.hs @@ -1065,7 +1065,9 @@ intro t mbe = case mbe of Nothing -> pretty t Just e -> text "The type of the indicated expression" <+> text "(" Pretty.<> (if isGen t then text "which we call" else text "inferred to be") <+> pretty t Pretty.<> text ")" - where isGen (TCon _ (TC (NoQ (Name _ ('t' : ds))) [])) = all isDigit ds + where isGen (TCon _ (TC (NoQ n) [])) = case rawstr n of + 't' : ds -> all isDigit ds + _ -> False isGen _ = False explainRequirement c = case info c of @@ -1144,7 +1146,7 @@ typeReport (NoSolve mbt vs cs) filename src = _ -> "Cannot satisfy the following simultaneous constraints for the unknown " ++ (if length vs == 1 then "type " ++ case head vs of - TCon _ tc -> nameStr (noq (tcname tc)) + TCon _ tc -> rawstr (noq (tcname tc)) _ -> show (head vs) else "types") -- Each constraint gets its own complete error message with source line @@ -1160,9 +1162,6 @@ typeReport (NoSolve mbt vs cs) filename src = header [(locToPosition l filename src, This m) | (l,m) <- withLocsMsgs] [] - where - nameStr (Name _ str) = str - typeReport (NoUnify (Simple l msg) _ _) filename src = Err Nothing "Type unification error" [(locToPosition l filename src, This msg)] [] typeReport (NoUnify info t1 t2) filename src = case (loc t1, loc t2) of diff --git a/compiler/lib/src/Acton/Types.hs b/compiler/lib/src/Acton/Types.hs index fa62e86cc..2667a0482 100644 --- a/compiler/lib/src/Acton/Types.hs +++ b/compiler/lib/src/Acton/Types.hs @@ -24,6 +24,7 @@ import Control.Monad.Except (runExceptT) import Control.Monad.State.Strict (runState) import Data.Maybe (isJust) import Data.List (nub, intersect, sort) +import qualified Data.Text as T import Pretty import qualified Control.Exception import Debug.Trace @@ -103,7 +104,7 @@ showTyFile env0 m fname verbose = do putStrLn ("Roots : " ++ (show (map prstr roots))) putStrLn ("Tests : " ++ (show tests)) case mdocH of - Just ds -> putStrLn ("Doc : \"\"\"" ++ ds ++ "\"\"\"") + Just ds -> putStrLn ("Doc : \"\"\"" ++ T.unpack ds ++ "\"\"\"") Nothing -> return () putStrLn ("ModuleSrcBytesHash: 0x" ++ (B.unpack $ Base16.encode srcH)) putStrLn ("ModulePubHash : 0x" ++ (B.unpack $ Base16.encode pubH)) @@ -141,7 +142,7 @@ showTyFile env0 m fname verbose = do putStrLn ("\n############### Interface ############") let NModule imps te mdoc = nmod forM_ mdoc $ \docstring -> - putStrLn $ "\"\"\"" ++ docstring ++ "\"\"\"" + putStrLn $ "\"\"\"" ++ T.unpack docstring ++ "\"\"\"" putStrLn $ prettySigs env0 m imps te @@ -1968,7 +1969,7 @@ instance Infer Expr where return (cs, tStr, eCall formatF [s,e']) where formatF = tApp (eQVar primFORMAT) [prow] tup = tTuple prow kwdNil - prow = format $ concat $ sval s + prow = format $ concatMap T.unpack $ sval s format [] = posNil format ('%':s) = nokey s format (c:s) = format s @@ -2170,7 +2171,7 @@ instance Infer Expr where w1 <- newWitness t1 <- newUnivar env return ([Sub (noinfo 444) env w tNone t1, Sub (noinfo 555) env w1 t t1],t1,eNone) - alt t te False = return ([],t,eCall (tApp (eQVar primRaiseValueError) [te]) [Strings NoLoc ["Forced unwrapping applied to None"]] ) + alt t te False = return ([],t,eCall (tApp (eQVar primRaiseValueError) [te]) [Strings NoLoc [T.pack "Forced unwrapping applied to None"]] ) infer env e@(Rest _ _ _) = notYetExpr e -- infer env (Rest l e n) = do p <- newUnivarOfKind PRow env @@ -2533,7 +2534,7 @@ testStmts env m ss = (stmts, tests) [ testActor ] tests = sort (nub (concatMap assocNames assocs)) assocNames assocList = mapMaybe assocName assocList - assocName (Assoc (Strings _ ssParts) _) = Just (concat ssParts) + assocName (Assoc (Strings _ ssParts) _) = Just (concatMap T.unpack ssParts) assocName _ = Nothing testEnv = [ (name n, NVar (tDict tStr (testing cl))) | (n,cl) <- testDicts ] ++ @@ -2558,26 +2559,26 @@ row2list (TRow _ _ _ t r) = t : row2list r row2list (TNil _ _) = [] mkAssoc d testType modName = - Assoc (Strings NoLoc [nstr (dname d)]) + Assoc (Strings NoLoc [T.pack (nstr (dname d))]) (eCall (eQVar (gname [name "testing"] testType)) [ eVar (dname d) - , Strings NoLoc [nstr (dname d)] + , Strings NoLoc [T.pack (nstr (dname d))] , comment (dbody d) - , Strings NoLoc [modName] + , Strings NoLoc [T.pack modName] ]) where comment (Expr _ s@(Strings _ ss) : _) = s - comment _ = Strings NoLoc [""] + comment _ = Strings NoLoc [T.empty] mkAssocActor (Actor _ n _ _ _ body _) testType modName = - Assoc (Strings NoLoc [nstr n]) + Assoc (Strings NoLoc [T.pack (nstr n)]) (eCall (eQVar (gname [name "testing"] testType)) [ eVar n - , Strings NoLoc [nstr n] + , Strings NoLoc [T.pack (nstr n)] , comment body - , Strings NoLoc [modName] + , Strings NoLoc [T.pack modName] ]) where comment (Expr _ s@(Strings _ ss) : _) = s - comment _ = Strings NoLoc [""] + comment _ = Strings NoLoc [T.empty] testFuns :: Env0 -> String -> Suite -> [[Assoc]] diff --git a/compiler/lib/src/InterfaceFiles.hs b/compiler/lib/src/InterfaceFiles.hs index e20598956..880e83493 100644 --- a/compiler/lib/src/InterfaceFiles.hs +++ b/compiler/lib/src/InterfaceFiles.hs @@ -31,7 +31,7 @@ -- 7) nameHashes :: [NameHashInfo] -- per-name src/pub/impl hashes + deps -- 8) roots :: [A.Name] -- root actors (e.g., main or test_main) -- 9) tests :: [String] -- discovered test names --- 10) docstring :: Maybe String -- module docstring +-- 10) docstring :: Maybe Text -- module docstring -- 11) nameInfo :: I.NameInfo -- type/name environment -- 12) typedModule :: A.Module -- typed module -- @@ -50,6 +50,7 @@ import qualified Control.Exception as E import qualified Data.Binary.Get as BinaryGet import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL +import Data.Text (Text) import qualified Acton.Syntax as A import qualified Acton.NameInfo as I import GHC.Generics (Generic) @@ -90,7 +91,7 @@ type TyFile = , [NameHashInfo] , [A.Name] , [String] - , Maybe String + , Maybe Text ) type TyHeader = @@ -102,7 +103,7 @@ type TyHeader = , [NameHashInfo] , [A.Name] , [String] - , Maybe String + , Maybe Text ) -- Note: tests are stored in the header to support listing without compiling @@ -142,7 +143,7 @@ decodeTyPrefix bsLazy = moduleImplHash <- get :: BinaryGet.Get BS.ByteString return (sourceMeta, moduleSrcBytesHash, modulePubHash, moduleImplHash) -writeFile :: FilePath -> BS.ByteString -> BS.ByteString -> BS.ByteString -> Maybe SourceFileMeta -> [(A.ModName, BS.ByteString)] -> [NameHashInfo] -> [A.Name] -> [String] -> Maybe String -> I.NameInfo -> A.Module -> IO () +writeFile :: FilePath -> BS.ByteString -> BS.ByteString -> BS.ByteString -> Maybe SourceFileMeta -> [(A.ModName, BS.ByteString)] -> [NameHashInfo] -> [A.Name] -> [String] -> Maybe Text -> I.NameInfo -> A.Module -> IO () writeFile f moduleSrcBytesHash modulePubHash moduleImplHash sourceMeta imps nameHashes roots tests mdoc nmod tchecked = do pid <- getProcessID let tmpFile = f ++ "." ++ show pid @@ -159,7 +160,7 @@ readFile f = do nameHashes <- get :: BinaryGet.Get [NameHashInfo] roots <- get :: BinaryGet.Get [A.Name] tests <- get :: BinaryGet.Get [String] - mdoc <- get :: BinaryGet.Get (Maybe String) + mdoc <- get :: BinaryGet.Get (Maybe Text) nmod <- get :: BinaryGet.Get I.NameInfo tmod <- get :: BinaryGet.Get A.Module return (imps, nameHashes, roots, tests, mdoc, nmod, tmod) @@ -182,7 +183,7 @@ readHeader f = do nameHashes <- get :: BinaryGet.Get [NameHashInfo] roots <- get :: BinaryGet.Get [A.Name] tests <- get :: BinaryGet.Get [String] - doc <- get :: BinaryGet.Get (Maybe String) + doc <- get :: BinaryGet.Get (Maybe Text) return (imps, nameHashes, roots, tests, doc) case BinaryGet.runGetOrFail getHdr body1 of Left _ -> ioError (userError "Failed to decode .ty header") diff --git a/compiler/lib/test/ActonSpec.hs b/compiler/lib/test/ActonSpec.hs index a1757dede..e102d9588 100644 --- a/compiler/lib/test/ActonSpec.hs +++ b/compiler/lib/test/ActonSpec.hs @@ -35,6 +35,7 @@ import qualified Control.Monad.Trans.State.Strict as St import Text.Megaparsec (ParseErrorBundle, PosState(..), bundleErrors, bundlePosState, errorOffset, reachOffset, runParser, errorBundlePretty, ShowErrorComponent(..)) import Text.Megaparsec.Pos (sourceLine, unPos) import qualified Data.Text as T +import qualified Data.Text.IO as TIO import Data.List (isInfixOf, isPrefixOf, nub, sort) import qualified Data.List.NonEmpty as NE import Data.IORef @@ -103,7 +104,7 @@ main = do it "reports rough parse progress by source offset" $ do progressRef <- newIORef [] - _ <- P.parseModule (S.modName ["progress"]) "progress.act" "x = 1\n" (Just $ \completed total -> + _ <- P.parseModule (S.modName ["progress"]) "progress.act" (T.pack "x = 1\n") (Just $ \completed total -> modifyIORef' progressRef (++ [(completed, total)])) progress <- readIORef progressRef let completed = map fst progress @@ -254,9 +255,9 @@ main = do , " pass" ] moduleName = S.modName ["chunked"] - result <- E.try (P.parseModule moduleName "chunked.act" input Nothing) + result <- E.try (P.parseModule moduleName "chunked.act" (T.pack input) Nothing) case result of - Left (bundle :: ParseErrorBundle String P.CustomParseError) -> + Left (bundle :: ParseErrorBundle T.Text P.CustomParseError) -> parseBundleErrorLine bundle `shouldBe` 3 Right _ -> expectationFailure "Expected chunked parser to reject malformed input" @@ -1034,7 +1035,7 @@ main = do actFile = "" sysTypesPath = ".." ".." "dist" "base" "out" "types" onInferred names sig = modifyIORef' sigsRef ((names, sig) :) - parsed <- liftIO $ P.parseModule moduleName actFile src Nothing + parsed <- liftIO $ P.parseModule moduleName actFile (T.pack src) Nothing env <- liftIO $ Acton.Env.mkEnv [sysTypesPath] env0 parsed kchecked <- liftIO $ Acton.Kinds.check env parsed _ <- liftIO $ Acton.Types.reconstruct Nothing (Just onInferred) env kchecked @@ -1604,7 +1605,7 @@ main = do -- Helper function to format custom parse errors consistently formatCustomParseError :: String -> String -> SrcLoc -> P.CustomParseError -> String formatCustomParseError filename input loc err = - let diagnostic = Diag.customParseErrorDiagnostic "Syntax error" filename input loc err + let diagnostic = Diag.customParseErrorDiagnostic "Syntax error" filename (T.pack input) loc err doc = prettyDiagnostic WithUnicode (TabSize 4) diagnostic layout = layoutPretty defaultLayoutOptions (unAnnotate doc) in T.unpack $ renderStrict layout @@ -1619,15 +1620,16 @@ parseActon :: String -> Either String String parseActon input = System.IO.Unsafe.unsafePerformIO $ E.catch - (E.evaluate $ case runParser (St.evalStateT P.stmt P.initState) "" inputWithNewline of + (E.evaluate $ case runParser (St.evalStateT P.stmt P.initState) "" inputText of Left err -> Left $ renderDiagnostic err Right result -> Right $ concatMap (Pretty.print) result) handleCustomParseException where inputWithNewline = withTrailingNewline input + inputText = T.pack inputWithNewline handleCustomParseException :: P.CustomParseException -> IO (Either String String) renderDiagnostic err = - let diagnostic = Diag.parseDiagnosticFromBundle "test" inputWithNewline err + let diagnostic = Diag.parseDiagnosticFromBundle "test" inputText err doc = prettyDiagnostic WithUnicode (TabSize 4) diagnostic layout = layoutPretty defaultLayoutOptions (unAnnotate doc) in T.unpack $ renderStrict layout @@ -1639,14 +1641,15 @@ parseModuleTest :: String -> Either String String parseModuleTest input = System.IO.Unsafe.unsafePerformIO $ E.catch - (E.evaluate $ case runParser (St.evalStateT P.file_input P.initState) "test.act" inputWithNewline of + (E.evaluate $ case runParser (St.evalStateT P.file_input P.initState) "test.act" inputText of Left err -> Left $ renderDiagnostic err Right (_imports, _mdoc, _suite) -> Right $ "Module parsed successfully") handleCustomParseException where inputWithNewline = withTrailingNewline input + inputText = T.pack inputWithNewline renderDiagnostic err = - let diagnostic = Diag.parseDiagnosticFromBundle "test.act" inputWithNewline err + let diagnostic = Diag.parseDiagnosticFromBundle "test.act" inputText err doc = prettyDiagnostic WithUnicode (TabSize 4) diagnostic layout = layoutPretty defaultLayoutOptions (unAnnotate doc) in T.unpack $ renderStrict layout @@ -1662,12 +1665,13 @@ expectChunkedParseMatchesSerial input = do expectChunkedParseMatchesSerialFile :: FilePath -> String -> Expectation expectChunkedParseMatchesSerialFile actFile input = do let moduleName = S.modName ["chunked"] - serial <- P.parseModuleSerial moduleName actFile input Nothing - chunked <- P.parseModule moduleName actFile input Nothing + let inputText = T.pack input + serial <- P.parseModuleSerial moduleName actFile inputText Nothing + chunked <- P.parseModule moduleName actFile inputText Nothing when (chunked /= serial) $ expectationFailure ("Chunked parser AST differs from serial parser for " ++ actFile) -parseBundleErrorLine :: ParseErrorBundle String P.CustomParseError -> Int +parseBundleErrorLine :: ParseErrorBundle T.Text P.CustomParseError -> Int parseBundleErrorLine bundle = let firstError = NE.head (bundleErrors bundle) (_, posState) = reachOffset (errorOffset firstError) (bundlePosState bundle) @@ -1799,14 +1803,15 @@ parseStmtAst :: String -> Either String [S.Stmt] parseStmtAst input = System.IO.Unsafe.unsafePerformIO $ E.catch - (E.evaluate $ case runParser (St.evalStateT P.stmt P.initState) "" inputWithNewline of + (E.evaluate $ case runParser (St.evalStateT P.stmt P.initState) "" inputText of Left err -> Left $ renderDiagnostic err Right result -> Right result) handleCustomParseException where inputWithNewline = withTrailingNewline input + inputText = T.pack inputWithNewline renderDiagnostic err = - let diagnostic = Diag.parseDiagnosticFromBundle "test" inputWithNewline err + let diagnostic = Diag.parseDiagnosticFromBundle "test" inputText err doc = prettyDiagnostic WithUnicode (TabSize 4) diagnostic layout = layoutPretty defaultLayoutOptions (unAnnotate doc) in T.unpack $ renderStrict layout @@ -1818,14 +1823,15 @@ parseExprAst :: String -> Either String S.Expr parseExprAst input = System.IO.Unsafe.unsafePerformIO $ E.catch - (E.evaluate $ case runParser (St.evalStateT P.expr P.initState) "" inputWithNewline of + (E.evaluate $ case runParser (St.evalStateT P.expr P.initState) "" inputText of Left err -> Left $ renderDiagnostic err Right result -> Right result) handleCustomParseException where inputWithNewline = withTrailingNewline input + inputText = T.pack inputWithNewline renderDiagnostic err = - let diagnostic = Diag.parseDiagnosticFromBundle "test" inputWithNewline err + let diagnostic = Diag.parseDiagnosticFromBundle "test" inputText err doc = prettyDiagnostic WithUnicode (TabSize 4) diagnostic layout = layoutPretty defaultLayoutOptions (unAnnotate doc) in T.unpack $ renderStrict layout @@ -1926,7 +1932,7 @@ parseAct env0 modulePath = do act_file = "test" "src" modulePath ++ ".act" sysTypesPath = ".." ".." "dist" "base" "out" "types" - src <- liftIO $ readFile act_file + src <- liftIO $ TIO.readFile act_file parsed <- liftIO $ P.parseModule moduleName act_file src Nothing env <- liftIO $ Acton.Env.mkEnv [sysTypesPath] env0 parsed return (env, parsed) @@ -1935,7 +1941,7 @@ typecheckSource env0 modName src = do let moduleName = S.modName [modName] actFile = "<" ++ modName ++ ">" sysTypesPath = ".." ".." "dist" "base" "out" "types" - parsed <- liftIO $ P.parseModule moduleName actFile src Nothing + parsed <- liftIO $ P.parseModule moduleName actFile (T.pack src) Nothing env <- liftIO $ Acton.Env.mkEnv [sysTypesPath] env0 parsed kchecked <- liftIO $ Acton.Kinds.check env parsed (_, tchecked, _, _) <- liftIO $ Acton.Types.reconstruct Nothing Nothing env kchecked @@ -2193,13 +2199,13 @@ testDocstrings env0 testname = do it "extracts module docstrings" $ do case mdoc of Just doc -> do - doc `shouldContain` "Test module" - doc `shouldContain` "{braces}" + T.unpack doc `shouldContain` "Test module" + T.unpack doc `shouldContain` "{braces}" Nothing -> expectationFailure "Module docstring not extracted" it "extracts function docstrings" $ do case lookup "test_function" docstrings of - Just (Just doc) -> doc `shouldContain` "Test function" + Just (Just doc) -> T.unpack doc `shouldContain` "Test function" Just Nothing -> expectationFailure "Function should have docstring" Nothing -> expectationFailure "Function not found" @@ -2211,25 +2217,25 @@ testDocstrings env0 testname = do it "extracts class docstrings" $ do case lookup "TestClass" docstrings of - Just (Just doc) -> doc `shouldContain` "Test class" + Just (Just doc) -> T.unpack doc `shouldContain` "Test class" Just Nothing -> expectationFailure "Class should have docstring" Nothing -> expectationFailure "Class not found" it "extracts actor docstrings" $ do case lookup "TestActor" docstrings of - Just (Just doc) -> doc `shouldContain` "Test actor" + Just (Just doc) -> T.unpack doc `shouldContain` "Test actor" Just Nothing -> expectationFailure "Actor should have docstring" Nothing -> expectationFailure "Actor not found" it "extracts protocol docstrings" $ do case lookup "TestProtocol" docstrings of - Just (Just doc) -> doc `shouldContain` "Test protocol" + Just (Just doc) -> T.unpack doc `shouldContain` "Test protocol" Just Nothing -> expectationFailure "Protocol should have docstring" Nothing -> expectationFailure "Protocol not found" it "extracts extension docstrings" $ do case lookup "extension" docstrings of - Just (Just doc) -> doc `shouldContain` "Extension" + Just (Just doc) -> T.unpack doc `shouldContain` "Extension" Just Nothing -> expectationFailure "Extension should have docstring" Nothing -> expectationFailure "Extension not found" @@ -2243,8 +2249,8 @@ testDocstrings env0 testname = do it "extracts only first string as docstring" $ do case lookup "function_with_multiple_strings" docstrings of Just (Just doc) -> do - doc `shouldContain` "First string is docstring" - when ("Second string" `isInfixOf` doc) $ + T.unpack doc `shouldContain` "First string is docstring" + when ("Second string" `isInfixOf` T.unpack doc) $ expectationFailure "Later strings should not be in docstring" Just Nothing -> expectationFailure "Function should have docstring" Nothing -> expectationFailure "Function not found" @@ -2257,31 +2263,31 @@ testDocstrings env0 testname = do it "handles single quote docstrings" $ do case lookup "function_with_single_quotes" docstrings of - Just (Just doc) -> doc `shouldContain` "Single quote" + Just (Just doc) -> T.unpack doc `shouldContain` "Single quote" Just Nothing -> expectationFailure "Function should have docstring" Nothing -> expectationFailure "Function not found" it "handles triple single quote docstrings" $ do case lookup "function_with_triple_single_quotes" docstrings of - Just (Just doc) -> doc `shouldContain` "Triple quote" + Just (Just doc) -> T.unpack doc `shouldContain` "Triple quote" Just Nothing -> expectationFailure "Function should have docstring" Nothing -> expectationFailure "Function not found" it "handles mixed quotes in docstrings" $ do case lookup "function_with_mixed_quotes" docstrings of - Just (Just doc) -> doc `shouldContain` "Mixed 'quotes'" + Just (Just doc) -> T.unpack doc `shouldContain` "Mixed 'quotes'" Just Nothing -> expectationFailure "Function should have docstring" Nothing -> expectationFailure "Function not found" it "does not interpolate docstrings" $ do case lookup "function_with_braces_docstring" docstrings of - Just (Just doc) -> doc `shouldContain` "{braces}" + Just (Just doc) -> T.unpack doc `shouldContain` "{braces}" Just Nothing -> expectationFailure "Function should have docstring" Nothing -> expectationFailure "Function not found" it "handles empty docstrings" $ do case lookup "function_empty_docstring" docstrings of - Just (Just doc) -> doc `shouldBe` "" + Just (Just doc) -> T.unpack doc `shouldBe` "" Just Nothing -> expectationFailure "Function should have empty docstring" Nothing -> expectationFailure "Function not found" @@ -2293,7 +2299,7 @@ testDocstrings env0 testname = do it "handles functions with just docstrings" $ do case lookup "function_just_docstring" docstrings of - Just (Just doc) -> doc `shouldContain` "Just a docstring" + Just (Just doc) -> T.unpack doc `shouldContain` "Just a docstring" Just Nothing -> expectationFailure "Function should have docstring" Nothing -> expectationFailure "Function not found" @@ -2419,12 +2425,12 @@ testTypeError env0 path = do in addFile diag display_file srcContent _ -> case E.fromException e :: Maybe CompilationError of Just (IllegalSigOverride n) -> - Diag.actErrToDiagnostic "Compilation error" display_file srcContent (loc n) ("Illegal signature override: " ++ prettyText n) + Diag.actErrToDiagnostic "Compilation error" display_file (T.pack srcContent) (loc n) ("Illegal signature override: " ++ prettyText n) Just (OtherError loc msg) -> - Diag.actErrToDiagnostic "Compilation error" display_file srcContent loc msg + Diag.actErrToDiagnostic "Compilation error" display_file (T.pack srcContent) loc msg Just compErr -> -- For other compilation errors, use the default show instance - Diag.actErrToDiagnostic "Compilation error" display_file srcContent (loc compErr) (show compErr) + Diag.actErrToDiagnostic "Compilation error" display_file (T.pack srcContent) (loc compErr) (show compErr) _ -> -- For now, just use the default formatting for other errors let diagnostic = addReport mempty $ Err (Just "error") (show e) [] [] diff --git a/compiler/lsp-server/Main.hs b/compiler/lsp-server/Main.hs index 60e38afd5..371fcc290 100644 --- a/compiler/lsp-server/Main.hs +++ b/compiler/lsp-server/Main.hs @@ -177,7 +177,7 @@ overlaySourceProvider ref = updateOverlay :: FilePath -> T.Text -> IO () updateOverlay path txt = let snap = Source.SourceSnapshot - { Source.ssText = T.unpack txt + { Source.ssText = txt , Source.ssBytes = TE.encodeUtf8 txt , Source.ssIsOverlay = True } @@ -862,7 +862,7 @@ signatureHelpFor path pos = do case snapRes of Left _ -> return (InR Null) Right snap -> do - let src = Source.ssText snap + let src = T.unpack (Source.ssText snap) cursor = positionToOffset src pos msigs <- liftIO $ tryLspIO $ do @@ -884,7 +884,7 @@ hoverFor path pos = do case snapRes of Left _ -> return (InR Null) Right snap -> do - let src = Source.ssText snap + let src = T.unpack (Source.ssText snap) cursor = positionToOffset src pos minfo <- liftIO $ tryLspIO $ do @@ -992,7 +992,7 @@ completionItemsFor path pos = do case snapRes of Left _ -> return [] Right snap -> do - let src = Source.ssText snap + let src = T.unpack (Source.ssText snap) cursor = positionToOffset src pos mitems <- liftIO $ tryLspIO $ do From 3f26d72d5079c20921e236e2c85a3414287986fa Mon Sep 17 00:00:00 2001 From: Kristian Larsson Date: Wed, 20 May 2026 23:15:30 +0200 Subject: [PATCH 2/6] Store internal names as Text Internal compiler names still carried String payloads after parser payloads moved to Text. Convert those name fields to Text and adjust consumers that compare, print, or thread them through compiler passes. This keeps internal names in the same representation as parsed names, so later passes do not reintroduce boxed character lists after parsing. --- compiler/lib/src/Acton/Boxing.hs | 7 ++-- compiler/lib/src/Acton/CPS.hs | 5 +-- compiler/lib/src/Acton/CodeGen.hs | 4 +-- compiler/lib/src/Acton/Env.hs | 2 +- compiler/lib/src/Acton/Kinds.hs | 3 +- compiler/lib/src/Acton/LambdaLifter.hs | 9 ++--- compiler/lib/src/Acton/Names.hs | 4 +-- compiler/lib/src/Acton/Normalizer.hs | 4 +-- compiler/lib/src/Acton/Syntax.hs | 48 +++++++++++++------------- compiler/lib/src/Acton/TypeEnv.hs | 5 +-- 10 files changed, 48 insertions(+), 43 deletions(-) diff --git a/compiler/lib/src/Acton/Boxing.hs b/compiler/lib/src/Acton/Boxing.hs index fe853fc03..4ccdf7307 100644 --- a/compiler/lib/src/Acton/Boxing.hs +++ b/compiler/lib/src/Acton/Boxing.hs @@ -14,6 +14,7 @@ import Utils import Debug.Trace import Control.Monad.State.Strict import Control.Monad.Except +import Data.Text (Text) doBoxing :: Acton.Env.Env0 -> Module -> IO Module doBoxing env m = do return m{mbody = ss} @@ -23,12 +24,12 @@ doBoxing env m = do return m{mbody = ss} type BoxM a = State Int a -newName :: String -> BoxM Name +newName :: Text -> BoxM Name newName s = do n <- get put (n+1) return $ Internal BoxPass s n -newNames (n : ns) = do un <- newName (nstr n) +newNames (n : ns) = do un <- newName (ntext n) ps <- newNames ns return ((n,un) : ps) newNames [] = return [] @@ -108,7 +109,7 @@ instance {-# OVERLAPS #-} Boxing ([Stmt]) where boxing env (x@(Assign l [p@(PVar _ n (Just t))] e) : xs) | isUnboxable t = do case lookup n (unboxedVars env) of Nothing -> do (ws1, e') <- boxing env e - un <- newName (nstr n) + un <- newName (ntext n) let env1 = define (envOf x) (addUnboxedVars [(n,un)] env) (ws2,p') <- boxing env1 p (ws3,xs') <- boxing env1 xs diff --git a/compiler/lib/src/Acton/CPS.hs b/compiler/lib/src/Acton/CPS.hs index 012c327cb..be63b4737 100644 --- a/compiler/lib/src/Acton/CPS.hs +++ b/compiler/lib/src/Acton/CPS.hs @@ -11,12 +11,13 @@ -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, OverloadedStrings #-} module Acton.CPS(convert) where import Debug.Trace import Control.Monad.State.Strict import Control.Monad.Writer +import Data.Text (Text) import Utils import Pretty import Acton.Syntax @@ -44,7 +45,7 @@ runCpsM m = evalState m ([1..], []) contKW = Internal CPSPass "cont" 0 -newName :: String -> CpsM Name +newName :: Text -> CpsM Name newName s = state (\(uniq:supply, stmts) -> (Internal CPSPass s uniq, (supply, stmts))) prefix :: [Stmt] -> CpsM () diff --git a/compiler/lib/src/Acton/CodeGen.hs b/compiler/lib/src/Acton/CodeGen.hs index 8c02d5bf4..bfbdf2314 100644 --- a/compiler/lib/src/Acton/CodeGen.hs +++ b/compiler/lib/src/Acton/CodeGen.hs @@ -66,8 +66,8 @@ myPretty (GName m n) | otherwise = pretty m <> dot <> pretty n myPretty (NoQ w@(Internal _ _ _)) = pretty w -instName (GName m n) = GName m (Derived n (globalName "instance")) -methName (GName m n) = GName m (Derived n (globalName "methods")) +instName (GName m n) = GName m (Derived n (globalName (T.pack "instance"))) +methName (GName m n) = GName m (Derived n (globalName (T.pack "methods"))) derivedHead (Derived d@(Derived{}) _) = derivedHead d derivedHead (Derived n _) = n diff --git a/compiler/lib/src/Acton/Env.hs b/compiler/lib/src/Acton/Env.hs index b158a8eca..df33ad75f 100644 --- a/compiler/lib/src/Acton/Env.hs +++ b/compiler/lib/src/Acton/Env.hs @@ -758,7 +758,7 @@ findTVAttr env tv n = findAttr env c n where c = findTVBound env tv tvarWit :: TVar -> PCon -> Name -tvarWit tv p = Internal Witness (nstr $ Derived (deriveQ $ tcname p) (tvname tv)) 0 +tvarWit tv p = Internal Witness (ntext $ Derived (deriveQ $ tcname p) (tvname tv)) 0 -- Method resolution order ------------------------------------------------------------------------------------------------------ diff --git a/compiler/lib/src/Acton/Kinds.hs b/compiler/lib/src/Acton/Kinds.hs index 2c9da65fa..b571a5128 100644 --- a/compiler/lib/src/Acton/Kinds.hs +++ b/compiler/lib/src/Acton/Kinds.hs @@ -18,6 +18,7 @@ import qualified Control.Exception import Control.DeepSeq (force) import qualified Data.Map.Strict as Map import Data.Map.Strict (Map) +import qualified Data.Text as T import Control.Monad.State.Strict import Control.Monad import Pretty @@ -69,7 +70,7 @@ newWildvar l = do k <- newKUni newKUni = KUni <$> newUnique -newXVar = TV KType <$> (Internal Xistvar "" <$> newUnique) +newXVar = TV KType <$> (Internal Xistvar T.empty <$> newUnique) type KindEnv = EnvF () diff --git a/compiler/lib/src/Acton/LambdaLifter.hs b/compiler/lib/src/Acton/LambdaLifter.hs index 85e04e789..942f181c2 100644 --- a/compiler/lib/src/Acton/LambdaLifter.hs +++ b/compiler/lib/src/Acton/LambdaLifter.hs @@ -11,10 +11,11 @@ -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, OverloadedStrings #-} module Acton.LambdaLifter(liftModule) where import Control.Monad.State.Strict +import Data.Text (Text) import Utils import Acton.Syntax import Acton.Names @@ -79,7 +80,7 @@ type LiftState = ([Decl],[Int]) -- lifted defs, name sup runL :: LiftM a -> a runL m = evalState m ([],[1..]) -newName :: String -> LiftM Name +newName :: Text -> LiftM Name newName s = state (\(totop,uniq:supply) -> (Internal LLiftPass s uniq, (totop,supply))) liftToTop :: [Decl] -> LiftM () @@ -179,7 +180,7 @@ instance (Lift a, EnvOf a, Vars a) => Lift [a] where llSuite env [] = return [] llSuite env (Decl l ds : ss) - | ctxt env == InDef = do ns <- zip fs <$> mapM (newName . nstr) (bound ds) + | ctxt env == InDef = do ns <- zip fs <$> mapM (newName . ntext) (bound ds) let env1 = extNames ns env' ds1 <- ll env1 ds liftToTop (vsubst (selfScopeSubst env) ds1) @@ -257,7 +258,7 @@ freefun env (TApp l (Var l' n) ts) | isDefOrClass env n = Just (TApp l (Var l' (primSubst n)) (conv ts), []) freefun env e = Nothing -closureConvert env lambda t0 vts0 es = do n <- newName (nstr $ noq basename) +closureConvert env lambda t0 vts0 es = do n <- newName (ntext $ noq basename) --traceM ("## closureConvert " ++ prstr lambda ++ " as " ++ prstr n) liftToTop [Class l0 n q bases body Nothing] return $ eCall (tApp (eVar n) (map tVar $ qbound q)) es diff --git a/compiler/lib/src/Acton/Names.hs b/compiler/lib/src/Acton/Names.hs index 22de97c93..b06bf0978 100644 --- a/compiler/lib/src/Acton/Names.hs +++ b/compiler/lib/src/Acton/Names.hs @@ -11,7 +11,7 @@ -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, OverloadedStrings #-} module Acton.Names where import Utils @@ -73,7 +73,7 @@ deriveMod n0 (n:m) = deriveMod (Derived n0 n) m deriveT (TVar _ v) = tvname v deriveT (TCon _ c) = deriveQ (tcname c) -witAttr qn = Internal Witness (nstr $ deriveQ qn) 0 +witAttr qn = Internal Witness (ntext $ deriveQ qn) 0 extensionName [] c = Derived (globalName "ext") (deriveQ $ tcname c) extensionName (p:_) c diff --git a/compiler/lib/src/Acton/Normalizer.hs b/compiler/lib/src/Acton/Normalizer.hs index e77dbc3fd..8a17565a7 100644 --- a/compiler/lib/src/Acton/Normalizer.hs +++ b/compiler/lib/src/Acton/Normalizer.hs @@ -11,7 +11,7 @@ -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts, OverloadedStrings #-} module Acton.Normalizer where import Acton.Syntax @@ -50,7 +50,7 @@ normalize env0 m = return (evalState (norm env m) (0,[]), env -- Normalizing monad type NormM a = State (Int,[(Name,PosPar,Expr)]) a -newName :: String -> NormM Name +newName :: T.Text -> NormM Name newName s = do (n,ts) <- get put (n+1,ts) return $ Internal NormPass s n diff --git a/compiler/lib/src/Acton/Syntax.hs b/compiler/lib/src/Acton/Syntax.hs index 2feadc16d..713029ea0 100644 --- a/compiler/lib/src/Acton/Syntax.hs +++ b/compiler/lib/src/Acton/Syntax.hs @@ -27,7 +27,7 @@ import Control.DeepSeq import Prelude hiding((<>)) version :: [Int] -version = [0,17] +version = [0,18] data Module = Module { modname::ModName, imps::[Import], mdoc::Maybe Text, mbody::Suite } deriving (Eq,Show,Generic,NFData) @@ -125,33 +125,33 @@ type Target = Expr data Prefix = Globvar | Xistvar | Tempvar | Witness | NormPass | CPSPass | LLiftPass | BoxPass deriving (Eq,Ord,Show,Read,Generic,NFData) -data Name = Name SrcLoc Text | Derived Name Name | Internal Prefix String Int deriving (Generic,Show,NFData) +data Name = Name SrcLoc Text | Derived Name Name | Internal Prefix Text Int deriving (Generic,Show,NFData) nloc (Name l _) = l nloc _ = NoLoc -nstr (Name _ s) = esc (T.unpack s) - where esc (c:'_':s) - | isUpper c = c : {- 'X' : -} '_' : esc s - esc (c:s) = c : esc s - esc "" = "" -nstr (Derived n s) - | Internal{} <- s = nstr n ++ nstr s - | otherwise = nstr n ++ "D_" ++ nstr s -nstr (Internal p s i) = prefix p ++ "_" ++ unique i ++ s - where prefix Globvar = "G" - prefix Xistvar = "E" - prefix Tempvar = "V" - prefix Witness = "W" - prefix NormPass = "N" - prefix CPSPass = "C" - prefix LLiftPass = "L" - prefix BoxPass = "U" - unique 0 = "" - unique i = show i - -rawstr (Name _ s) = T.unpack s -rawstr n = nstr n +nstr = T.unpack . ntext + +ntext (Name _ s) = s +ntext (Derived n s) + | Internal{} <- s = T.concat [ntext n, ntext s] + | otherwise = T.concat [ntext n, T.pack "D_", ntext s] +ntext (Internal p s i) = T.concat [prefix p, T.singleton '_', unique i, s] + where prefix Globvar = T.singleton 'G' + prefix Xistvar = T.singleton 'E' + prefix Tempvar = T.singleton 'V' + prefix Witness = T.singleton 'W' + prefix NormPass = T.singleton 'N' + prefix CPSPass = T.singleton 'C' + prefix LLiftPass = T.singleton 'L' + prefix BoxPass = T.singleton 'U' + unique 0 = T.empty + unique i = T.pack (show i) + +rawstr = T.unpack . rawText + +rawText (Name _ s) = s +rawText n = ntext n name = Name NoLoc . T.pack diff --git a/compiler/lib/src/Acton/TypeEnv.hs b/compiler/lib/src/Acton/TypeEnv.hs index f9a0adc9a..971dc58a2 100644 --- a/compiler/lib/src/Acton/TypeEnv.hs +++ b/compiler/lib/src/Acton/TypeEnv.hs @@ -32,6 +32,7 @@ import qualified Data.IntMap.Strict as IntMap import Data.IntMap.Strict (IntMap) import qualified Data.IntSet as IntSet import Data.IntSet (IntSet) +import qualified Data.Text as T import Pretty import Utils @@ -469,8 +470,8 @@ uextend s = lift $ newGenerated p = do i <- newUnique st <- currentState return $ Internal p (tag (uniqprefix st) i) 0 - where tag "" i = show i - tag s i = s ++ "_" ++ show i + where tag "" i = T.pack (show i) + tag s i = T.concat [T.pack s, T.singleton '_', T.pack (show i)] newWitness = newGenerated Witness From c40f685a1f994c62a296ac24f696c7a317395908 Mon Sep 17 00:00:00 2001 From: Kristian Larsson Date: Wed, 20 May 2026 23:15:44 +0200 Subject: [PATCH 3/6] Unpack small compiler fields Several common compiler records still stored tiny strict fields through separate heap boxes. Unpack source locations and small AST metadata fields that are carried in large numbers. The field types and semantics stay the same; this only changes the heap layout of values that are already strict. --- compiler/lib/src/Acton/NameInfo.hs | 2 +- compiler/lib/src/Acton/Syntax.hs | 20 ++++++++++---------- compiler/lib/src/Acton/TypeEnv.hs | 6 +++--- compiler/lib/src/Utils.hs | 2 +- 4 files changed, 15 insertions(+), 15 deletions(-) diff --git a/compiler/lib/src/Acton/NameInfo.hs b/compiler/lib/src/Acton/NameInfo.hs index b8b3844c8..81f16e2e3 100644 --- a/compiler/lib/src/Acton/NameInfo.hs +++ b/compiler/lib/src/Acton/NameInfo.hs @@ -390,7 +390,7 @@ unSig te = map f te -- Witnesses ----------------------------------------------------------------------------------------------- -data Witness = WClass { binds::QBinds, wtype::Type, proto::PCon, wname::QName, wsteps::WPath, wopts::Int } +data Witness = WClass { binds::QBinds, wtype::Type, proto::PCon, wname::QName, wsteps::WPath, wopts:: {-# UNPACK #-} !Int } | WInst { binds::QBinds, wtype::Type, proto::PCon, wname::QName, wsteps::WPath } deriving (Show) diff --git a/compiler/lib/src/Acton/Syntax.hs b/compiler/lib/src/Acton/Syntax.hs index 713029ea0..0f87c1ad1 100644 --- a/compiler/lib/src/Acton/Syntax.hs +++ b/compiler/lib/src/Acton/Syntax.hs @@ -70,10 +70,10 @@ data Decl = Def { dloc::SrcLoc, dname:: Name, qbinds::QBinds, po deriving (Show,Read,NFData,Generic) data Expr = Var { eloc::SrcLoc, var::QName } - | Int { eloc::SrcLoc, ival::Integer, lexeme::Text } - | Float { eloc::SrcLoc, dval::Double, lexeme::Text } - | Imaginary { eloc::SrcLoc, dval::Double, lexeme::Text } - | Bool { eloc::SrcLoc, bval::Bool } + | Int { eloc::SrcLoc, ival:: !Integer, lexeme::Text } + | Float { eloc::SrcLoc, dval:: {-# UNPACK #-} !Double, lexeme::Text } + | Imaginary { eloc::SrcLoc, dval:: {-# UNPACK #-} !Double, lexeme::Text } + | Bool { eloc::SrcLoc, bval:: {-# UNPACK #-} !Bool } | None { eloc::SrcLoc } | NotImplemented{ eloc::SrcLoc } | Ellipsis { eloc::SrcLoc } @@ -93,9 +93,9 @@ data Expr = Var { eloc::SrcLoc, var::QName } | UnOp { eloc::SrcLoc, uop::Unary, exp1::Expr } | Dot { eloc::SrcLoc, exp1::Expr, attr::Name } | Rest { eloc::SrcLoc, exp1::Expr, attr::Name } - | DotI { eloc::SrcLoc, exp1::Expr, ival::Integer } - | RestI { eloc::SrcLoc, exp1::Expr, ival::Integer } - | Opt { eloc::SrcLoc, exp1::Expr, optVal::Bool } + | DotI { eloc::SrcLoc, exp1::Expr, ival:: !Integer } + | RestI { eloc::SrcLoc, exp1::Expr, ival:: !Integer } + | Opt { eloc::SrcLoc, exp1::Expr, optVal:: {-# UNPACK #-} !Bool } | OptChain { eloc::SrcLoc, exp1::Expr } | Lambda { eloc::SrcLoc, ppar::PosPar, kpar::KwdPar, exp1::Expr, efx::TFX } | Yield { eloc::SrcLoc, yexp1::Maybe Expr } @@ -125,7 +125,7 @@ type Target = Expr data Prefix = Globvar | Xistvar | Tempvar | Witness | NormPass | CPSPass | LLiftPass | BoxPass deriving (Eq,Ord,Show,Read,Generic,NFData) -data Name = Name SrcLoc Text | Derived Name Name | Internal Prefix Text Int deriving (Generic,Show,NFData) +data Name = Name SrcLoc Text | Derived Name Name | Internal Prefix Text {-# UNPACK #-} !Int deriving (Generic,Show,NFData) nloc (Name l _) = l nloc _ = NoLoc @@ -212,14 +212,14 @@ data Comparison = Eq|NEq|LtGt|Lt|Gt|GE|LE|In|NotIn|Is|IsNot deriving (Show,Eq,Re data Deco = NoDec | Property | Static deriving (Eq,Show,Read,Generic,NFData) -data Kind = KType | KProto | KFX | PRow | KRow | KFun [Kind] Kind | KUni Int | KWild deriving (Eq,Ord,Show,Read,Generic,NFData) +data Kind = KType | KProto | KFX | PRow | KRow | KFun [Kind] Kind | KUni {-# UNPACK #-} !Int | KWild deriving (Eq,Ord,Show,Read,Generic,NFData) data TSchema = TSchema { scloc::SrcLoc, scbind::QBinds, sctype::Type } deriving (Show,Read,Generic,NFData) data TVar = TV { tvkind::Kind, tvname::Name } -- the Name is an uppercase letter, optionally followed by digits. deriving (Show,Read,Generic,NFData) -data TUni = UV { uvkind::Kind, uvlevel::Int, uvid::Int } +data TUni = UV { uvkind::Kind, uvlevel:: {-# UNPACK #-} !Int, uvid:: {-# UNPACK #-} !Int } deriving (Show,Read,Generic,NFData) univar k l i = UV k l i diff --git a/compiler/lib/src/Acton/TypeEnv.hs b/compiler/lib/src/Acton/TypeEnv.hs index 971dc58a2..fd5db842d 100644 --- a/compiler/lib/src/Acton/TypeEnv.hs +++ b/compiler/lib/src/Acton/TypeEnv.hs @@ -405,7 +405,7 @@ headvar (Seal _ _ (TUni _ u)) = u -- Type inference monad ------------------------------------------------------------------ data TypeState = TypeState { - nextint :: Int, + nextint :: {-# UNPACK #-} !Int, uniqprefix :: String, -- Prefix for generated names effectstack :: [(TFX,Type)], deferred :: Constraints, @@ -903,7 +903,7 @@ wvars cs = [ eVar v | Proto _ _ v _ _ <- cs ] -- Equations ----------------------------------------------------------------------------------------------------------------------- -data Equation = Eqn Int Name Type Expr +data Equation = Eqn {-# UNPACK #-} !Int Name Type Expr type Equations = [Equation] @@ -1010,7 +1010,7 @@ data TypeError = TypeError SrcLoc String | UninitializedAttribute SrcLoc Name Bool SrcLoc SrcLoc Name (Maybe (Name, SrcLoc)) -- attr loc, attr name, is inferred, init loc, class loc, class name, parent class info deriving (Show) -data ErrInfo = DfltInfo {errloc :: SrcLoc, errno :: Int, errexpr :: Maybe Expr, errinsts :: [(QName,TSchema,Type)]} +data ErrInfo = DfltInfo {errloc :: SrcLoc, errno :: {-# UNPACK #-} !Int, errexpr :: Maybe Expr, errinsts :: [(QName,TSchema,Type)]} | DeclInfo {errloc :: SrcLoc, errloc2 :: SrcLoc, errname :: Name, errschema :: TSchema, errmsg :: String} | Simple {errloc ::SrcLoc, errmsg :: String} deriving (Show) diff --git a/compiler/lib/src/Utils.hs b/compiler/lib/src/Utils.hs index e4962a564..c63dc3623 100644 --- a/compiler/lib/src/Utils.hs +++ b/compiler/lib/src/Utils.hs @@ -30,7 +30,7 @@ import System.FilePath (takeDirectory, takeFileName) import System.IO (openTempFile, hSetEncoding, utf8, hPutStr, hClose) import System.IO.Error (catchIOError) -data SrcLoc = Loc Int Int | NoLoc deriving (Eq,Ord,Show,Read,Generic,NFData) +data SrcLoc = Loc {-# UNPACK #-} !Int {-# UNPACK #-} !Int | NoLoc deriving (Eq,Ord,Show,Read,Generic,NFData) instance Data.Binary.Binary SrcLoc where put NoLoc = Data.Binary.put False From b09cb60e64280ec9e284fe79c2fd4c7764a8e47a Mon Sep 17 00:00:00 2001 From: Kristian Larsson Date: Wed, 20 May 2026 23:15:59 +0200 Subject: [PATCH 4/6] Allow underscore lambda parameters The parser treats _ as a keyword for ordinary identifiers, but lambda parameters can use it as a throwaway name. After the Text cleanup, that path rejected call arguments containing lambda c, _, err. Accept _ through parameter parsing only, where it is valid. Keep normal identifier diagnostics unchanged and add a parser regression covering the lambda call-argument case. --- compiler/lib/src/Acton/Parser.hs | 15 +++++++++++---- compiler/lib/test/ActonSpec.hs | 6 ++++++ 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/compiler/lib/src/Acton/Parser.hs b/compiler/lib/src/Acton/Parser.hs index ad5774ee2..bc4a6fa9a 100644 --- a/compiler/lib/src/Acton/Parser.hs +++ b/compiler/lib/src/Acton/Parser.hs @@ -1115,8 +1115,9 @@ singleStar = (lexeme . try) (char '*' <* notFollowedBy (char '*')) identifier :: Parser Text identifier = (lexeme . try) $ do off <- getOffset - void $ lookAhead (satisfy (\c -> isAlpha c || c == '_') "identifier") - x <- takeWhile1P (Just "identifier") (\c -> isAlphaNum c || c=='_') + c <- satisfy (\c -> isAlpha c || c == '_') "identifier" + cs <- hidden (takeWhileP Nothing (\c -> isAlphaNum c || c == '_')) + let x = T.cons c cs if S.isKeywordText x then parseError (TrivialError off (Just (Tokens (N.fromList (T.unpack x)))) (Set.fromList [Label (N.fromList "identifier")])) else return x @@ -1130,6 +1131,12 @@ name = do off <- getOffset escname = name <|> addLoc (S.name . head <$> plainstrLiteral) -- Assumes an escname cannot contain hex escape sequences +paramName :: Parser S.Name +paramName = name <|> do + off <- getOffset + rword "_" + return $ S.Name (Loc off (off + 1)) (T.singleton '_') + tvarname = do off <- getOffset x <- identifier if isTypeVarName x @@ -2448,13 +2455,13 @@ yield_expr = addLoc $ do --- Params --------------------------------------------------------------------- parm :: Bool -> Parser (S.Name, Maybe S.Type, Maybe S.Expr) -parm ann = do n <- name +parm ann = do n <- paramName mbt <- if ann then optional (colon *> ttype) else return Nothing mbe <- optional (equals *> expr) return (n, mbt, mbe) pstar :: Bool -> Parser S.Type -> Parser (S.Name, Maybe S.Type) -pstar ann startype = do n <- name +pstar ann startype = do n <- paramName mbt <- if ann then optional (colon *> startype) else return Nothing return (n, mbt) diff --git a/compiler/lib/test/ActonSpec.hs b/compiler/lib/test/ActonSpec.hs index e102d9588..10ea2f30b 100644 --- a/compiler/lib/test/ActonSpec.hs +++ b/compiler/lib/test/ActonSpec.hs @@ -113,6 +113,12 @@ main = do completed `shouldSatisfy` monotonic last progress `shouldBe` (6, 6) + it "allows underscore parameters in lambdas" $ do + let input = "def f():\n rpc(a, lambda c, _, err: cb(c, err))\n" + case parseModuleTest input of + Left err -> expectationFailure $ "Parse failed: " ++ err + Right _ -> return () + describe "Basic Syntax" $ do testParse env0 ["syntax1"] From 3d47b48e8e5443932ae5985e62a9c9b3b30c004e Mon Sep 17 00:00:00 2001 From: Kristian Larsson Date: Wed, 20 May 2026 23:16:14 +0200 Subject: [PATCH 5/6] Parse payloads from Text slices Literal and token parsers still converted through String or built Text one character at a time. Capture chunks from the Text input directly for identifiers, numbers, string fragments, format specs, quote runs, and escape digits. This keeps source spans stable and makes the affected numeric diagnostics use more precise decimal and hexadecimal digit labels, while reducing intermediate allocation before AST construction. Update the kinds and types bench readers to keep benchmark sources in Text too. --- compiler/acton/test/syntaxerrors/err10.golden | 4 +- compiler/acton/test/syntaxerrors/err15.golden | 4 +- compiler/acton/test/syntaxerrors/err27.golden | 4 +- compiler/acton/test/syntaxerrors/err37.golden | 4 +- compiler/acton/test/syntaxerrors/err38.golden | 4 +- compiler/lib/bench/KindsBench.hs | 3 +- compiler/lib/bench/TypesBench.hs | 3 +- compiler/lib/src/Acton/Parser.hs | 512 ++++++++++++------ 8 files changed, 373 insertions(+), 165 deletions(-) diff --git a/compiler/acton/test/syntaxerrors/err10.golden b/compiler/acton/test/syntaxerrors/err10.golden index 761bb0a01..0b1528b7f 100644 --- a/compiler/acton/test/syntaxerrors/err10.golden +++ b/compiler/acton/test/syntaxerrors/err10.golden @@ -1,12 +1,12 @@ Building file test/syntaxerrors/err10.act using temporary scratch directory [error Parse error]: unexpected newline - expecting ':', call arguments, slice/index expression, digit, if clause, or operator + expecting ':', call arguments, slice/index expression, decimal digit, if clause, or operator +--> test/syntaxerrors/err10.act@3:13-3:14 | 3 | if x > 0 : ^ : `- unexpected newline - : expecting ':', call arguments, slice/index expression, digit, if clause, or operator + : expecting ':', call arguments, slice/index expression, decimal digit, if clause, or operator : -----+ diff --git a/compiler/acton/test/syntaxerrors/err15.golden b/compiler/acton/test/syntaxerrors/err15.golden index 30b7a7fcd..b2b7d0579 100644 --- a/compiler/acton/test/syntaxerrors/err15.golden +++ b/compiler/acton/test/syntaxerrors/err15.golden @@ -1,12 +1,12 @@ Building file test/syntaxerrors/err15.act using temporary scratch directory [error Parse error]: unexpected '}' - expecting call arguments, slice/index expression, closing ']', comma, digit, if clause, or operator + expecting call arguments, slice/index expression, closing ']', comma, decimal digit, if clause, or operator +--> test/syntaxerrors/err15.act@4:17-4:18 | 4 | return arr[0} : ^ : `- unexpected '}' - : expecting call arguments, slice/index expression, closing ']', comma, digit, if clause, or operator + : expecting call arguments, slice/index expression, closing ']', comma, decimal digit, if clause, or operator : -----+ diff --git a/compiler/acton/test/syntaxerrors/err27.golden b/compiler/acton/test/syntaxerrors/err27.golden index 417862493..d51ed61e2 100644 --- a/compiler/acton/test/syntaxerrors/err27.golden +++ b/compiler/acton/test/syntaxerrors/err27.golden @@ -1,12 +1,12 @@ Building file test/syntaxerrors/err27.act using temporary scratch directory [error Parse error]: unexpected "ab" - expecting ';', call arguments, slice/index expression, comma, digit, end of line, if clause, or operator + expecting ';', call arguments, slice/index expression, comma, decimal digit, end of line, if clause, or operator +--> test/syntaxerrors/err27.act@3:15-3:16 | 3 | return 123abc : ^ : `- unexpected "ab" - : expecting ';', call arguments, slice/index expression, comma, digit, end of line, if clause, or operator + : expecting ';', call arguments, slice/index expression, comma, decimal digit, end of line, if clause, or operator : -----+ diff --git a/compiler/acton/test/syntaxerrors/err37.golden b/compiler/acton/test/syntaxerrors/err37.golden index 497bb8d23..fd55d300c 100644 --- a/compiler/acton/test/syntaxerrors/err37.golden +++ b/compiler/acton/test/syntaxerrors/err37.golden @@ -1,12 +1,12 @@ Building file test/syntaxerrors/err37.act using temporary scratch directory [error Parse error]: unexpected "b1" - expecting ';', call arguments, slice/index expression, comma, digit, end of line, if clause, or operator + expecting ';', call arguments, slice/index expression, comma, decimal digit, end of line, if clause, or operator +--> test/syntaxerrors/err37.act@3:13-3:14 | 3 | return 0b102 : ^ : `- unexpected "b1" - : expecting ';', call arguments, slice/index expression, comma, digit, end of line, if clause, or operator + : expecting ';', call arguments, slice/index expression, comma, decimal digit, end of line, if clause, or operator : -----+ diff --git a/compiler/acton/test/syntaxerrors/err38.golden b/compiler/acton/test/syntaxerrors/err38.golden index 06b673070..09692a7bc 100644 --- a/compiler/acton/test/syntaxerrors/err38.golden +++ b/compiler/acton/test/syntaxerrors/err38.golden @@ -1,12 +1,12 @@ Building file test/syntaxerrors/err38.act using temporary scratch directory [error Parse error]: unexpected 'G' - expecting hexadecimal integer + expecting hexadecimal digit +--> test/syntaxerrors/err38.act@3:14-3:15 | 3 | return 0xGHI : ^ : `- unexpected 'G' - : expecting hexadecimal integer + : expecting hexadecimal digit : -----+ diff --git a/compiler/lib/bench/KindsBench.hs b/compiler/lib/bench/KindsBench.hs index ccad6493a..8ce40cf80 100644 --- a/compiler/lib/bench/KindsBench.hs +++ b/compiler/lib/bench/KindsBench.hs @@ -7,6 +7,7 @@ import qualified Acton.Syntax as Syntax import Control.DeepSeq (rnf) import qualified Control.Exception as E import qualified Data.HashMap.Strict as HashMap +import qualified Data.Text.IO as TIO import Data.Time.Clock (diffUTCTime, getCurrentTime) import GHC.Stats import System.Environment (getArgs) @@ -45,7 +46,7 @@ main = do case args of [typesPath, sourcePath] -> do statsEnabled <- getRTSStatsEnabled - src <- readFile sourcePath + src <- TIO.readFile sourcePath env0 <- Env.initEnv typesPath False let modName = Syntax.modName [takeBaseName sourcePath] diff --git a/compiler/lib/bench/TypesBench.hs b/compiler/lib/bench/TypesBench.hs index cecf94a89..6c967667c 100644 --- a/compiler/lib/bench/TypesBench.hs +++ b/compiler/lib/bench/TypesBench.hs @@ -8,6 +8,7 @@ import qualified Acton.Types as Types import Control.DeepSeq (rnf) import qualified Control.Exception as E import qualified Data.HashMap.Strict as HashMap +import qualified Data.Text.IO as TIO import Data.Time.Clock (diffUTCTime, getCurrentTime) import GHC.Stats import System.Environment (getArgs) @@ -46,7 +47,7 @@ main = do case args of [typesPath, sourcePath] -> do statsEnabled <- getRTSStatsEnabled - src <- readFile sourcePath + src <- TIO.readFile sourcePath env0 <- Env.initEnv typesPath False let modName = Syntax.modName [takeBaseName sourcePath] diff --git a/compiler/lib/src/Acton/Parser.hs b/compiler/lib/src/Acton/Parser.hs index bc4a6fa9a..03925a538 100644 --- a/compiler/lib/src/Acton/Parser.hs +++ b/compiler/lib/src/Acton/Parser.hs @@ -36,7 +36,6 @@ import Data.Text (Text) import qualified Data.List.NonEmpty as N import qualified Data.Set as Set import GHC.Conc (getNumCapabilities) -import Numeric import Text.Megaparsec import Text.Megaparsec.Char import Text.Megaparsec.Error @@ -473,11 +472,23 @@ locate (Loc l _) = setOffset l lexeme:: Parser a -> Parser a lexeme p = p <* currSC +lexemeWithText :: Parser a -> Parser (a, Text) +lexemeWithText p = lexeme $ do + input <- getInput + off1 <- getOffset + a <- p + off2 <- getOffset + return (a, T.take (off2 - off1) input) + stringS :: String -> Parser Text stringS = string . T.pack -symbol :: String -> Parser Text -symbol str = lexeme (stringS str) +stringS_ :: String -> Parser () +stringS_ = void . stringS + +symbol :: String -> Parser () +symbol [c] = lexeme (void (char c)) +symbol str = lexeme (stringS_ str) newline1 :: Parser [S.Stmt] newline1 = const [] <$> (eol *> sc2) @@ -518,14 +529,27 @@ Prefix sequences are also as in subsection 2.4.1 with the following exceptions -} strings :: Parser S.Expr -strings = addLoc $ - bytesLiteral +strings = addLoc $ do + start <- stringStart + case start of + BytesString -> bytesLiteral + RawString -> rawStringLiteral + FString -> fstringLiteral + PlainString -> stringLiteral + +data StringStart = BytesString | RawString | FString | PlainString + +stringStart :: Parser StringStart +stringStart = lookAhead $ + try (char 'r' *> char 'b' *> oneOf ("'\"" :: String) *> return BytesString) + <|> + (char 'b' *> oneOf ("'\"" :: String) *> return BytesString) <|> - rawStringLiteral + (char 'r' *> oneOf ("'\"" :: String) *> return RawString) <|> - fstringLiteral -- Explicit f"..." syntax, with interpolation + (char 'f' *> oneOf ("'\"" :: String) *> return FString) <|> - stringLiteral -- "" strings - all strings support interpolation + (oneOf ("'\"" :: String) *> return PlainString) -- We use this `some` construct because Acton allows multiple adjacent strings -- to be effectively concatenated together without specifying any explicit @@ -536,21 +560,21 @@ strings = addLoc $ -- This will be parsed as a single string literal, not two separate ones. bytesLiteral :: Parser S.Expr -bytesLiteral = S.BStrings NoLoc . map T.pack . concat <$> some bytesLiteralCombo +bytesLiteral = S.BStrings NoLoc . concat <$> some bytesLiteralCombo -- | b"" and rb"" -bytesLiteralCombo :: Parser [String] +bytesLiteralCombo :: Parser [Text] bytesLiteralCombo = plainbytesLiteral <|> rawbytesLiteral "bytes literal" -- | Raw string literals (r"...") that don't support interpolation rawStringLiteral :: Parser S.Expr -rawStringLiteral = S.Strings NoLoc . map T.pack . concat <$> some rawstrLiteral "string literal" +rawStringLiteral = S.Strings NoLoc . concat <$> some rawstrLiteral "string literal" -- Docstring parser - parses strings with normal escape handling but no interpolation docstringLiteral :: Parser S.Expr docstringLiteral = (do parts <- some docstringPlainLiteral - return $ S.Strings NoLoc [T.pack (concat (concat parts))] + return $ S.Strings NoLoc [T.concat (concat parts)] ) "docstring" where docstringPlainLiteral = @@ -595,26 +619,26 @@ concatStringLiterals singleStringParser = do -- Multiple strings need to be concatenated -- We need to combine all the format strings and collect all expressions let (formatParts, exprLists) = unzip $ map extractParts multiple - combinedFormat = concat formatParts + combinedFormat = T.concat formatParts combinedExprs = concat exprLists if null combinedExprs - then return $ S.Strings NoLoc [T.pack combinedFormat] + then return $ S.Strings NoLoc [combinedFormat] else return $ S.BinOp NoLoc - (S.Strings NoLoc [T.pack combinedFormat]) + (S.Strings NoLoc [combinedFormat]) S.Mod (if length combinedExprs == 1 then head combinedExprs else S.Tuple NoLoc (foldr S.PosArg S.PosNil combinedExprs) S.KwdNil) where -- Extract format string and expressions from each part - extractParts :: S.Expr -> (String, [S.Expr]) - extractParts (S.Strings _ ss) = (concatMap T.unpack ss, []) + extractParts :: S.Expr -> (Text, [S.Expr]) + extractParts (S.Strings _ ss) = (T.concat ss, []) extractParts (S.BinOp _ (S.Strings _ [fmt]) S.Mod expr) = case expr of - S.Tuple _ args _ -> (T.unpack fmt, tupleToList args) - e -> (T.unpack fmt, [e]) - extractParts _ = ("", []) -- Should not happen + S.Tuple _ args _ -> (fmt, tupleToList args) + e -> (fmt, [e]) + extractParts _ = (T.empty, []) -- Should not happen -- Convert tuple arguments to list tupleToList :: S.PosArg -> [S.Expr] @@ -624,15 +648,15 @@ concatStringLiterals singleStringParser = do -- | Parts of an interpolated string data StringPart - = TextPart String -- ^ Regular text content - | ExprPart S.Expr String -- ^ Expression with format specifier + = TextPart Text -- ^ Regular text content + | ExprPart S.Expr Text -- ^ Expression with format specifier deriving Show -- | Convert f-string parts to a format string with specifiers -buildFormatString :: [StringPart] -> String -buildFormatString [] = "" -buildFormatString (TextPart s : rest) = s ++ buildFormatString rest -buildFormatString (ExprPart _ fmt : rest) = "%" ++ fmt ++ buildFormatString rest +buildFormatString :: [StringPart] -> Text +buildFormatString [] = T.empty +buildFormatString (TextPart s : rest) = s <> buildFormatString rest +buildFormatString (ExprPart _ fmt : rest) = T.cons '%' fmt <> buildFormatString rest -- | Parse a string with optional interpolation expressions -- Both regular strings and f-strings support interpolation in Acton @@ -644,8 +668,8 @@ parseInterpolatedString startQuote endQuote textPartParser = lexeme $ do let startQuoteCharOffset = startLoc + (length startQuote - length endQuote) let stringPart = choice [ -- Escaped braces - handle these BEFORE expression parsing - try (stringS "{{" >> return (TextPart "{")), - try (stringS "}}" >> return (TextPart "}")), + try (stringS "{{" >> return (TextPart (T.singleton '{'))), + try (stringS "}}" >> return (TextPart (T.singleton '}'))), -- Expression parts (now without the notFollowedBy check) try exprPart, -- Regular text @@ -670,14 +694,14 @@ parseInterpolatedString startQuote endQuote textPartParser = lexeme $ do if null exprs then do -- No expressions found, create a regular string - let textContent = concat [s | TextPart s <- parts] + let textContent = T.concat [s | TextPart s <- parts] -- Apply hex splitting to handle cases like "\x48ello" -> ["\x48", "ello"] - return $ S.Strings NoLoc (map T.pack (hexSplitString textContent)) + return $ S.Strings NoLoc (hexSplitText textContent) else do -- Found expressions, create interpolated string format let formatStr = buildFormatString parts result = S.BinOp NoLoc - (S.Strings NoLoc [T.pack formatStr]) + (S.Strings NoLoc [formatStr]) S.Mod (if length exprs == 1 then head exprs @@ -691,7 +715,7 @@ parseTextPart quoteStr isTriple handleNewlines startOfString = do -- Use existing escape sequence parsers with better error handling try (char '\\' >> choice [ -- Escaped quotes - handle quote-specific escaping - try (stringS quoteStr >> return quoteStr), + try (stringS quoteStr >> return (T.pack quoteStr)), -- Use existing escape parsers for consistency and better error messages try hexEscape, @@ -707,26 +731,26 @@ parseTextPart quoteStr isTriple handleNewlines startOfString = do -- Handle newlines in triple-quoted strings if handleNewlines - then try (stringS "\n" >> return "\\n") + then try (char '\n' >> return (T.pack "\\n")) else empty, -- Handle quotes in triple-quoted strings if isTriple then try (do -- When we see a quote char, check if it's part of closing sequence - c <- char (head quoteStr) - quotes <- lookAhead $ many (char (head quoteStr)) - let totalQuotes = 1 + length quotes + c <- char quoteChar + quotes <- lookAhead $ takeWhileP (Just "quote") (== quoteChar) + let totalQuotes = 1 + T.length quotes case totalQuotes of -- 1-2 quotes: always consume as content - 1 -> return [c] - 2 -> char (head quoteStr) >> return [c, head quoteStr] + 1 -> return (T.singleton c) + 2 -> char quoteChar >> return (T.cons c (T.singleton quoteChar)) -- 3 quotes exactly: this is the closing sequence, stop 3 -> empty -- 4 quotes: consume 1, leave 3 for closing - 4 -> return [c] + 4 -> return (T.singleton c) -- 5 quotes: consume 2, leave 3 for closing - 5 -> char (head quoteStr) >> return [c, head quoteStr] + 5 -> char quoteChar >> return (T.cons c (T.singleton quoteChar)) -- 6+ quotes: this is an error _ -> do curPos <- getOffset @@ -745,15 +769,18 @@ parseTextPart quoteStr isTriple handleNewlines startOfString = do Just _ -> do pos <- getOffset parseException (Loc startOfString pos) $ MissingClosingQuote quoteStr - Nothing -> do - (loc, c) <- withLoc $ noneOf ("{}" ++ quoteStr ++ "\n") - return [c] + Nothing -> stringTextChunk else - (:[]) <$> noneOf ("{}" ++ quoteStr) + stringTextChunk ] -- Concatenate chunks - return (TextPart (concat chunks)) + return (TextPart (T.concat chunks)) + where + quoteChar = head quoteStr + stringTextChunk = + takeWhile1P (Just "string text") $ \c -> + c /= '{' && c /= '}' && c /= quoteChar && c /= '\\' && c /= '\n' -- | Parse an expression in braces with optional format specifier @@ -762,7 +789,7 @@ exprPart = do openLoc <- getOffset char '{' -- Allow for spaces around the expression - many (char ' ') + skipFormatSpaces -- Check for empty expression or immediate colon closeLoc <- getOffset @@ -776,13 +803,13 @@ exprPart = do parsedExpr <- expr "expression" -- Allow spaces before format specifier or closing brace - many (char ' ') + skipFormatSpaces -- Check for optional format specifier formatInfo <- (char ':' *> formatSpec) <|> do closeBraceLoc <- getOffset char '}' <|> parseException (Loc (openLoc + 1) (closeBraceLoc)) UnclosedInterpolationBrace - return ("s", False, Nothing, Nothing, False, Nothing) + return (T.singleton 's', False, Nothing, Nothing, False, Nothing) let (fmt, isZeroPad, precisionInfo, typeSpecInfo, isCenterAlign, widthInfo) = formatInfo @@ -792,8 +819,8 @@ exprPart = do then do -- Handle center alignment by using str.center() method let widthExpr = case widthInfo of - Just w -> S.Int NoLoc (read w) (T.pack w) - Nothing -> S.Int NoLoc 0 (T.pack "0") + Just w -> S.Int NoLoc (decimalText w) w + Nothing -> S.Int NoLoc 0 (T.singleton '0') -- First convert the expression to a string strExpr = S.Call NoLoc (S.Var NoLoc (S.NoQ (S.name "str"))) (S.PosArg parsedExpr S.PosNil) S.KwdNil -- Then call the center method on the string @@ -812,12 +839,18 @@ exprPart = do return $ ExprPart finalExpr fmt +decimalText :: Text -> Integer +decimalText = T.foldl' (\n c -> n * 10 + fromIntegral (digitToInt c)) 0 + +skipFormatSpaces :: Parser () +skipFormatSpaces = void $ takeWhileP (Just "space") (== ' ') + -- | Parse format specifier after the colon (colon is already consumed) -formatSpec :: Parser (String, Bool, Maybe String, Maybe Char, Bool, Maybe String) -- Returns (format, isZeroPadded, precision, typeSpec, isCenterAlign, width) +formatSpec :: Parser (Text, Bool, Maybe Text, Maybe Char, Bool, Maybe Text) -- Returns (format, isZeroPadded, precision, typeSpec, isCenterAlign, width) formatSpec = do specLoc <- getOffset -- Allow spaces at the beginning - many (char ' ') + skipFormatSpaces -- Check if there's any content before trying to parse beforeParseLoc <- getOffset @@ -875,13 +908,13 @@ formatSpec = do zeroPad <- optional $ char '0' -- Optional width - width <- optional $ some digitChar + width <- optional digitsText -- Optional precision precision <- optional $ do char '.' digitLoc <- getOffset - digits <- optional $ some digitChar + digits <- optional digitsText case digits of Nothing -> parseException (Loc digitLoc digitLoc) MissingFormatPrecisionDigits Just d -> return d @@ -891,7 +924,7 @@ formatSpec = do typeSpec <- optional (oneOf "fdeEgGnoxX%bos" "type specifier") -- Allow spaces before closing brace - many (char ' ') + skipFormatSpaces -- Check for any remaining invalid characters invalidCharLoc <- getOffset @@ -923,137 +956,257 @@ formatSpec = do let fmt = case (precision, typeSpec) of -- Float with precision and width (e.g., 10.2f becomes %10.2f for printf) (Just p, Just 'f') -> case (zeroPad, width) of - (Just '0', Just w) -> "0" ++ w ++ "." ++ p ++ "f" -- Zero-padded float - (_, Just w) -> w ++ "." ++ p ++ "f" -- Regular float with width - (_, Nothing) -> "." ++ p ++ "f" -- Just precision, no width + (Just '0', Just w) -> T.concat [T.singleton '0', w, T.singleton '.', p, T.singleton 'f'] -- Zero-padded float + (_, Just w) -> T.concat [w, T.singleton '.', p, T.singleton 'f'] -- Regular float with width + (_, Nothing) -> T.concat [T.singleton '.', p, T.singleton 'f'] -- Just precision, no width -- Default to float if precision specified but no type (Just p, _) -> case (zeroPad, width) of - (Just '0', Just w) -> "0" ++ w ++ "." ++ p ++ "f" - (_, Just w) -> w ++ "." ++ p ++ "f" - (_, Nothing) -> "." ++ p ++ "f" + (Just '0', Just w) -> T.concat [T.singleton '0', w, T.singleton '.', p, T.singleton 'f'] + (_, Just w) -> T.concat [w, T.singleton '.', p, T.singleton 'f'] + (_, Nothing) -> T.concat [T.singleton '.', p, T.singleton 'f'] -- Float without precision - (Nothing, Just 'f') -> "f" + (Nothing, Just 'f') -> T.singleton 'f' -- Other formats based on alignment and width (Nothing, _) -> case (zeroPad, align, width) of -- Zero padding with width (for numbers) - use integer format - (Just '0', _, Just w) -> "0" ++ w ++ "d" + (Just '0', _, Just w) -> T.concat [T.singleton '0', w, T.singleton 'd'] -- Left-aligned with width - (_, Just '<', Just w) -> "-" ++ w ++ "s" + (_, Just '<', Just w) -> T.concat [T.singleton '-', w, T.singleton 's'] -- Right-aligned with width - (_, Just '>', Just w) -> w ++ "s" + (_, Just '>', Just w) -> T.snoc w 's' -- Center-aligned with width - (_, Just '^', Just w) -> "s" -- Width handled separately in expr processing + (_, Just '^', Just w) -> T.singleton 's' -- Width handled separately in expr processing -- Just width, no alignment - (_, Nothing, Just w) -> w ++ "s" + (_, Nothing, Just w) -> T.snoc w 's' -- Default case - _ -> "s" + _ -> T.singleton 's' return (fmt, isZeroPadding, precision, typeSpec, isCenterAlign, width) + where + digitsText = takeWhile1P (Just "digit") isDigit -- Split string when hex escape is followed by hex digit (to prevent C compiler issues) -- Only splits if the string contains actual hex escapes (not literal \x patterns) -hexSplitString :: String -> [String] -hexSplitString "" = [""] -hexSplitString s - | hasActualHexEscapes s = filter (not . null) $ reverse $ map reverse $ process s [] [] +hexSplitText :: Text -> [Text] +hexSplitText s + | T.null s = [T.empty] + | hasActualHexEscapes s = filter (not . T.null) $ reverse $ process s T.empty [] | otherwise = [s] -- No splitting needed for raw strings or strings without hex escapes where -- Check if string has actual hex escapes (single backslash followed by x and hex digits) -- Raw strings produce \\x patterns (double backslashes) which should NOT be split - hasActualHexEscapes [] = False - hasActualHexEscapes ('\\':'\\':'x':rest) = hasActualHexEscapes rest -- Skip \\x pattern (raw string) - hasActualHexEscapes ('\\':'x':h1:h2:rest) - | isHex h1 && isHex h2 = True - | otherwise = hasActualHexEscapes rest - hasActualHexEscapes (_:rest) = hasActualHexEscapes rest - - process [] acc chunks = acc : chunks - process ('\\':'x':h1:h2:rest) acc chunks - | isHex h1 && isHex h2 && (not (null rest) && isHex (head rest)) = - -- Next char is hex, split here - complete current chunk with hex escape - let completedChunk = h2:h1:'x':'\\':acc - in process rest [] (completedChunk : chunks) - | isHex h1 && isHex h2 = - -- Valid hex escape, continue accumulating - process rest (h2:h1:'x':'\\':acc) chunks - | otherwise = - -- Invalid hex escape, keep as-is - process (h1:h2:rest) ('x':'\\':acc) chunks - process (c:cs) acc chunks = process cs (c:acc) chunks + hasActualHexEscapes t = + case T.uncons t of + Nothing -> False + Just ('\\', rest) -> + case T.uncons rest of + Just ('\\', rest') -> + case T.uncons rest' of + Just ('x', rest'') -> hasActualHexEscapes rest'' -- Skip \\x pattern (raw string) + _ -> hasActualHexEscapes rest + Just ('x', rest') -> + case T.uncons rest' of + Just (h1, rest'') -> + case T.uncons rest'' of + Just (h2, _) | isHex h1 && isHex h2 -> True + _ -> hasActualHexEscapes rest' + _ -> hasActualHexEscapes rest' + _ -> hasActualHexEscapes rest + Just (_, rest) -> hasActualHexEscapes rest + + process t acc chunks = + case T.uncons t of + Nothing -> T.reverse acc : chunks + Just ('\\', rest) -> + case T.uncons rest of + Just ('x', rest') -> + case T.uncons rest' of + Just (h1, rest'') -> + case T.uncons rest'' of + Just (h2, rest''') | isHex h1 && isHex h2 -> + let acc' = h2 `T.cons` h1 `T.cons` 'x' `T.cons` '\\' `T.cons` acc + in case T.uncons rest''' of + Just (c, _) | isHex c -> process rest''' T.empty (T.reverse acc' : chunks) + _ -> process rest''' acc' chunks + _ -> process rest ('\\' `T.cons` acc) chunks + _ -> process rest ('\\' `T.cons` acc) chunks + _ -> process rest ('\\' `T.cons` acc) chunks + Just (c, rest) -> process rest (c `T.cons` acc) chunks + isHex :: Char -> Bool isHex c = c `elem` ("0123456789abcdefABCDEF" :: String) -newlineEscape = "" <$ newline -singleCharEscape = (\c -> '\\':c:[]) <$> (oneOf ("\'\"\\abfnrtv")) +newlineEscape = T.empty <$ newline +singleCharEscape = (\c -> T.cons '\\' (T.singleton c)) <$> (oneOf ("\'\"\\abfnrtv")) hexEscape = do char 'x' - (loc,cs) <- withLoc (count' 0 2 hexDigitChar) - if length cs == 2 - then return ("\\x" ++ cs) - else parseException loc $ IncompleteHexEscape cs + (loc,cs) <- withLoc (countTextBy 0 2 "hex digit" isHexDigit) + if T.length cs == 2 + then return (T.cons '\\' (T.cons 'x' cs)) + else parseException loc $ IncompleteHexEscape (T.unpack cs) octEscape = do - (loc,cs) <- withLoc (count' 1 3 octDigitChar) - if length cs == 3 && head cs > '3' + (loc,cs) <- withLoc (countTextBy 1 3 "octal digit" isOctDigit) + if T.length cs == 3 && T.head cs > '3' then parseException loc OctalEscapeOutOfRange - else return ("\\" ++ cs) + else return (T.cons '\\' cs) univ1Escape = do char 'u' - (loc,cs) <- withLoc (count' 0 4 hexDigitChar) - if length cs < 4 - then parseException loc $ IncompleteUnicodeEscape 4 (length cs) - else return ("\\u" ++ cs) + (loc,cs) <- withLoc (countTextBy 0 4 "hex digit" isHexDigit) + if T.length cs < 4 + then parseException loc $ IncompleteUnicodeEscape 4 (T.length cs) + else return (T.cons '\\' (T.cons 'u' cs)) univ2Escape = do char 'U' - (loc,cs) <- withLoc (count' 0 8 hexDigitChar) - if length cs < 8 - then parseException loc $ IncompleteUnicodeEscape 8 (length cs) - else return ("\\U" ++ cs) + (loc,cs) <- withLoc (countTextBy 0 8 "hex digit" isHexDigit) + if T.length cs < 8 + then parseException loc $ IncompleteUnicodeEscape 8 (T.length cs) + else return (T.cons '\\' (T.cons 'U' cs)) + +countTextBy :: Int -> Int -> String -> (Char -> Bool) -> Parser Text +countTextBy minCount maxCount label f = do + input <- getInput + let cs = T.take maxCount (T.takeWhile f input) + n = T.length cs + if n < minCount + then empty + else if n == 0 + then return T.empty + else takeP (Just label) n asciiC = do (loc,c) <- withLoc anySingle if c == '\n' then parseException loc (MissingClosingQuote "\"") else if isAscii c - then return [c] + then return (T.singleton c) else parseException loc NonAsciiInBytesLiteral anyC = do (loc,c) <- withLoc anySingle if c == '\n' then parseException loc (MissingClosingQuote "\"") - else return [c] + else return (T.singleton c) unknownEscape charParser = do (loc,c) <- withLoc charParser parseException loc UnknownEscapeSequence -plainLiteral charParser prefix tailEscapes = stringTempl "\"\"\"" longItem esc prefix - <|> stringTempl "'''" longItem esc prefix - <|> stringTempl "\"" charParser esc prefix - <|> stringTempl "'" charParser esc prefix - where longItem = ("\\n" <$ newline) <|> charParser -- newlines allowed in triple-quoted literals - esc = newlineEscape <|> singleCharEscape <|> hexEscape <|> octEscape <|> tailEscapes +plainLiteral :: Bool -> String -> Parser Text -> Parser [Text] +plainLiteral bytes prefix tailEscapes = plainTempl "\"\"\"" + <|> plainTempl "'''" + <|> plainTempl "\"" + <|> plainTempl "'" + where + esc = newlineEscape <|> singleCharEscape <|> hexEscape <|> octEscape <|> tailEscapes + + plainTempl q = do + startLoc <- getOffset + _ <- stringS (prefix++q) + content <- manyTill (plainItem (startLoc + length prefix) q) + (stringS q closingQuoteError startLoc q) + currSC + return $ hexSplitText (T.concat content) + + plainItem startQuoteOffset q = + (char '\\' *> esc) + <|> newlineItem startQuoteOffset q + <|> quoteItem q + <|> textChunk q + <|> nonAsciiByte + + newlineItem startQuoteOffset q + | length q == 3 = T.pack "\\n" <$ newline + | otherwise = do + pos <- getOffset + _ <- lookAhead (char '\n') + parseException (Loc startQuoteOffset pos) (MissingClosingQuote q) + + quoteItem q + | length q == 3 = T.singleton <$> char (head q) + | otherwise = empty + + textChunk q = + takeWhile1P (Just "string text") $ \c -> + c /= '\\' && c /= head q && c /= '\n' && (not bytes || isAscii c) + + nonAsciiByte + | bytes = do + off <- getOffset + c <- lookAhead anySingle + if isAscii c + then empty + else anySingle *> parseException (Loc off (off + 1)) NonAsciiInBytesLiteral + | otherwise = empty -plainbytesLiteral = plainLiteral asciiC "b" (unknownEscape asciiC) + closingQuoteError startLoc quote + | quote `elem` ["\"\"\"", "'''"] = "closing triple quote " ++ quote ++ " for string starting at position " ++ show startLoc + | otherwise = "closing quote " ++ quote ++ " for string" + +plainbytesLiteral = plainLiteral True "b" (unknownEscape asciiC) -plainstrLiteral = plainLiteral anyC "" ( univ1Escape <|> univ2Escape <|> unknownEscape anyC) +plainstrLiteral = plainLiteral False "" ( univ1Escape <|> univ2Escape <|> unknownEscape anyC) +rawLiteral :: Parser Text -> String -> Parser [Text] rawLiteral charParser prefix = stringTempl "\"\"\"" longItem esc prefix <|> stringTempl "'''" longItem esc prefix <|> stringTempl "\"" charParser esc prefix <|> stringTempl "'" charParser esc prefix - where longItem = ("\\n" <$ newline) <|> charParser + where longItem = (T.pack "\\n" <$ newline) <|> charParser esc = newlineEscapeRaw <|> singleCharEscapeRaw <|> generalEscapeRaw - newlineEscapeRaw = "\\\\\\n" <$ newline - singleCharEscapeRaw = (\c -> "\\\\\\" ++ [c]) <$> (oneOf ("\'\"")) - generalEscapeRaw = return "\\\\" + newlineEscapeRaw = T.pack "\\\\\\n" <$ newline + singleCharEscapeRaw = (\c -> T.pack ['\\', '\\', '\\', c]) <$> (oneOf ("\'\"")) + generalEscapeRaw = return (T.pack "\\\\") rawbytesLiteral = rawLiteral asciiC "rb" -rawstrLiteral = rawLiteral ((:[]) <$> anySingle) "r" +rawstrLiteral = rawstrTempl "\"\"\"" + <|> rawstrTempl "'''" + <|> rawstrTempl "\"" + <|> rawstrTempl "'" -stringTempl :: String -> Parser String -> Parser String -> String -> Parser [String] +rawstrTempl :: String -> Parser [Text] +rawstrTempl q = do + startLoc <- getOffset + _ <- stringS ("r"++q) + content <- manyTill (rawItem startLoc) (stringS q closingQuoteError startLoc q) + currSC + return $ hexSplitText (T.concat content) + where + quoteChar = head q + isTriple = length q == 3 + + rawItem startLoc = + rawEscape + <|> newlineItem startLoc + <|> quoteItem + <|> rawTextChunk + + rawEscape = char '\\' *> ( + T.pack "\\\\\\n" <$ newline + <|> ((\c -> T.pack ['\\', '\\', '\\', c]) <$> oneOf ("\'\"")) + <|> return (T.pack "\\\\")) + + newlineItem startLoc + | isTriple = T.pack "\\n" <$ newline + | otherwise = do + pos <- getOffset + _ <- lookAhead (char '\n') + parseException (Loc (startLoc + 1) pos) (MissingClosingQuote q) + + quoteItem + | isTriple = T.singleton <$> char quoteChar + | otherwise = empty + + rawTextChunk = + takeWhile1P (Just "raw string text") $ \c -> + c /= '\\' && c /= quoteChar && c /= '\n' + + closingQuoteError start quote + | quote `elem` ["\"\"\"", "'''"] = "closing triple quote " ++ quote ++ " for string starting at position " ++ show start + | otherwise = "closing quote " ++ quote + +stringTempl :: String -> Parser Text -> Parser Text -> String -> Parser [Text] stringTempl q single esc prefix = do startLoc <- getOffset _ <- stringS (prefix++q) @@ -1071,13 +1224,13 @@ stringTempl q single esc prefix = do else single content <- manyTillEsc guardedSingle esc (stringS q closingQuoteError startLoc q) currSC -- Apply lexeme whitespace consumption - return $ hexSplitString . concat $ content + return $ hexSplitText (T.concat content) where closingQuoteError startLoc quote | quote `elem` ["\"\"\"", "'''"] = "closing triple quote " ++ quote ++ " for string starting at position " ++ show startLoc | otherwise = "closing quote " ++ quote ++ " for string" -manyTillEsc, someTillEsc :: Parser String -> Parser String -> Parser a -> Parser [String] +manyTillEsc, someTillEsc :: Parser Text -> Parser Text -> Parser a -> Parser [Text] manyTillEsc p esc end = (const [] <$> end) <|> (someTillEsc p esc end) someTillEsc p esc end = do @@ -1090,7 +1243,7 @@ someTillEsc p esc end = do -- Reserved words, other symbols and names ---------------------------------------------------------- rword :: String -> Parser () -rword w = (lexeme . try) (stringS w *> notFollowedBy (alphaNumChar <|> char '_')) +rword w = (lexeme . try) (stringS_ w *> notFollowedBy (alphaNumChar <|> char '_')) comma = symbol "," "comma" colon = symbol ":" @@ -1107,20 +1260,23 @@ vbar = symbol "|" -- Parser for operator that is a prefix of another operator -- Slightly hackish; depends on the (presently true) fact that chars in argument to oneOf are -- the only chars that can follow directly after the prefix operator in a longer operator name. -opPref :: String -> Parser Text -opPref op = (lexeme . try) (stringS op <* notFollowedBy (oneOf "<>=/*")) +opPref :: String -> Parser () +opPref [c] = (lexeme . try) (void (char c) <* notFollowedBy (oneOf "<>=/*")) +opPref op = (lexeme . try) (stringS_ op <* notFollowedBy (oneOf "<>=/*")) singleStar = (lexeme . try) (char '*' <* notFollowedBy (char '*')) identifier :: Parser Text identifier = (lexeme . try) $ do off <- getOffset - c <- satisfy (\c -> isAlpha c || c == '_') "identifier" - cs <- hidden (takeWhileP Nothing (\c -> isAlphaNum c || c == '_')) - let x = T.cons c cs + lookAhead (satisfy identifierStart "identifier") + x <- hidden (takeWhile1P (Just "identifier") identifierChar) if S.isKeywordText x then parseError (TrivialError off (Just (Tokens (N.fromList (T.unpack x)))) (Set.fromList [Label (N.fromList "identifier")])) else return x + where + identifierStart c = isAlpha c || c == '_' + identifierChar c = isAlphaNum c || c == '_' name, escname, tvarname :: Parser S.Name name = do off <- getOffset @@ -1129,7 +1285,7 @@ name = do off <- getOffset then parseError (FancyError off (Set.fromList [ErrorCustom (TypeVariableNameError (T.unpack x))])) else return $ S.Name (Loc off (off + T.length x)) x -escname = name <|> addLoc (S.name . head <$> plainstrLiteral) -- Assumes an escname cannot contain hex escape sequences +escname = name <|> addLoc (S.Name NoLoc . head <$> plainstrLiteral) -- Assumes an escname cannot contain hex escape sequences paramName :: Parser S.Name paramName = name <|> do @@ -1166,6 +1322,55 @@ qual_name = do -- recognizers for numbers are used directly in function atom below. +number :: Parser S.Expr +number = basedInteger <|> try decimalInteger <|> try imaginary <|> try floating + where + basedInteger = + (\(i,s) -> S.Int NoLoc i s) <$> lexemeWithText basedIntegerValue + + decimalInteger = + (\(i,s) -> S.Int NoLoc i s) <$> lexemeWithText decimalIntegerValue + + floating = + (\(f,s) -> S.Float NoLoc f s) <$> lexemeWithText L.float + + imaginary = + (\(f,s) -> S.Imaginary NoLoc f s) <$> lexemeWithText (L.float <* stringS "j") + + basedIntegerValue = do + input <- getInput + case T.uncons input of + Just ('0', rest) -> + case T.uncons rest of + Just ('o', _) -> stringS_ "0o" *> (integerText 8 <$> takeWhile1P (Just "octal digit") isOctDigit) + Just ('x', _) -> stringS_ "0x" *> (integerText 16 <$> takeWhile1P (Just "hexadecimal digit") isHexDigit) + _ -> empty + _ -> empty + + decimalIntegerValue = do + ds <- takeWhile1P (Just "decimal digit") isDigit + rest <- getInput + if startsFloatSuffix rest then empty else return (integerText 10 ds) + + startsFloatSuffix rest = + case T.uncons rest of + Just ('.', rest') -> + case T.uncons rest' of + Just (c, _) -> isDigit c + Nothing -> False + Just (e, rest') | e == 'e' || e == 'E' -> + case T.uncons rest' of + Just (c, _) | isDigit c -> True + Just (s, rest'') | s == '+' || s == '-' -> + case T.uncons rest'' of + Just (c, _) -> isDigit c + Nothing -> False + _ -> False + _ -> False + + integerText base = + T.foldl' (\n c -> n * base + fromIntegral (digitToInt c)) 0 + --- Helper functions for parenthesised forms ----------------------------------- parens, brackets, braces :: Parser a -> Parser a @@ -1180,7 +1385,7 @@ braces p = withCtx PAR (L.symbol sc2 (T.pack "{") *> p <* (char '}' "closing module_docstring :: Parser Text module_docstring = do S.Strings _ ss <- addLoc docstringLiteral - return (T.pack (unescapeString (concatMap T.unpack ss))) + return (unescapeText (T.concat ss)) file_input :: Parser ([S.Import], Maybe Text, S.Suite) file_input = sc2 *> do @@ -2139,18 +2344,23 @@ docstringSmallStmt :: Parser (Maybe Text, S.Suite) docstringSmallStmt = do S.Strings _ ss <- addLoc docstringLiteral _ <- lookAhead (void (char ';') <|> void eol <|> eof) - return (Just (T.pack (unescapeString (concatMap T.unpack ss))), []) - - -unescapeString :: String -> String -unescapeString [] = [] -unescapeString ('\\':'n':xs) = '\n' : unescapeString xs -unescapeString ('\\':'t':xs) = '\t' : unescapeString xs -unescapeString ('\\':'r':xs) = '\r' : unescapeString xs -unescapeString ('\\':'\\':xs) = '\\' : unescapeString xs -unescapeString ('\\':'"':xs) = '"' : unescapeString xs -unescapeString ('\\':'\'':xs) = '\'' : unescapeString xs -unescapeString (x:xs) = x : unescapeString xs + return (Just (unescapeText (T.concat ss)), []) + + +unescapeText :: Text -> Text +unescapeText s = + case T.uncons s of + Nothing -> T.empty + Just ('\\', xs) -> + case T.uncons xs of + Just ('n', rest) -> '\n' `T.cons` unescapeText rest + Just ('t', rest) -> '\t' `T.cons` unescapeText rest + Just ('r', rest) -> '\r' `T.cons` unescapeText rest + Just ('\\', rest) -> '\\' `T.cons` unescapeText rest + Just ('"', rest) -> '"' `T.cons` unescapeText rest + Just ('\'', rest) -> '\'' `T.cons` unescapeText rest + _ -> '\\' `T.cons` unescapeText xs + Just (x, xs) -> x `T.cons` unescapeText xs ------------------------------------------------------------------------------------------------ --- Expressions ---------------------------------------------------------------- @@ -2338,11 +2548,7 @@ atom_expr = do return $ maybe (S.Dict NoLoc []) id mbe) <|> var <|> isinstance - <|> (try ((\f -> S.Imaginary NoLoc f (T.pack (show f ++ "j"))) <$> lexeme (L.float <* stringS "j"))) - <|> (try ((\f -> S.Float NoLoc f (T.pack (show f))) <$> lexeme L.float)) - <|> (\i -> S.Int NoLoc i (T.pack ("0o"++showOct i ""))) <$> (stringS "0o" *> lexeme L.octal) - <|> (\i -> S.Int NoLoc i (T.pack ("0x"++showHex i ""))) <$> (stringS "0x" *> lexeme L.hexadecimal) - <|> (\i -> S.Int NoLoc i (T.pack (show i))) <$> (lexeme L.decimal) + <|> number <|> (S.Ellipsis <$> rwordLoc "...") <|> (S.None <$> rwordLoc "None") <|> (S.NotImplemented <$> rwordLoc "NotImplemented") @@ -2411,7 +2617,7 @@ atom_expr = do return (\a -> maybe (S.DotI (loc a `upto` l) a i) (const $ S.RestI (loc a `upto` l) a i) mb) strdot = do (l,ss) <- withLoc plainstrLiteral - return (\a -> S.Dot (loc a `upto` l) a (S.Name l (T.pack (head ss)))) + return (\a -> S.Dot (loc a `upto` l) a (S.Name l (head ss))) -- Parse slice or index: try slice first since it can start with expr sliceOrIndex = try sliceParser <|> indexParser From 0acf7b6e217d393b2ddadbdf72c871681a45afb2 Mon Sep 17 00:00:00 2001 From: Kristian Larsson Date: Wed, 20 May 2026 23:16:31 +0200 Subject: [PATCH 6/6] Scan top-level chunks in bulk The top-level chunk scanner still advanced through ordinary source, comments, and string text one character at a time. Batch those runs with Text operations while keeping newline, delimiter, interpolation, and escape handling on the existing state-machine paths. The scanner still preserves previous-character state, line-start tracking, continuations, and chunk boundaries, while avoiding per-character work for large ordinary regions of generated modules. --- compiler/lib/src/Acton/Parser.hs | 123 +++++++++++++++++++++++++++---- 1 file changed, 108 insertions(+), 15 deletions(-) diff --git a/compiler/lib/src/Acton/Parser.hs b/compiler/lib/src/Acton/Parser.hs index 03925a538..c9c46a40a 100644 --- a/compiler/lib/src/Acton/Parser.hs +++ b/compiler/lib/src/Acton/Parser.hs @@ -1555,6 +1555,9 @@ scanTopLevelChunks src start emit let depth' = max 0 (scanDepth st - 1) (_, rest, st') = consumeMany True 1 i xs st { scanDepth = depth' } in go (i + 1) rest st' + | Just n <- codeRunLength xs -> + let (rest, st') = consumeCodeRun n xs st + in go (i + n) rest st' | otherwise -> let (_, rest, st') = consumeMany True 1 i xs st in go (i + 1) rest st' @@ -1576,10 +1579,10 @@ scanTopLevelChunks src start emit _ -> 1 (_, xs', st') = consumeMany False n i xs st in go (i + n) xs' st' - | scanInterpolate mode && startsWith "{{" xs -> + | scanInterpolate mode && startsWith2 '{' '{' xs -> let (_, xs', st') = consumeMany False 2 i xs st in go (i + 2) xs' st' - | scanInterpolate mode && startsWith "}}" xs -> + | scanInterpolate mode && startsWith2 '}' '}' xs -> let (_, xs', st') = consumeMany False 2 i xs st in go (i + 2) xs' st' | scanInterpolate mode && c == '{' -> @@ -1593,6 +1596,9 @@ scanTopLevelChunks src start emit let n = if scanTriple mode then 3 else 1 (_, xs', st') = consumeMany False n i xs st { scanModes = rest } in go (i + n) xs' st' + | Just n <- stringTextRunLength mode xs -> + let (xs', st') = consumeStringTextRun n xs st + in go (i + n) xs' st' | otherwise -> let (_, xs', st') = consumeMany False 1 i xs st in go (i + 1) xs' st' @@ -1624,7 +1630,7 @@ scanTopLevelChunks src start emit case T.uncons xs of Just (q, _) | q == '"' || q == '\'' -> - let triple = startsWith [q, q, q] xs + let triple = startsWith3 q q q xs raw = scanPrev1 st == Just 'r' || (scanPrev2 st == Just 'r' && scanPrev1 st == Just 'b') bytes = scanPrev1 st == Just 'b' || @@ -1635,10 +1641,12 @@ scanTopLevelChunks src start emit _ -> Nothing closesString xs mode - | scanTriple mode = startsWith (replicate 3 (scanQuote mode)) xs + | scanTriple mode = startsWith3 q q q xs | otherwise = case T.uncons xs of - Just (c, _) -> c == scanQuote mode + Just (c, _) -> c == q Nothing -> False + where + q = scanQuote mode tripleInterpolatedQuoteText xs mode | scanTriple mode && scanInterpolate mode = @@ -1650,18 +1658,103 @@ scanTopLevelChunks src start emit quoteRunLength q = T.length . T.takeWhile (== q) - startsWith prefix xs = T.pack prefix `T.isPrefixOf` xs + startsWith2 a b xs = + case T.uncons xs of + Just (c1, rest1) | c1 == a -> + case T.uncons rest1 of + Just (c2, _) -> c2 == b + Nothing -> False + _ -> False - skipComment i xs st = + startsWith3 a b c xs = case T.uncons xs of - Nothing -> go i T.empty st - Just (c, _) - | c == '\n' -> - let (_, xs', st') = consumeMany False 1 i xs st - in go (i + 1) xs' st' - | otherwise -> - let (_, xs', st') = consumeMany False 1 i xs st - in skipComment (i + 1) xs' st' + Just (c1, rest1) | c1 == a -> + case T.uncons rest1 of + Just (c2, rest2) | c2 == b -> + case T.uncons rest2 of + Just (c3, _) -> c3 == c + Nothing -> False + _ -> False + _ -> False + + codeRunLength xs = + let n = T.length (T.takeWhile isCodeRunChar xs) + in if n == 0 then Nothing else Just n + + stringTextRunLength mode xs = + let n = T.length (T.takeWhile (isStringTextRunChar mode) xs) + in if n == 0 then Nothing else Just n + + isCodeRunChar c = + c /= '#' && c /= '"' && c /= '\'' && c /= '\n' && c /= '\\' && + not (c `elem` ("()[]{}" :: String)) + + isStringTextRunChar mode c = + c /= '\\' && c /= '\n' && c /= scanQuote mode && + (not (scanInterpolate mode) || (c /= '{' && c /= '}')) + + consumeCodeRun n xs st = + let (run, rest) = T.splitAt n xs + in (rest, advanceCodeRun run st) + + consumeStringTextRun n xs st = + let (run, rest) = T.splitAt n xs + in (rest, advanceStringTextRun run st) + + advanceCodeRun run st = + case T.unsnoc run of + Nothing -> st + Just (front, lastC) -> + let prev2' = case T.unsnoc front of + Just (_, c) -> Just c + Nothing -> scanPrev1 st + significant = T.any (\c -> c /= ' ' && c /= '\t' && c /= '\r') run + in st + { scanPrev2 = prev2' + , scanPrev1 = Just lastC + , scanAtLineStart = False + , scanContinued = False + , scanBackslash = if significant then False else scanBackslash st + } + + advanceStringTextRun run st = + case T.unsnoc run of + Nothing -> st + Just (front, lastC) -> + let prev2' = case T.unsnoc front of + Just (_, c) -> Just c + Nothing -> scanPrev1 st + in st + { scanPrev2 = prev2' + , scanPrev1 = Just lastC + , scanAtLineStart = False + , scanContinued = False + } + + skipComment i xs st = + let (comment, rest) = T.break (== '\n') xs + n = T.length comment + st' = advanceCommentRun comment st + i' = i + n + in case T.uncons rest of + Just ('\n', _) -> + let (_, xs', st'') = consumeMany False 1 i' rest st' + in go (i' + 1) xs' st'' + _ -> go i' rest st' + + advanceCommentRun run st = + case T.unsnoc run of + Nothing -> st + Just (front, lastC) -> + let prev2' = case T.unsnoc front of + Just (_, c) -> Just c + Nothing -> scanPrev1 st + in st + { scanPrev2 = prev2' + , scanPrev1 = Just lastC + , scanAtLineStart = False + , scanContinued = False + } consumeMany _ 0 i xs st = (i, xs, st) consumeMany track n i xs st =