futhark 0.21.7 → 0.21.8

raw patch · 42 files changed

+1104/−700 lines, 42 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• docs/man/futhark-literate.rst +13/−2
• futhark.cabal +3/−1
• src/Futhark/Analysis/Alias.hs +6/−1
• src/Futhark/Analysis/Metrics.hs +1/−1
• src/Futhark/CLI/Bench.hs +19/−22
• src/Futhark/CLI/Dataset.hs +1/−1
• src/Futhark/CLI/Dev.hs +5/−4
• src/Futhark/CLI/Doc.hs +2/−2
• src/Futhark/CLI/Literate.hs +73/−21
• src/Futhark/CLI/REPL.hs +11/−11
• src/Futhark/CLI/Run.hs +3/−3
• src/Futhark/CodeGen/Backends/MulticoreC.hs +4/−0
• src/Futhark/CodeGen/ImpGen/GPU/SegHist.hs +2/−3
• src/Futhark/CodeGen/ImpGen/Multicore.hs +1/−0
• src/Futhark/Compiler.hs +44/−8
• src/Futhark/Compiler/Program.hs +77/−53
• src/Futhark/Construct.hs +57/−10
• src/Futhark/IR/Aliases.hs +46/−27
• src/Futhark/IR/GPU/Simplify.hs +1/−16
• src/Futhark/IR/SOACS/SOAC.hs +4/−6
• src/Futhark/IR/SOACS/Simplify.hs +11/−0
• src/Futhark/IR/Syntax/Core.hs +7/−0
• src/Futhark/Internalise/Exps.hs +4/−4
• src/Futhark/Optimise/Simplify/Engine.hs +10/−2
• src/Futhark/Optimise/Simplify/Rep.hs +3/−5
• src/Futhark/Test.hs +2/−2
• src/Language/Futhark/Parser.hs +36/−7
• src/Language/Futhark/Parser/Lexer.x +33/−286
• src/Language/Futhark/Parser/Lexer/Tokens.hs +283/−0
• src/Language/Futhark/Parser/Lexer/Wrapper.hs +137/−0
• src/Language/Futhark/Parser/Monad.hs +54/−47
• src/Language/Futhark/Parser/Parser.y +86/−98
• src/Language/Futhark/Syntax.hs +1/−0
• src/Language/Futhark/TypeChecker.hs +4/−4
• src/Language/Futhark/TypeChecker/Modules.hs +29/−34
• src/Language/Futhark/TypeChecker/Monad.hs +3/−3
• src/Language/Futhark/TypeChecker/Terms.hs +2/−2
• src/Language/Futhark/TypeChecker/Terms/Monad.hs +7/−7
• src/Language/Futhark/TypeChecker/Terms/Pat.hs +9/−1
• src/Language/Futhark/TypeChecker/Unify.hs +4/−4
• src/Language/Futhark/Warnings.hs +5/−0
• unittests/Language/Futhark/SyntaxTests.hs +1/−2

@@ -34,6 +34,10 @@ Image directives and builtin functions shell out to ``convert`` (from ImageMagick).  Video generation uses ``ffmpeg``. +For an input file ``foo.fut``, all generated files will be in a+directory named ``foo-img``.  A ``file`` parameter passed to a+directive may not contain a directory component or spaces.+ OPTIONS ======= @@ -118,6 +122,8 @@    * ``format: <webm|gif>`` +  * ``file: <name>``.  Make sure to provide a proper extension.+   ``e`` must be one of the following:    * A 3D array where the 2D elements is of a type acceptable to@@ -138,9 +144,14 @@   ``>``), but do not show the directive itself in the output, only its   result. -* ``> :img e``+* ``> :img e[; parameters...]`` -  Visualises ``e``. The following types are supported:+  Visualises ``e``.  The optional parameters are lines of+  the form *key: value*:++  * ``file: NAME``.  Make sure to use a proper extension.++  The expression ``e`` must have one of the following types:    * ``[][]i32`` and ``[][]u32`` 

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:           futhark-version:        0.21.7+version:        0.21.8 synopsis:       An optimising compiler for a functional, array-oriented language.  description:    Futhark is a small programming language designed to be compiled to@@ -285,6 +285,8 @@       Language.Futhark.Interpreter       Language.Futhark.Parser       Language.Futhark.Parser.Monad+      Language.Futhark.Parser.Lexer.Tokens+      Language.Futhark.Parser.Lexer.Wrapper       Language.Futhark.Prelude       Language.Futhark.Pretty       Language.Futhark.Prop

@@ -32,6 +32,7 @@ aliasAnalysis (Prog consts funs) =   Prog (fst (analyseStms mempty consts)) (map analyseFun funs) +-- | Perform alias analysis on function. analyseFun ::   (ASTRep rep, CanBeAliased (Op rep)) =>   FunDef rep ->@@ -41,6 +42,7 @@   where     body' = analyseBody mempty body +-- | Perform alias analysis on Body. analyseBody ::   ( ASTRep rep,     CanBeAliased (Op rep)@@ -52,6 +54,7 @@   let (stms', _atable') = analyseStms atable stms    in mkAliasedBody rep stms' result +-- | Perform alias analysis on statements. analyseStms ::   (ASTRep rep, CanBeAliased (Op rep)) =>   AliasTable ->@@ -72,10 +75,11 @@   Stm (Aliases rep) analyseStm aliases (Let pat (StmAux cs attrs dec) e) =   let e' = analyseExp aliases e-      pat' = addAliasesToPat pat e'+      pat' = mkAliasedPat pat e'       rep' = (AliasDec $ consumedInExp e', dec)    in Let pat' (StmAux cs attrs rep') e' +-- | Perform alias analysis on expression. analyseExp ::   (ASTRep rep, CanBeAliased (Op rep)) =>   AliasTable ->@@ -114,6 +118,7 @@           mapOnOp = return . addOpAliases aliases         } +-- | Perform alias analysis on lambda. analyseLambda ::   (ASTRep rep, CanBeAliased (Op rep)) =>   AliasTable ->

@@ -123,7 +123,7 @@ basicOpMetrics BinOp {} = seen "BinOp" basicOpMetrics UnOp {} = seen "UnOp" basicOpMetrics ConvOp {} = seen "ConvOp"-basicOpMetrics CmpOp {} = seen "ConvOp"+basicOpMetrics CmpOp {} = seen "CmpOp" basicOpMetrics Assert {} = seen "Assert" basicOpMetrics Index {} = seen "Index" basicOpMetrics Update {} = seen "Update"

@@ -100,7 +100,7 @@       (sortBy (comparing fst) compiled_benchmarks)   let results = concat $ catMaybes maybe_results   case optJSON opts of-    Nothing -> return ()+    Nothing -> pure ()     Just file -> LBS.writeFile file $ encodeBenchResults results   when (any isNothing maybe_results || anyFailed results) exitFailure   where@@ -122,8 +122,8 @@  compileOptions :: BenchOptions -> IO CompileOptions compileOptions opts = do-  futhark <- maybe getExecutablePath return $ optFuthark opts-  return $+  futhark <- maybe getExecutablePath pure $ optFuthark opts+  pure $     CompileOptions       { compFuthark = futhark,         compBackend = optBackend opts,@@ -145,10 +145,10 @@           then do             exists <- doesFileExist $ binaryName program             if exists-              then return $ Right (program, cases)+              then pure $ Right (program, cases)               else do                 putStrLn $ binaryName program ++ " does not exist, but --skip-compilation passed."-                return $ Left FailedToCompile+                pure $ Left FailedToCompile           else do             putStr $ "Compiling " ++ program ++ "...\n" @@ -159,12 +159,12 @@             case res of               Left (err, errstr) -> do                 putStrLn $ inRed err-                maybe (return ()) SBS.putStrLn errstr-                return $ Left FailedToCompile+                maybe (pure ()) SBS.putStrLn errstr+                pure $ Left FailedToCompile               Right () ->-                return $ Right (program, cases)+                pure $ Right (program, cases)     _ ->-      return $ Left Skipped+      pure $ Left Skipped   where     hasRuns (InputOutputs _ runs) = not $ null runs @@ -251,7 +251,7 @@ mkProgressPrompt runs pad_to dataset_desc   | fancyTerminal = do     count <- newIORef (0, 0)-    return $ \us -> do+    pure $ \us -> do       putStr "\r" -- Go to start of line.       let p s =             putStr $@@ -269,7 +269,7 @@   | otherwise = do     putStr $ descString dataset_desc pad_to     hFlush stdout-    return $ const $ return ()+    pure $ const $ pure ()  reportResult :: [RunResult] -> IO () reportResult = putStrLn . reportString@@ -296,10 +296,10 @@   TestRun ->   IO (Maybe DataResult) runBenchmarkCase _ _ _ _ _ _ (TestRun _ _ RunTimeFailure {} _ _) =-  return Nothing -- Not our concern, we are not a testing tool.+  pure Nothing -- Not our concern, we are not a testing tool. runBenchmarkCase _ opts _ _ _ _ (TestRun tags _ _ _ _)   | any (`elem` tags) $ optExcludeCase opts =-    return Nothing+    pure Nothing runBenchmarkCase server opts futhark program entry pad_to tr@(TestRun _ input_spec (Succeeds expected_spec) _ dataset_desc) = do   prompt <- mkProgressPrompt (optRuns opts) pad_to dataset_desc @@ -321,23 +321,20 @@   when fancyTerminal $ do     clearLine     putStr "\r"+    putStr $ descString (atMostChars 40 dataset_desc) pad_to    case res of-    Left err -> do-      when fancyTerminal $-        liftIO $ putStrLn $ descString (atMostChars 40 dataset_desc) pad_to-      liftIO $ putStrLn $ inRed $ T.unpack err-      return $ Just $ DataResult dataset_desc $ Left err+    Left err -> liftIO $ do+      putStrLn ""+      putStrLn $ inRed $ T.unpack err+      pure $ Just $ DataResult dataset_desc $ Left err     Right (runtimes, errout) -> do-      when fancyTerminal $-        putStr $ descString (atMostChars 40 dataset_desc) pad_to-       reportResult runtimes       Result runtimes (getMemoryUsage errout) errout         & Right         & DataResult dataset_desc         & Just-        & return+        & pure  getMemoryUsage :: T.Text -> M.Map T.Text Int getMemoryUsage t =

@@ -177,7 +177,7 @@   | Just vs <- readValues $ BS.pack t =     return $ \_ fmt _ -> mapM_ (outValue fmt) vs   | otherwise = do-    t' <- toValueType =<< either (Left . show) Right (parseType name (T.pack t))+    t' <- toValueType =<< either (Left . syntaxErrorMsg) Right (parseType name (T.pack t))     return $ \conf fmt seed -> do       let v = randomValue conf t' seed       outValue fmt v

@@ -52,8 +52,8 @@ import Futhark.Util.Log import Futhark.Util.Options import qualified Futhark.Util.Pretty as PP-import Language.Futhark.Core (nameFromString)-import Language.Futhark.Parser (parseFuthark)+import Language.Futhark.Core (locStr, nameFromString)+import Language.Futhark.Parser (SyntaxError (..), parseFuthark) import System.Exit import System.FilePath import System.IO@@ -642,13 +642,14 @@               . intersperse ""               . map (if futharkPrintAST config then show else pretty) -          readProgram' = readProgram (futharkEntryPoints (futharkConfig config)) file+          readProgram' = readProgramFile (futharkEntryPoints (futharkConfig config)) file        case futharkPipeline config of         PrettyPrint -> liftIO $ do           maybe_prog <- parseFuthark file <$> T.readFile file           case maybe_prog of-            Left err -> fail $ show err+            Left (SyntaxError loc err) ->+              fail $ "Syntax error at " <> locStr loc <> ":\n" <> err             Right prog               | futharkPrintAST config -> print prog               | otherwise -> putStrLn $ pretty prog

@@ -11,7 +11,7 @@ import Data.List (nubBy) import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.IO as T-import Futhark.Compiler (Imports, dumpError, fileProg, newFutharkConfig, readLibrary)+import Futhark.Compiler (Imports, dumpError, fileProg, newFutharkConfig, readProgramFiles) import Futhark.Doc.Generator import Futhark.Pipeline (FutharkM, Verbosity (..), runFutharkM) import Futhark.Util (directoryContents, trim)@@ -49,7 +49,7 @@             liftIO $ do               mapM_ (hPutStrLn stderr . ("Found source file " <>)) files               hPutStrLn stderr "Reading files..."-          (_w, imports, _vns) <- readLibrary [] files+          (_w, imports, _vns) <- readProgramFiles [] files           liftIO $ printDecs config outdir files $ nubBy sameImport imports      sameImport (x, _) (y, _) = x == y

@@ -57,11 +57,21 @@ import Text.Megaparsec.Char import Text.Printf +newtype ImgParams = ImgParams+  { imgFile :: Maybe FilePath+  }+  deriving (Show)++defaultImgParams :: ImgParams+defaultImgParams =+  ImgParams {imgFile = Nothing}+ data VideoParams = VideoParams   { videoFPS :: Maybe Int,     videoLoop :: Maybe Bool,     videoAutoplay :: Maybe Bool,-    videoFormat :: Maybe T.Text+    videoFormat :: Maybe T.Text,+    videoFile :: Maybe FilePath   }   deriving (Show) @@ -71,14 +81,15 @@     { videoFPS = Nothing,       videoLoop = Nothing,       videoAutoplay = Nothing,-      videoFormat = Nothing+      videoFormat = Nothing,+      videoFile = Nothing     }  data Directive   = DirectiveRes Exp   | DirectiveBrief Directive   | DirectiveCovert Directive-  | DirectiveImg Exp+  | DirectiveImg Exp ImgParams   | DirectivePlot Exp (Maybe (Int, Int))   | DirectiveGnuplot Exp T.Text   | DirectiveVideo Exp VideoParams@@ -88,7 +99,7 @@ varsInDirective (DirectiveRes e) = varsInExp e varsInDirective (DirectiveBrief d) = varsInDirective d varsInDirective (DirectiveCovert d) = varsInDirective d-varsInDirective (DirectiveImg e) = varsInExp e+varsInDirective (DirectiveImg e _) = varsInExp e varsInDirective (DirectivePlot e _) = varsInExp e varsInDirective (DirectiveGnuplot e _) = varsInExp e varsInDirective (DirectiveVideo e _) = varsInExp e@@ -100,8 +111,17 @@   pprDirective False f pprDirective _ (DirectiveCovert f) =   pprDirective False f-pprDirective _ (DirectiveImg e) =+pprDirective _ (DirectiveImg e params) =   "> :img " <> PP.align (PP.ppr e)+    <> if null params' then mempty else PP.stack $ ";" : params'+  where+    params' =+      catMaybes+        [ p "file" imgFile PP.ppr+        ]+    p s f ppr = do+      x <- f params+      Just $ s <> ": " <> ppr x pprDirective True (DirectivePlot e (Just (h, w))) =   PP.stack     [ "> :plot2d " <> PP.ppr e <> ";",@@ -126,7 +146,8 @@         [ p "fps" videoFPS PP.ppr,           p "loop" videoLoop ppBool,           p "autoplay" videoAutoplay ppBool,-          p "format" videoFormat PP.strictText+          p "format" videoFormat PP.strictText,+          p "file" videoFile PP.ppr         ]     ppBool b = if b then "true" else "false"     p s f ppr = do@@ -191,6 +212,35 @@       *> token "("       *> ((,) <$> parseInt <* token "," <*> parseInt) <* token ")" +withPredicate :: (a -> Bool) -> String -> Parser a -> Parser a+withPredicate f msg p = do+  r <- lookAhead p+  if f r then p else fail msg++parseFilePath :: Parser FilePath+parseFilePath =+  withPredicate ok "filename must not have directory component" p+  where+    p = T.unpack <$> lexeme (takeWhileP Nothing (not . isSpace))+    ok f = takeFileName f == f++parseImgParams :: Parser ImgParams+parseImgParams =+  fmap (fromMaybe defaultImgParams) $+    optional $ ";" *> hspace *> eol *> "-- " *> parseParams defaultImgParams+  where+    parseParams params =+      choice+        [ choice+            [pFile params]+            >>= parseParams,+          pure params+        ]+    pFile params = do+      token "file:"+      b <- parseFilePath+      pure params {imgFile = Just b}+ parseVideoParams :: Parser VideoParams parseVideoParams =   fmap (fromMaybe defaultVideoParams) $@@ -246,7 +296,8 @@           directiveName "brief" $> DirectiveBrief             <*> parseDirective,           directiveName "img" $> DirectiveImg-            <*> parseExp postlexeme <* eol,+            <*> parseExp postlexeme+            <*> parseImgParams <* eol,           directiveName "plot2d" $> DirectivePlot             <*> parseExp postlexeme             <*> parsePlotParams <* eol,@@ -533,9 +584,9 @@     envHash :: T.Text   } -newFileWorker :: Env -> FilePath -> (FilePath -> ScriptM ()) -> ScriptM (FilePath, FilePath)-newFileWorker env template m = do-  let fname_base = T.unpack (envHash env) <> "-" <> template+newFileWorker :: Env -> (Maybe FilePath, FilePath) -> (FilePath -> ScriptM ()) -> ScriptM (FilePath, FilePath)+newFileWorker env (fname_desired, template) m = do+  let fname_base = fromMaybe (T.unpack (envHash env) <> "-" <> template) fname_desired       fname = envImgDir env </> fname_base       fname_rel = envRelImgDir env </> fname_base   exists <- liftIO $ doesFileExist fname@@ -549,12 +600,12 @@   modify $ \s -> s {stateFiles = S.insert fname $ stateFiles s}   pure (fname, fname_rel) -newFile :: Env -> FilePath -> (FilePath -> ScriptM ()) -> ScriptM FilePath-newFile env template m = snd <$> newFileWorker env template m+newFile :: Env -> (Maybe FilePath, FilePath) -> (FilePath -> ScriptM ()) -> ScriptM FilePath+newFile env f m = snd <$> newFileWorker env f m -newFileContents :: Env -> FilePath -> (FilePath -> ScriptM ()) -> ScriptM T.Text-newFileContents env template m =-  liftIO . T.readFile . fst =<< newFileWorker env template m+newFileContents :: Env -> (Maybe FilePath, FilePath) -> (FilePath -> ScriptM ()) -> ScriptM T.Text+newFileContents env f m =+  liftIO . T.readFile . fst =<< newFileWorker env f m  processDirective :: Env -> Directive -> ScriptM T.Text processDirective env (DirectiveBrief d) =@@ -563,7 +614,7 @@   processDirective env d processDirective env (DirectiveRes e) = do   result <--    newFileContents env "eval.txt" $ \resultf -> do+    newFileContents env (Nothing, "eval.txt") $ \resultf -> do       v <- either nope pure =<< evalExpToGround literateBuiltin (envServer env) e       liftIO $ T.writeFile resultf $ prettyText v   pure $@@ -578,8 +629,8 @@     nope t =       throwError $ "Cannot show value of type " <> prettyText t ---processDirective env (DirectiveImg e) = do-  fmap imgBlock . newFile env "img.png" $ \pngfile -> do+processDirective env (DirectiveImg e params) = do+  fmap imgBlock . newFile env (imgFile params, "img.png") $ \pngfile -> do     maybe_v <- evalExpToGround literateBuiltin (envServer env) e     case maybe_v of       Right (ValueAtom v)@@ -598,7 +649,7 @@         "Cannot create image from value of type " <> prettyText t -- processDirective env (DirectivePlot e size) = do-  fmap imgBlock . newFile env "plot.png" $ \pngfile -> do+  fmap imgBlock . newFile env (Nothing, "plot.png") $ \pngfile -> do     maybe_v <- evalExpToGround literateBuiltin (envServer env) e     case maybe_v of       Right v@@ -642,7 +693,7 @@         void $ system "gnuplot" [] script -- processDirective env (DirectiveGnuplot e script) = do-  fmap imgBlock . newFile env "plot.png" $ \pngfile -> do+  fmap imgBlock . newFile env (Nothing, "plot.png") $ \pngfile -> do     maybe_v <- evalExpToGround literateBuiltin (envServer env) e     case maybe_v of       Right (ValueRecord m)@@ -667,7 +718,8 @@   when (format `notElem` ["webm", "gif"]) $     throwError $ "Unknown video format: " <> format -  fmap (videoBlock params) . newFile env ("video" <.> T.unpack format) $ \videofile -> do+  let file = (videoFile params, "video" <.> T.unpack format)+  fmap (videoBlock params) . newFile env file $ \videofile -> do     v <- evalExp literateBuiltin (envServer env) e     let nope =           throwError $

@@ -153,7 +153,8 @@   (prog, tenv, ienv) <- case maybe_file of     Nothing -> do       -- Load the builtins through the type checker.-      (_, prog) <- badOnLeft show =<< runExceptT (reloadProg prev_prog [])+      (_, prog) <-+        badOnLeft prettyProgramErrors =<< liftIO (reloadProg prev_prog [])       -- Then into the interpreter.       ienv <-         foldM@@ -166,7 +167,7 @@        pure (prog, tenv, ienv')     Just file -> do-      (ws, prog) <- badOnLeft show =<< runExceptT (reloadProg prev_prog [file])+      (ws, prog) <- badOnLeft prettyProgramErrors =<< liftIO (reloadProg prev_prog [file])       liftIO $ putStrLn $ pretty ws        ienv <-@@ -195,6 +196,8 @@     badOnLeft _ (Right x) = pure x     badOnLeft p (Left err) = throwError $ p err +    prettyProgramErrors = pretty . pprProgramErrors+ getPrompt :: FutharkiM String getPrompt = do   i <- gets futharkiCount@@ -235,7 +238,7 @@       maybe_dec_or_e <- parseDecOrExpIncrM (inputLine "  ") prompt line        case maybe_dec_or_e of-        Left err -> liftIO $ print err+        Left (SyntaxError _ err) -> liftIO $ putStrLn err         Right (Left d) -> onDec d         Right (Right e) -> onExp e   modify $ \s -> s {futharkiCount = futharkiCount s + 1}@@ -260,12 +263,10 @@   let mkImport = uncurry $ T.mkImportFrom cur_import       files = map (T.includeToFilePath . mkImport) $ decImports d -  imp_r <- runExceptT $ do-    prog <- lift $ gets futharkiProg-    extendProg prog files-+  cur_prog <- gets futharkiProg+  imp_r <- liftIO $ extendProg cur_prog files   case imp_r of-    Left e -> liftIO $ print e+    Left e -> liftIO $ T.putStrLn $ prettyText $ pprProgramErrors e     Right (_ws, prog) -> do       env <- gets futharkiEnv       let (tenv, ienv) = extendEnvs prog env (map fst $ decImports d)@@ -392,15 +393,14 @@     (False, _) -> throwError $ Load $ T.unpack file  genTypeCommand ::-  Show err =>-  (String -> T.Text -> Either err a) ->+  (String -> T.Text -> Either SyntaxError a) ->   (Imports -> VNameSource -> T.Env -> a -> (Warnings, Either T.TypeError b)) ->   (b -> String) ->   Command genTypeCommand f g h e = do   prompt <- getPrompt   case f prompt e of-    Left err -> liftIO $ print err+    Left (SyntaxError _ err) -> liftIO $ putStrLn err     Right e' -> do       (imports, src, tenv, _) <- getIt       case snd $ g imports src tenv e' of

@@ -47,8 +47,8 @@    inps <-     case vr of-      Left err -> do-        hPutStrLn stderr $ "Error when reading input: " ++ show err+      Left (SyntaxError loc err) -> do+        hPutStrLn stderr $ "Input syntax error at " <> locStr loc <> ":\n" <> err         exitFailure       Right vs ->         return vs@@ -117,7 +117,7 @@   (ws, imports, src) <-     badOnLeft show       =<< liftIO-        ( runExceptT (readProgram [] file)+        ( runExceptT (readProgramFile [] file)             `catch` \(err :: IOException) ->               return (externalErrorS (show err))         )

@@ -47,6 +47,8 @@     )     <=< ImpGen.compileProg +-- | Generate the multicore context definitions.  This is exported+-- because the WASM backend needs it. generateContext :: GC.CompilerM op () () generateContext = do   mapM_ GC.earlyDecl [C.cunit|$esc:(T.unpack schedulerH)|]@@ -215,6 +217,7 @@                    }|]     ) +-- | Multicore-related command line options. cliOptions :: [Option] cliOptions =   [ Option@@ -233,6 +236,7 @@       }   ] +-- | Operations for generating multicore code. operations :: GC.Operations Multicore () operations =   GC.defaultOperations

@@ -414,8 +414,7 @@         num_threads = sExt64 $ kernelNumThreads constants     kernelLoop gtid num_threads total_w_64 $ \offset -> do       -- Construct segment indices.-      zipWithM_ dPrimV_ space_is $-        map sExt32 $ unflattenIndex space_sizes_64 offset+      dIndexSpace (zip space_is space_sizes_64) offset        -- We execute the bucket function once and update each histogram serially.       -- We apply the bucket function if j=offset+ltid is less than@@ -716,7 +715,7 @@         sOp $ Imp.Barrier Imp.FenceLocal          kernelLoop pgtid_in_segment threads_per_segment (sExt32 segment_size') $ \ie -> do-          dPrimV_ i_in_segment ie+          dPrimV_ i_in_segment $ sExt64 ie            -- We execute the bucket function once and update each histogram           -- serially.  This also involves writing to the mapout arrays if

@@ -40,6 +40,7 @@         (Or Int64, Imp.AtomicOr Int64)       ] +-- | Compile the program. compileProg ::   MonadFreshNames m =>   Prog MCMem ->

@@ -8,9 +8,11 @@     runCompilerOnProgram,     dumpError,     handleWarnings,+    pprProgramErrors,     module Futhark.Compiler.Program,     module Futhark.Compiler.Config,-    readProgram,+    readProgramFile,+    readProgramFiles,     readProgramOrDie,     readUntypedProgram,     readUntypedProgramOrDie,@@ -20,6 +22,8 @@ import Control.Monad import Control.Monad.Except import Data.Bifunctor (first)+import qualified Data.List.NonEmpty as NE+import Data.Loc (Loc (NoLoc)) import qualified Data.Text.IO as T import qualified Futhark.Analysis.Alias as Alias import Futhark.Compiler.Config@@ -30,8 +34,9 @@ import Futhark.Internalise import Futhark.MonadFreshNames import Futhark.Pipeline+import Futhark.Util.Console (inRed) import Futhark.Util.Log-import Futhark.Util.Pretty (ppr, prettyText)+import Futhark.Util.Pretty (Doc, line, ppr, prettyText, punctuate, stack, text, (</>)) import qualified Language.Futhark as E import Language.Futhark.Semantic (includeToString) import Language.Futhark.Warnings@@ -105,7 +110,7 @@   (prog_imports, namesrc) <-     handleWarnings config $       (\(a, b, c) -> (a, (b, c)))-        <$> readProgram (futharkEntryPoints config) file+        <$> readProgramFile (futharkEntryPoints config) file    putNameSource namesrc   int_prog <- internaliseProg config prog_imports@@ -128,14 +133,44 @@   where     prog' = Alias.aliasAnalysis prog --- | Read and type-check a Futhark program, including all imports.-readProgram ::+-- | Prettyprint program errors as suitable for showing on a text console.+pprProgramErrors :: NE.NonEmpty ProgramError -> Doc+pprProgramErrors = stack . punctuate line . map onError . NE.toList+  where+    onError (ProgramError NoLoc msg) =+      msg+    onError (ProgramError loc msg) =+      text (inRed $ "Error at " <> locStr (srclocOf loc) <> ":") </> msg++-- | Throw an exception formatted with 'pprProgramErrors' if there's+-- an error.+throwOnProgramError ::+  MonadError CompilerError m =>+  Either (NE.NonEmpty ProgramError) a ->+  m a+throwOnProgramError =+  either (externalError . pprProgramErrors) pure++-- | Read and type-check a Futhark program, comprising a single file,+-- including all imports.+readProgramFile ::   (MonadError CompilerError m, MonadIO m) =>   [I.Name] ->   FilePath ->   m (Warnings, Imports, VNameSource)-readProgram extra_eps = readLibrary extra_eps . pure+readProgramFile extra_eps =+  readProgramFiles extra_eps . pure +-- | Read and type-check a Futhark library, comprising multiple files,+-- including all imports.+readProgramFiles ::+  (MonadError CompilerError m, MonadIO m) =>+  [I.Name] ->+  [FilePath] ->+  m (Warnings, Imports, VNameSource)+readProgramFiles extra_eps =+  throwOnProgramError <=< liftIO . readLibrary extra_eps+ -- | Read and parse (but do not type-check) a Futhark program, -- including all imports. readUntypedProgram ::@@ -143,7 +178,8 @@   FilePath ->   m [(String, E.UncheckedProg)] readUntypedProgram =-  fmap (map (first includeToString)) . readUntypedLibrary . pure+  fmap (map (first includeToString)) . throwOnProgramError+    <=< liftIO . readUntypedLibrary . pure  orDie :: MonadIO m => FutharkM a -> m a orDie m = liftIO $ do@@ -156,7 +192,7 @@  -- | Not verbose, and terminates process on error. readProgramOrDie :: MonadIO m => FilePath -> m (Warnings, Imports, VNameSource)-readProgramOrDie file = orDie $ readProgram mempty file+readProgramOrDie file = orDie $ readProgramFile mempty file  -- | Not verbose, and terminates process on error. readUntypedProgramOrDie :: MonadIO m => FilePath -> m [(String, E.UncheckedProg)]

@@ -10,6 +10,7 @@     Imports,     FileModule (..),     E.Warnings,+    ProgramError (..),     LoadedProg (lpNameSource),     noLoadedProg,     lpImports,@@ -32,17 +33,18 @@ import Control.Monad.State (execStateT, gets, modify) import Data.Bifunctor (first) import Data.List (intercalate, isPrefixOf, sort)+import qualified Data.List.NonEmpty as NE+import Data.Loc (Loc (..), locOf) import qualified Data.Map as M import Data.Maybe (mapMaybe) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Time.Clock (UTCTime)-import Futhark.Error import Futhark.FreshNames import Futhark.Util (interactWithFileSafely, nubOrd, startupTime)-import Futhark.Util.Pretty (line, ppr, text, (</>))+import Futhark.Util.Pretty (Doc, line, ppr, text, (</>)) import qualified Language.Futhark as E-import Language.Futhark.Parser+import Language.Futhark.Parser (SyntaxError (..), parseFuthark) import Language.Futhark.Prelude import Language.Futhark.Semantic import qualified Language.Futhark.TypeChecker as E@@ -60,9 +62,15 @@   }   deriving (Eq, Ord, Show) +-- | Note that the location may be 'NoLoc'.  This essentially only+-- happens when the problem is that a root file cannot be found.+data ProgramError = ProgramError Loc Doc++type WithErrors = Either (NE.NonEmpty ProgramError)+ newtype UncheckedImport = UncheckedImport   { unChecked ::-      Either CompilerError (LoadedFile E.UncheckedProg, [(ImportName, MVar UncheckedImport)])+      WithErrors (LoadedFile E.UncheckedProg, [(ImportName, MVar UncheckedImport)])   }  -- | If mapped to Nothing, treat it as present.  This is used when@@ -72,29 +80,46 @@ newState :: [ImportName] -> IO ReaderState newState known = newMVar $ M.fromList $ zip known $ repeat Nothing +-- Since we need to work with base 4.14 that does not have NE.singleton.+singleError :: ProgramError -> NE.NonEmpty ProgramError+singleError = (NE.:| [])+ orderedImports ::-  (MonadError CompilerError m, MonadIO m) =>   [(ImportName, MVar UncheckedImport)] ->-  m [(ImportName, LoadedFile E.UncheckedProg)]+  IO [(ImportName, WithErrors (LoadedFile E.UncheckedProg))] orderedImports = fmap reverse . flip execStateT [] . mapM_ (spelunk [])   where     spelunk steps (include, mvar)-      | include `elem` steps =-        externalErrorS $-          "Import cycle: "-            ++ intercalate-              " -> "-              (map includeToString $ reverse $ include : steps)+      | include `elem` steps = do+        let problem =+              ProgramError (locOf include) . text $+                "Import cycle: "+                  <> intercalate+                    " -> "+                    (map includeToString $ reverse $ include : steps)+        modify ((include, Left (singleError problem)) :)       | otherwise = do         prev <- gets $ lookup include         case prev of           Just _ -> pure ()           Nothing -> do-            (file, more_imports) <--              either throwError pure . unChecked =<< liftIO (readMVar mvar)-            mapM_ (spelunk (include : steps)) more_imports-            modify ((include, file) :)+            res <- unChecked <$> liftIO (readMVar mvar)+            case res of+              Left errors ->+                modify ((include, Left errors) :)+              Right (file, more_imports) -> do+                mapM_ (spelunk (include : steps)) more_imports+                modify ((include, Right file) :) +errorsToTop ::+  [(ImportName, WithErrors (LoadedFile E.UncheckedProg))] ->+  WithErrors [(ImportName, LoadedFile E.UncheckedProg)]+errorsToTop [] = Right []+errorsToTop ((_, Left x) : rest) =+  either (Left . (x <>)) (const (Left x)) (errorsToTop rest)+errorsToTop ((name, Right x) : rest) =+  fmap ((name, x) :) (errorsToTop rest)+ newImportMVar :: IO UncheckedImport -> IO (Maybe (MVar UncheckedImport)) newImportMVar m = do   mvar <- newEmptyMVar@@ -106,7 +131,7 @@   interactWithFileSafely $     (,) <$> T.readFile filepath <*> getModificationTime filepath -readImportFile :: ImportName -> IO (Either CompilerError (LoadedFile T.Text))+readImportFile :: ImportName -> IO (Either ProgramError (LoadedFile T.Text)) readImportFile include = do   -- First we try to find a file of the given name in the search path,   -- then we look at the builtin library if we have to.  For the@@ -116,10 +141,12 @@   case (r, lookup prelude_str prelude) of     (Just (Right (s, mod_time)), _) ->       pure $ Right $ loaded filepath s mod_time-    (Just (Left e), _) -> pure $ Left $ ExternalError $ text e+    (Just (Left e), _) ->+      pure $ Left $ ProgramError (locOf include) $ text e     (Nothing, Just s) ->       pure $ Right $ loaded prelude_str s startupTime-    (Nothing, Nothing) -> pure $ Left $ ExternalError $ text not_found+    (Nothing, Nothing) ->+      pure $ Left $ ProgramError (locOf include) $ text not_found   where     prelude_str = "/" Posix.</> includeToString include Posix.<.> "fut" @@ -132,16 +159,14 @@         }      not_found =-      "Error at " ++ E.locStr (E.srclocOf include)-        ++ ": could not find import '"-        ++ includeToString include-        ++ "'."+      "Could not find import " <> E.quote (includeToString include) <> "."  handleFile ::   ReaderState -> LoadedFile T.Text -> IO UncheckedImport handleFile state_mvar (LoadedFile file_name import_name file_contents mod_time) = do   case parseFuthark file_name file_contents of-    Left err -> pure $ UncheckedImport $ Left $ ExternalError $ text $ show err+    Left (SyntaxError loc err) ->+      pure . UncheckedImport . Left . singleError $ ProgramError loc $ text err     Right prog -> do       let imports = map (uncurry (mkImportFrom import_name)) $ E.progImports prog       mvars <-@@ -164,22 +189,21 @@       Nothing -> do         prog_mvar <- newImportMVar $ do           readImportFile include >>= \case-            Left e -> pure $ UncheckedImport $ Left e+            Left e -> pure $ UncheckedImport $ Left $ singleError e             Right file -> handleFile state_mvar file         pure (M.insert include prog_mvar state, prog_mvar)  readUntypedLibraryExceptKnown ::-  (MonadIO m, MonadError CompilerError m) =>   [ImportName] ->   [FilePath] ->-  m [LoadedFile E.UncheckedProg]+  IO (Either (NE.NonEmpty ProgramError) [LoadedFile E.UncheckedProg]) readUntypedLibraryExceptKnown known fps = do   state_mvar <- liftIO $ newState known   let prelude_import = mkInitialImport "/prelude/prelude"   prelude_mvar <- liftIO $ readImport state_mvar prelude_import   fps_mvars <- liftIO (mapM (onFile state_mvar) fps)   let unknown_mvars = onlyUnknown ((prelude_import, prelude_mvar) : fps_mvars)-  map snd <$> orderedImports unknown_mvars+  fmap (map snd) . errorsToTop <$> orderedImports unknown_mvars   where     onlyUnknown = mapMaybe sequenceA     onFile state_mvar fp =@@ -199,9 +223,11 @@                         lfPath = fp                       }                 Just (Left e) ->-                  pure $ UncheckedImport $ Left $ ExternalError $ text $ show e+                  pure . UncheckedImport . Left . singleError $+                    ProgramError NoLoc $ text $ show e                 Nothing ->-                  pure $ UncheckedImport $ Left $ ExternalError $ text $ fp <> ": file not found."+                  pure . UncheckedImport . Left . singleError $+                    ProgramError NoLoc $ text $ fp <> ": file not found."             pure (M.insert include prog_mvar state, (include, prog_mvar))       where         include = mkInitialImport fp_name@@ -213,11 +239,10 @@     f lf = (includeToString (lfImportName lf), snd $ lfMod lf)  typeCheckProg ::-  MonadError CompilerError m =>   [LoadedFile (VNameSource, FileModule)] ->   VNameSource ->   [LoadedFile E.UncheckedProg] ->-  m (E.Warnings, [LoadedFile (VNameSource, FileModule)], VNameSource)+  WithErrors (E.Warnings, [LoadedFile (VNameSource, FileModule)], VNameSource) typeCheckProg orig_imports orig_src =   foldM f (mempty, orig_imports, orig_src)   where@@ -228,14 +253,15 @@             | "/prelude" `isPrefixOf` includeToFilePath import_name = prog             | otherwise = prependRoots roots prog       case E.checkProg (asImports imports) src import_name prog' of-        (prog_ws, Left err) -> do+        (prog_ws, Left (E.TypeError loc notes msg)) -> do           let ws' = ws <> prog_ws-          externalError $+              err' = msg <> ppr notes+          Left . singleError . ProgramError (locOf loc) $             if anyWarnings ws'-              then ppr ws' </> line <> ppr err-              else ppr err+              then ppr ws' </> line <> ppr err'+              else ppr err'         (prog_ws, Right (m, src')) ->-          pure+          Right             ( ws <> prog_ws,               imports ++ [LoadedFile path import_name (src, m) mod_time],               src'@@ -330,53 +356,51 @@  -- | Extend a loaded program with (possibly new) files. extendProg ::-  (MonadError CompilerError m, MonadIO m) =>   LoadedProg ->   [FilePath] ->-  m (E.Warnings, LoadedProg)+  IO (Either (NE.NonEmpty ProgramError) (E.Warnings, LoadedProg)) extendProg lp new_roots = do   new_imports_untyped <-     readUntypedLibraryExceptKnown (map lfImportName $ lpFiles lp) new_roots-  (ws, imports, src') <--    typeCheckProg (lpFiles lp) (lpNameSource lp) new_imports_untyped-  pure (ws, LoadedProg (nubOrd (lpRoots lp ++ new_roots)) imports src')+  pure $ do+    (ws, imports, src') <-+      typeCheckProg (lpFiles lp) (lpNameSource lp) =<< new_imports_untyped+    Right (ws, LoadedProg (nubOrd (lpRoots lp ++ new_roots)) imports src')  -- | Load some new files, reusing as much of the previously loaded -- program as possible.  This does not *extend* the currently loaded -- program the way 'extendProg' does it, so it is always correct (if -- less efficient) to pass 'noLoadedProg'. reloadProg ::-  (MonadError CompilerError m, MonadIO m) =>   LoadedProg ->   [FilePath] ->-  m (E.Warnings, LoadedProg)+  IO (Either (NE.NonEmpty ProgramError) (E.Warnings, LoadedProg)) reloadProg lp new_roots = do   lp' <- usableLoadedProg lp new_roots   extendProg lp' new_roots  -- | Read and type-check some Futhark files. readLibrary ::-  (MonadError CompilerError m, MonadIO m) =>   -- | Extra functions that should be marked as entry points; only   -- applies to the immediate files, not any imports imported.   [E.Name] ->   -- | The files to read.   [FilePath] ->-  m (E.Warnings, Imports, VNameSource)+  IO (Either (NE.NonEmpty ProgramError) (E.Warnings, Imports, VNameSource)) readLibrary extra_eps fps =-  fmap frob-    . typeCheckProg mempty (lpNameSource noLoadedProg)-    . setEntryPoints (E.defaultEntryPoint : extra_eps) fps-    =<< readUntypedLibraryExceptKnown [] fps+  ( fmap frob+      . typeCheckProg mempty (lpNameSource noLoadedProg)+      <=< fmap (setEntryPoints (E.defaultEntryPoint : extra_eps) fps)+  )+    <$> readUntypedLibraryExceptKnown [] fps   where     frob (x, y, z) = (x, asImports y, z)  -- | Read (and parse) all source files (including the builtin prelude) -- corresponding to a set of root files. readUntypedLibrary ::-  (MonadIO m, MonadError CompilerError m) =>   [FilePath] ->-  m [(ImportName, E.UncheckedProg)]-readUntypedLibrary = fmap (map f) . readUntypedLibraryExceptKnown []+  IO (Either (NE.NonEmpty ProgramError) [(ImportName, E.UncheckedProg)])+readUntypedLibrary = fmap (fmap (map f)) . readUntypedLibraryExceptKnown []   where     f lf = (lfImportName lf, lfMod lf)

@@ -47,18 +47,29 @@ -- z <- letExp "z" $ BasicOp $ BinOp (Add Int32) (Var x) (Var y) -- @ --+-- == Monadic expression builders+--+-- This module also contains "monadic expression" functions that let+-- us build nested expressions in a "direct" style, rather than using+-- 'letExp' and friends to bind every sub-part first.  See functions+-- such as 'eIf' and 'eBody' for example.  See also+-- "Futhark.Analysis.PrimExp" and the 'ToExp' type class.+-- -- == Examples -- -- The "Futhark.Transform.FirstOrderTransform" module is a -- (relatively) simple example of how to use these components.  As are -- some of the high-level building blocks in this very module. module Futhark.Construct-  ( letSubExp,-    letSubExps,+  ( -- * Basic building blocks+    module Futhark.Builder,+    letSubExp,     letExp,     letTupExp,     letTupExp',     letInPlace,++    -- * Monadic expression builders     eSubExp,     eParam,     eIf,@@ -75,6 +86,8 @@     eBlank,     eAll,     eOutOfBounds,++    -- * Other building blocks     asIntZ,     asIntS,     resultBody,@@ -93,7 +106,6 @@     isFullSlice,     sliceAt,     ifCommon,-    module Futhark.Builder,      -- * Result types     instantiateShapes,@@ -115,6 +127,10 @@ import Futhark.IR import Futhark.Util (maybeNth) +-- | @letSubExp desc e@ binds the expression @e@, which must produce a+-- single value.  Returns a t'SubExp' corresponding to the resulting+-- value.  For expressions that produce multiple values, see+-- 'letTupExp'. letSubExp ::   MonadBuilder m =>   String ->@@ -123,6 +139,7 @@ letSubExp _ (BasicOp (SubExp se)) = return se letSubExp desc e = Var <$> letExp desc e +-- | Like 'letSubExp', but returns a name rather than a t'SubExp'. letExp ::   MonadBuilder m =>   String ->@@ -138,6 +155,9 @@     [v] -> return v     _ -> error $ "letExp: tuple-typed expression given:\n" ++ pretty e +-- | Like 'letExp', but the 'VName' and 'Slice' denote an array that+-- is 'Update'd with the result of the expression.  The name of the+-- updated array is returned. letInPlace ::   MonadBuilder m =>   String ->@@ -149,13 +169,7 @@   tmp <- letSubExp (desc ++ "_tmp") e   letExp desc $ BasicOp $ Update Unsafe src slice tmp -letSubExps ::-  MonadBuilder m =>-  String ->-  [Exp (Rep m)] ->-  m [SubExp]-letSubExps desc = mapM $ letSubExp desc-+-- | Like 'letExp', but the expression may return multiple values. letTupExp ::   (MonadBuilder m) =>   String ->@@ -169,6 +183,7 @@   letBindNames names e   pure names +-- | Like 'letTupExp', but returns t'SubExp's instead of 'VName's. letTupExp' ::   (MonadBuilder m) =>   String ->@@ -177,18 +192,25 @@ letTupExp' _ (BasicOp (SubExp se)) = return [se] letTupExp' name ses = map Var <$> letTupExp name ses +-- | Turn a subexpression into a monad expression.  Does not actually+-- lead to any code generation.  This is supposed to be used alongside+-- the other monadic expression functions, such as 'eIf'. eSubExp ::   MonadBuilder m =>   SubExp ->   m (Exp (Rep m)) eSubExp = pure . BasicOp . SubExp +-- | Treat a parameter as a monadic expression. eParam ::   MonadBuilder m =>   Param t ->   m (Exp (Rep m)) eParam = eSubExp . Var . paramName +-- | Construct an 'If' expression from a monadic condition and monadic+-- branches.  'eBody' might be convenient for constructing the+-- branches. eIf ::   (MonadBuilder m, BranchType (Rep m) ~ ExtType) =>   m (Exp (Rep m)) ->@@ -233,6 +255,7 @@   where     stmsscope = scopeOf stms +-- | Construct a v'BinOp' expression with the given operator. eBinOp ::   MonadBuilder m =>   BinOp ->@@ -244,6 +267,7 @@   y' <- letSubExp "y" =<< y   return $ BasicOp $ BinOp op x' y' +-- | Construct a v'CmpOp' expression with the given comparison. eCmpOp ::   MonadBuilder m =>   CmpOp ->@@ -255,6 +279,7 @@   y' <- letSubExp "y" =<< y   return $ BasicOp $ CmpOp op x' y' +-- | Construct a v'ConvOp' expression with the given conversion. eConvOp ::   MonadBuilder m =>   ConvOp ->@@ -264,6 +289,8 @@   x' <- letSubExp "x" =<< x   return $ BasicOp $ ConvOp op x' +-- | Construct a 'SSignum' expression.  Fails if the provided+-- expression is not of integer type. eSignum ::   MonadBuilder m =>   m (Exp (Rep m)) ->@@ -278,12 +305,20 @@     _ ->       error $ "eSignum: operand " ++ pretty e ++ " has invalid type." +-- | Construct a 'Copy' expression. eCopy ::   MonadBuilder m =>   m (Exp (Rep m)) ->   m (Exp (Rep m)) eCopy e = BasicOp . Copy <$> (letExp "copy_arg" =<< e) +-- | Construct a body from expressions.  If multiple expressions are+-- provided, their results will be concatenated in order and returned+-- as the result.+--+-- /Beware/: this will not produce correct code if the type of the+-- body would be existential.  That is, the type of the results being+-- returned should be invariant to the body. eBody ::   (MonadBuilder m) =>   [m (Exp (Rep m))] ->@@ -293,6 +328,9 @@   xs <- mapM (letTupExp "x") es'   pure $ varsRes $ concat xs +-- | Bind each lambda parameter to the result of an expression, then+-- bind the body of the lambda.  The expressions must produce only a+-- single value each. eLambda ::   MonadBuilder m =>   Lambda (Rep m) ->@@ -304,6 +342,9 @@   where     bindParam param arg = letBindNames [paramName param] =<< arg +-- | @eRoundToMultipleOf t x d@ produces an expression that rounds the+-- integer expression @x@ upwards to be a multiple of @d@, with @t@+-- being the integer type of the expressions. eRoundToMultipleOf ::   MonadBuilder m =>   IntType ->@@ -492,6 +533,7 @@     allOfIt d (DimSlice _ n _) = d == n     allOfIt _ _ = False +-- | Produce the common case of an 'IfDec'. ifCommon :: [Type] -> IfDec ExtType ifCommon ts = IfDec (staticShapes ts) IfNormal @@ -568,6 +610,9 @@           return se     instantiate' (Free se) = return se +-- | Like 'instantiateShapes', but obtains names from the provided+-- list.  If an 'Ext' is out of bounds of this list, the function+-- fails with 'error'. instantiateShapes' :: [VName] -> [TypeBase ExtShape u] -> [TypeBase Shape u] instantiateShapes' names ts =   -- Carefully ensure that the order of idents we produce corresponds@@ -579,6 +624,8 @@         Nothing -> error $ "instantiateShapes': " ++ pretty names ++ ", " ++ show x         Just name -> pure $ Var name +-- | Remove existentials by imposing sizes from another type where+-- needed. removeExistentials :: ExtType -> Type -> Type removeExistentials t1 t2 =   t1

@@ -5,8 +5,14 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} --- | A representation where all bindings are annotated with aliasing--- information.+-- | A representation where all patterns are annotated with aliasing+-- information.  It also records consumption of variables in bodies.+--+-- Note that this module is mostly not concerned with actually+-- /computing/ the aliasing information; only with shuffling it around+-- and providing some basic building blocks.  See modules such as+-- "Futhark.Analysis.Alias" for computing the aliases in the first+-- place. module Futhark.IR.Aliases   ( -- * The representation definition     Aliases,@@ -23,11 +29,9 @@     module Futhark.IR.Syntax,      -- * Adding aliases-    addAliasesToPat,-    mkAliasedLetStm,     mkAliasedBody,-    mkPatAliases,-    mkBodyAliases,+    mkAliasedPat,+    mkBodyAliasing,      -- * Removing aliases     removeProgAliases,@@ -185,6 +189,7 @@       rephraseOp = return . removeOpAliases     } +-- | Remove alias information from an aliased scope. removeScopeAliases :: Scope (Aliases rep) -> Scope rep removeScopeAliases = M.map unAlias   where@@ -193,49 +198,49 @@     unAlias (LParamName dec) = LParamName dec     unAlias (IndexName it) = IndexName it +-- | Remove alias information from a program. removeProgAliases ::   CanBeAliased (Op rep) =>   Prog (Aliases rep) ->   Prog rep removeProgAliases = runIdentity . rephraseProg removeAliases +-- | Remove alias information from a function. removeFunDefAliases ::   CanBeAliased (Op rep) =>   FunDef (Aliases rep) ->   FunDef rep removeFunDefAliases = runIdentity . rephraseFunDef removeAliases +-- | Remove alias information from an expression. removeExpAliases ::   CanBeAliased (Op rep) =>   Exp (Aliases rep) ->   Exp rep removeExpAliases = runIdentity . rephraseExp removeAliases +-- | Remove alias information from statements. removeStmAliases ::   CanBeAliased (Op rep) =>   Stm (Aliases rep) ->   Stm rep removeStmAliases = runIdentity . rephraseStm removeAliases +-- | Remove alias information from lambda. removeLambdaAliases ::   CanBeAliased (Op rep) =>   Lambda (Aliases rep) ->   Lambda rep removeLambdaAliases = runIdentity . rephraseLambda removeAliases +-- | Remove alias information from pattern. removePatAliases ::   Pat (AliasDec, a) ->   Pat a removePatAliases = runIdentity . rephrasePat (return . snd) -addAliasesToPat ::-  (ASTRep rep, CanBeAliased (Op rep), Typed dec) =>-  Pat dec ->-  Exp (Aliases rep) ->-  Pat (VarAliases, dec)-addAliasesToPat pat e =-  Pat $ mkPatAliases pat e-+-- | Augment a body decoration with aliasing information provided by+-- the statements and result of that body. mkAliasedBody ::   (ASTRep rep, CanBeAliased (Op rep)) =>   BodyDec rep ->@@ -243,20 +248,20 @@   Result ->   Body (Aliases rep) mkAliasedBody dec stms res =-  Body (mkBodyAliases stms res, dec) stms res+  Body (mkBodyAliasing stms res, dec) stms res -mkPatAliases ::+-- | Augment a pattern with aliasing information provided by the+-- expression the pattern is bound to.+mkAliasedPat ::   (Aliased rep, Typed dec) =>   Pat dec ->   Exp rep ->-  [PatElem (VarAliases, dec)]-mkPatAliases pat e =-  let als = expAliases e ++ repeat mempty-   in -- In case the pattern has-      -- more elements (this-      -- implies a type error).-      zipWith annotatePatElem (patElems pat) als+  Pat (VarAliases, dec)+mkAliasedPat pat e = Pat $ zipWith annotatePatElem (patElems pat) als   where+    -- Repeat mempty in case the pattern has more elements (this+    -- implies a type error).+    als = expAliases e ++ repeat mempty     annotatePatElem bindee names =       bindee `setPatElemDec` (AliasDec names', patElemDec bindee)       where@@ -266,12 +271,18 @@             Mem _ -> names             _ -> mempty -mkBodyAliases ::+-- | Given statements (with aliasing information) and a body result,+-- produce aliasing information for the corresponding body as a whole.+-- This is basically just looking up the aliasing of each element of+-- the result, and removing the names that are no longer in scope.+-- Note that this does *not* include aliases of results that are not+-- bound in the statements!+mkBodyAliasing ::   Aliased rep =>   Stms rep ->   Result ->   BodyAliasing-mkBodyAliases stms res =+mkBodyAliasing stms res =   -- We need to remove the names that are bound in stms from the alias   -- and consumption sets.  We do this by computing the transitive   -- closure of the alias map (within stms), then removing anything@@ -302,11 +313,19 @@       where         look k = M.findWithDefault mempty k aliasmap +-- | A tuple of a mapping from variable names to their aliases, and+-- the names of consumed variables. type AliasesAndConsumed =   ( M.Map VName Names,     Names   ) +-- | A helper function for computing the aliases of a sequence of+-- statements.  You'd use this while recursing down the statements+-- from first to last.  The 'AliasesAndConsumed' parameter is the+-- current "state" of aliasing, and the function then returns a new+-- state.  The main thing this function provides is proper handling of+-- transitivity and "reverse" aliases. trackAliases ::   Aliased rep =>   AliasesAndConsumed ->@@ -337,7 +356,7 @@   Stm (Aliases rep) mkAliasedLetStm pat (StmAux cs attrs dec) e =   Let-    (addAliasesToPat pat e)+    (mkAliasedPat pat e)     (StmAux cs attrs (AliasDec $ consumedInExp e, dec))     e @@ -347,7 +366,7 @@      in (AliasDec $ consumedInExp e, dec)    mkExpPat ids e =-    addAliasesToPat (mkExpPat ids $ removeExpAliases e) e+    mkAliasedPat (mkExpPat ids $ removeExpAliases e) e    mkLetNames names e = do     env <- asksScope removeScopeAliases

@@ -15,7 +15,6 @@   ) where -import qualified Futhark.Analysis.SymbolTable as ST import Futhark.IR.GPU import qualified Futhark.IR.SOACS.Simplify as SOAC import Futhark.MonadFreshNames@@ -26,7 +25,6 @@ import Futhark.Optimise.Simplify.Rules import Futhark.Pass import Futhark.Tools-import qualified Futhark.Transform.FirstOrderTransform as FOT  simpleGPU :: Simplify.SimpleOps GPU simpleGPU = Simplify.bindableSimpleOps $ simplifyKernelOp SOAC.simplifySOAC@@ -95,23 +93,10 @@ kernelRules =   standardRules <> segOpRules     <> ruleBook-      [ RuleOp redomapIotaToLoop,-        RuleOp SOAC.simplifyKnownIterationSOAC,+      [ RuleOp SOAC.simplifyKnownIterationSOAC,         RuleOp SOAC.removeReplicateMapping,         RuleOp SOAC.liftIdentityMapping,         RuleOp SOAC.simplifyMapIota       ]       [ RuleBasicOp removeUnnecessaryCopy       ]---- We turn reductions over (solely) iotas into do-loops, because there--- is no useful structure here anyway.  This is mostly a hack to work--- around the fact that loop tiling would otherwise pointlessly tile--- them.-redomapIotaToLoop :: TopDownRuleOp (Wise GPU)-redomapIotaToLoop vtable pat aux (OtherOp soac@(Screma _ [arr] form))-  | Just _ <- isRedomapSOAC form,-    Just (Iota {}, _) <- ST.lookupBasicOp arr vtable =-    Simplify $ certifying (stmAuxCerts aux) $ FOT.transformSOAC pat soac-redomapIotaToLoop _ _ _ _ =-  Skip

@@ -80,7 +80,7 @@ -- | A second-order array combinator (SOAC). data SOAC rep   = Stream SubExp [VName] (StreamForm rep) [SubExp] (Lambda rep)-  | -- | @Scatter <length> <lambda> <inputs> <outputs>@+  | -- | @Scatter <length> <inputs> <lambda> <outputs>@     --     -- Scatter maps values from a set of input arrays to indices and values of a     -- set of output arrays. It is able to write multiple values to multiple@@ -116,13 +116,11 @@     -- arr2. Additionally, the results are grouped, so the first 6 index values     -- will correspond to the first two output values, and so on. For this     -- example, <lambda> should return a total of 11 values, 8 index values and-    -- 3 output values.+    -- 3 output values.  See also 'splitScatterResults'.     Scatter SubExp [VName] (Lambda rep) [(Shape, Int, VName)]-  | -- | @Hist <length> <dest-arrays-and-ops> <bucket fun> <input arrays>@+  | -- | @Hist <length> <input arrays> <dest-arrays-and-ops> <bucket fun>@     ---    -- The first SubExp is the length of the input arrays. The first-    -- list describes the operations to perform.  The t'Lambda' is the-    -- bucket function.  Finally comes the input images.+    -- The final lambda produces indexes and values for the 'HistOp's.     Hist SubExp [VName] [HistOp rep] (Lambda rep)   | -- | A combination of scan, reduction, and map.  The first     -- t'SubExp' is the size of the input arrays.

@@ -671,6 +671,7 @@   = ArrayIndexing Certs VName (Slice SubExp)   | ArrayRearrange Certs VName [Int]   | ArrayRotate Certs VName [SubExp]+  | ArrayReshape Certs VName (ShapeChange SubExp)   | ArrayCopy Certs VName   | -- | Never constructed.     ArrayVar Certs VName@@ -680,6 +681,7 @@ arrayOpArr (ArrayIndexing _ arr _) = arr arrayOpArr (ArrayRearrange _ arr _) = arr arrayOpArr (ArrayRotate _ arr _) = arr+arrayOpArr (ArrayReshape _ arr _) = arr arrayOpArr (ArrayCopy _ arr) = arr arrayOpArr (ArrayVar _ arr) = arr @@ -687,6 +689,7 @@ arrayOpCerts (ArrayIndexing cs _ _) = cs arrayOpCerts (ArrayRearrange cs _ _) = cs arrayOpCerts (ArrayRotate cs _ _) = cs+arrayOpCerts (ArrayReshape cs _ _) = cs arrayOpCerts (ArrayCopy cs _) = cs arrayOpCerts (ArrayVar cs _) = cs @@ -697,6 +700,8 @@   Just $ ArrayRearrange cs arr perm isArrayOp cs (BasicOp (Rotate rots arr)) =   Just $ ArrayRotate cs arr rots+isArrayOp cs (BasicOp (Reshape new_shape arr)) =+  Just $ ArrayReshape cs arr new_shape isArrayOp cs (BasicOp (Copy arr)) =   Just $ ArrayCopy cs arr isArrayOp _ _ =@@ -706,6 +711,7 @@ fromArrayOp (ArrayIndexing cs arr slice) = (cs, BasicOp $ Index arr slice) fromArrayOp (ArrayRearrange cs arr perm) = (cs, BasicOp $ Rearrange perm arr) fromArrayOp (ArrayRotate cs arr rots) = (cs, BasicOp $ Rotate rots arr)+fromArrayOp (ArrayReshape cs arr new_shape) = (cs, BasicOp $ Reshape new_shape arr) fromArrayOp (ArrayCopy cs arr) = (cs, BasicOp $ Copy arr) fromArrayOp (ArrayVar cs arr) = (cs, BasicOp $ SubExp $ Var arr) @@ -901,6 +907,9 @@     arrayIsMapParam (_, ArrayRotate cs arr rots) =       arr `elem` map_param_names         && all (`ST.elem` vtable) (namesToList $ freeIn cs <> freeIn rots)+    arrayIsMapParam (_, ArrayReshape cs arr new_shape) =+      arr `elem` map_param_names+        && all (`ST.elem` vtable) (namesToList $ freeIn cs <> freeIn new_shape)     arrayIsMapParam (_, ArrayCopy cs arr) =       arr `elem` map_param_names         && all (`ST.elem` vtable) (namesToList $ freeIn cs)@@ -921,6 +930,8 @@                 BasicOp $ Rearrange (0 : map (+ 1) perm) arr               ArrayRotate _ _ rots ->                 BasicOp $ Rotate (intConst Int64 0 : rots) arr+              ArrayReshape _ _ new_shape ->+                BasicOp $ Reshape (DimCoercion w : new_shape) arr               ArrayCopy {} ->                 BasicOp $ Copy arr               ArrayVar {} ->

@@ -413,6 +413,7 @@       DimSlice (j + (s0 * i)) n (s0 * s1) : sliceSlice' js' is'     sliceSlice' _ _ = [] +-- | A dimension in a 'FlatSlice'. data FlatDimIndex d   = FlatDimIndex       d@@ -430,6 +431,10 @@ instance Foldable FlatDimIndex where   foldMap = foldMapDefault +-- | A flat slice is a way of viewing a one-dimensional array as a+-- multi-dimensional array, using a more compressed mechanism than+-- reshaping and using 'Slice'.  The initial @d@ is an offset, and the+-- list then specifies the shape of the resulting array. data FlatSlice d = FlatSlice d [FlatDimIndex d]   deriving (Eq, Ord, Show) @@ -443,11 +448,13 @@ instance Foldable FlatSlice where   foldMap = foldMapDefault +-- | The dimensions (shape) of the view produced by a flat slice. flatSliceDims :: FlatSlice d -> [d] flatSliceDims (FlatSlice _ ds) = map dimSlice ds   where     dimSlice (FlatDimIndex n _) = n +-- | The strides of each dimension produced by a flat slice. flatSliceStrides :: FlatSlice d -> [d] flatSliceStrides (FlatSlice _ ds) = map dimStride ds   where

@@ -228,7 +228,7 @@   let index v = do         v_t <- lookupType v         return $ I.BasicOp $ I.Index v $ fullSlice v_t idxs'-  certifying cs $ letSubExps desc =<< mapM index vs+  certifying cs $ mapM (letSubExp desc <=< index) vs internaliseAppExp desc _ (E.Range start maybe_second end loc) = do   start' <- internaliseExp1 "range_start" start   end' <- internaliseExp1 "range_end" $ case end of@@ -676,7 +676,7 @@               ks           return $ I.BasicOp $ I.ArrayLit ks' rt -    letSubExps desc+    mapM (letSubExp desc)       =<< if null es'         then mapM (arraylit []) rowtypes         else zipWithM arraylit (transpose es') rowtypes@@ -1333,7 +1333,7 @@   InternaliseM [I.SubExp] internaliseOperation s e op = do   vs <- internaliseExpToVars s e-  letSubExps s =<< mapM (fmap I.BasicOp . op) vs+  mapM (letSubExp s . I.BasicOp <=< op) vs  certifyingNonzero ::   SrcLoc ->@@ -1788,7 +1788,7 @@        let conc xarr yarr =             I.BasicOp $ I.Concat 0 (xarr :| [yarr]) ressize-      letSubExps desc $ zipWith conc xs ys+      mapM (letSubExp desc) $ zipWith conc xs ys     handleRest [TupLit [offset, e] _] "rotate" = Just $ \desc -> do       offset' <- internaliseExp1 "rotation_offset" offset       internaliseOperation desc e $ \v -> do

@@ -668,6 +668,13 @@       -- possible.       isNotHoistableBnd _ _ (Let _ _ (BasicOp ArrayLit {})) = False       isNotHoistableBnd _ _ (Let _ _ (BasicOp SubExp {})) = False+      -- Hoist things that are free.+      isNotHoistableBnd _ _ (Let _ _ (BasicOp Reshape {})) = False+      isNotHoistableBnd _ _ (Let _ _ (BasicOp Rearrange {})) = False+      isNotHoistableBnd _ _ (Let _ _ (BasicOp Rotate {})) = False+      isNotHoistableBnd _ _ (Let _ _ (BasicOp (Index _ slice))) =+        null $ sliceDims slice+      --       isNotHoistableBnd _ usage (Let pat _ _)         | any (`UT.isSize` usage) $ patNames pat =           False@@ -679,9 +686,10 @@        block =         branch_blocker-          `orIf` ((isNotSafe `orIf` isNotCheap) `andAlso` stmIs (not . desirableToHoist))+          `orIf` ( (isNotSafe `orIf` isNotCheap `orIf` isNotHoistableBnd)+                     `andAlso` stmIs (not . desirableToHoist)+                 )           `orIf` isConsuming-          `orIf` isNotHoistableBnd    (hoisted1, body1') <-     protectIfHoisted cond True $

@@ -203,11 +203,9 @@   Exp (Wise rep) ->   Pat (LetDec (Wise rep)) addWisdomToPat pat e =-  Pat $ map f $ Aliases.mkPatAliases pat e+  f <$> Aliases.mkAliasedPat pat e   where-    f pe =-      let (als, dec) = patElemDec pe-       in pe `setPatElemDec` (VarWisdom als, dec)+    f (als, dec) = (VarWisdom als, dec)  mkWiseBody ::   (ASTRep rep, CanBeWise (Op rep)) =>@@ -223,7 +221,7 @@     stms     res   where-    (aliases, consumed) = Aliases.mkBodyAliases stms res+    (aliases, consumed) = Aliases.mkBodyAliasing stms res  mkWiseLetStm ::   (ASTRep rep, CanBeWise (Op rep)) =>

@@ -205,8 +205,8 @@   let types = map snd names_and_types       vs_types = map (V.valueTypeTextNoDims . V.valueType) vs   unless (types == vs_types) . throwError . T.unlines $-    [ "Expected input of types: " <> prettyTextOneLine types,-      "Provided input of types: " <> prettyTextOneLine vs_types+    [ "Expected input of types: " <> T.unwords (map prettyTextOneLine types),+      "Provided input of types: " <> T.unwords (map prettyTextOneLine vs_types)     ]   cmdMaybe . withSystemTempFile "futhark-input" $ \tmpf tmpf_h -> do     mapM_ (BS.hPutStr tmpf_h . Bin.encode) vs

@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ -- | Interface to the Futhark parser. module Language.Futhark.Parser   ( parseFuthark,@@ -7,7 +9,7 @@     parseValue,     parseValues,     parseDecOrExpIncrM,-    ParseError,+    SyntaxError (..),   ) where @@ -21,7 +23,7 @@ parseFuthark ::   FilePath ->   T.Text ->-  Either ParseError UncheckedProg+  Either SyntaxError UncheckedProg parseFuthark = parse prog  -- | Parse an Futhark expression from the given 'String', using the@@ -29,7 +31,7 @@ parseExp ::   FilePath ->   T.Text ->-  Either ParseError UncheckedExp+  Either SyntaxError UncheckedExp parseExp = parse expression  -- | Parse a Futhark module expression from the given 'String', using the@@ -37,7 +39,7 @@ parseModExp ::   FilePath ->   T.Text ->-  Either ParseError (ModExpBase NoInfo Name)+  Either SyntaxError (ModExpBase NoInfo Name) parseModExp = parse modExpression  -- | Parse an Futhark type from the given 'String', using the@@ -45,7 +47,7 @@ parseType ::   FilePath ->   T.Text ->-  Either ParseError UncheckedTypeExp+  Either SyntaxError UncheckedTypeExp parseType = parse futharkType  -- | Parse any Futhark value from the given 'String', using the 'FilePath'@@ -53,7 +55,7 @@ parseValue ::   FilePath ->   T.Text ->-  Either ParseError Value+  Either SyntaxError Value parseValue = parse anyValue  -- | Parse several Futhark values (separated by anything) from the given@@ -62,5 +64,32 @@ parseValues ::   FilePath ->   T.Text ->-  Either ParseError [Value]+  Either SyntaxError [Value] parseValues = parse anyValues++-- | Parse an Futhark expression incrementally from monadic actions, using the+-- 'FilePath' as the source name for error messages.+parseExpIncrM ::+  Monad m =>+  m T.Text ->+  FilePath ->+  T.Text ->+  m (Either SyntaxError UncheckedExp)+parseExpIncrM fetch file program =+  getLinesFromM fetch $ parseInMonad expression file program++-- | Parse either an expression or a declaration incrementally;+-- favouring declarations in case of ambiguity.+parseDecOrExpIncrM ::+  Monad m =>+  m T.Text ->+  FilePath ->+  T.Text ->+  m (Either SyntaxError (Either UncheckedDec UncheckedExp))+parseDecOrExpIncrM fetch file input =+  case parseInMonad declaration file input of+    Value Left {} -> fmap Right <$> parseExpIncrM fetch file input+    Value (Right d) -> pure $ Right $ Left d+    GetLine _ -> do+      l <- fetch+      parseDecOrExpIncrM fetch file $ input <> "\n" <> l

@@ -6,11 +6,11 @@ -- | The Futhark lexer.  Takes a string, produces a list of tokens with position information. module Language.Futhark.Parser.Lexer   ( Token(..)-  , L(..)   , scanTokens   , scanTokensText   ) where +import Data.Bifunctor (second) import qualified Data.ByteString.Lazy as BS import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -18,6 +18,7 @@ import Data.Char (ord, toLower, digitToInt) import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word8)+import Data.Loc (Loc (..), L(..), Pos(..)) import Data.Bits import Data.Function (fix) import Data.List@@ -30,12 +31,13 @@                               Name, nameFromText, nameToText) import Language.Futhark.Prop (leadingOperator) import Language.Futhark.Syntax (BinOp(..))-import Futhark.Util.Loc hiding (L)+import Language.Futhark.Parser.Lexer.Wrapper+import Language.Futhark.Parser.Lexer.Tokens+import qualified Data.ByteString.Internal as ByteString (w2c)+import qualified Data.ByteString.Lazy as ByteString  } -%wrapper "monad-bytestring"- @charlit = ($printable#['\\]|\\($printable|[0-9]+)) @stringcharlit = ($printable#[\"\\]|\\($printable|[0-9]+)) @hexlit = 0[xX][0-9a-fA-F][0-9a-fA-F_]*@@ -117,9 +119,9 @@   \" @stringcharlit* \"    { tokenM $ fmap (STRINGLIT . T.pack) . tryRead "string"  }    @identifier              { tokenS keyword }-  @identifier "["          { tokenM $ fmap INDEXING . indexing . T.takeWhile (/='[') }+  @identifier "["          { tokenPosM $ fmap INDEXING . indexing . second (T.takeWhile (/='[')) }   @qualidentifier "["      { tokenM $ fmap (uncurry QUALINDEXING) . mkQualId . T.takeWhile (/='[') }-  @identifier "." "("      { tokenM $ fmap (QUALPAREN []) . indexing . T.init . T.takeWhile (/='(') }+  @identifier "." "("      { tokenPosM $ fmap (QUALPAREN []) . indexing . second (T.init . T.takeWhile (/='(')) }   @qualidentifier "." "("  { tokenM $ fmap (uncurry QUALPAREN) . mkQualId . T.init . T.takeWhile (/='(') }   "#" @identifier          { tokenS $ CONSTRUCTOR . nameFromText . T.drop 1 } @@ -129,291 +131,36 @@   "." [0-9]+               { tokenS $ PROJ_INTFIELD . nameFromText . T.drop 1 } { -keyword :: T.Text -> Token-keyword s =-  case s of-    "true"         -> TRUE-    "false"        -> FALSE-    "if"           -> IF-    "then"         -> THEN-    "else"         -> ELSE-    "def"          -> DEF-    "let"          -> LET-    "loop"         -> LOOP-    "in"           -> IN-    "val"          -> VAL-    "for"          -> FOR-    "do"           -> DO-    "with"         -> WITH-    "local"        -> LOCAL-    "open"         -> OPEN-    "include"      -> INCLUDE-    "import"       -> IMPORT-    "type"         -> TYPE-    "entry"        -> ENTRY-    "module"       -> MODULE-    "while"        -> WHILE-    "assert"       -> ASSERT-    "match"        -> MATCH-    "case"         -> CASE--    _              -> ID $ nameFromText s--indexing :: T.Text -> Alex Name-indexing s = case keyword s of-  ID v -> return v-  _    -> alexError $ "Cannot index keyword '" ++ T.unpack s ++ "'."--mkQualId :: T.Text -> Alex ([Name], Name)-mkQualId s = case reverse $ T.splitOn "." s of-  []   -> error "mkQualId: no components"-  k:qs -> return (map nameFromText (reverse qs), nameFromText k)---- | Suffix a zero if the last character is dot.-suffZero :: T.Text -> T.Text-suffZero s = if T.last s == '.' then s <> "0" else s--tryRead :: Read a => String -> T.Text -> Alex a-tryRead desc s = case reads s' of-  [(x, "")] -> return x-  _         -> error $ "Invalid " ++ desc ++ " literal: `" ++ T.unpack s ++ "'."-  where s' = T.unpack s--readIntegral :: Integral a => T.Text -> a-readIntegral s-  | "0x" `T.isPrefixOf` s || "0X" `T.isPrefixOf` s = parseBase 16 (T.drop 2 s)-  | "0b" `T.isPrefixOf` s || "0B" `T.isPrefixOf` s = parseBase 2 (T.drop 2 s)-  | "0r" `T.isPrefixOf` s || "0R" `T.isPrefixOf` s = fromRoman (T.drop 2 s)-  | otherwise = parseBase 10 s-      where parseBase base = T.foldl (\acc c -> acc * base + fromIntegral (digitToInt c)) 0--tokenC v  = tokenS $ const v--tokenS f = tokenM $ return . f--type Lexeme a = ((Int, Int, Int), (Int, Int, Int), a)--tokenM :: (T.Text -> Alex a)-       -> (AlexPosn, Char, ByteString.ByteString, Int64)-       -> Int64-       -> Alex (Lexeme a)-tokenM f (AlexPn addr line col, _, s, _) len = do-  x <- f $ T.decodeUtf8 $ BS.toStrict s'-  return (pos, advance pos s', x)-  where pos = (line, col, addr)-        s' = BS.take len s--advance :: (Int, Int, Int) -> ByteString.ByteString -> (Int, Int, Int)-advance orig_pos = foldl' advance' orig_pos . init . ByteString.unpack-  where advance' (!line, !col, !addr) c-          | c == nl   = (line + 1, 1, addr + 1)-          | otherwise = (line, col + 1, addr + 1)-        nl = fromIntegral $ ord '\n'--symbol :: [Name] -> Name -> Token-symbol [] q-  | nameToText q == "*" = ASTERISK-  | nameToText q == "-" = NEGATE-  | nameToText q == "<" = LTH-  | nameToText q == "^" = HAT-  | nameToText q == "|" = PIPE-  | otherwise = SYMBOL (leadingOperator q) [] q-symbol qs q = SYMBOL (leadingOperator q) qs q---romanNumerals :: Integral a => [(T.Text,a)]-romanNumerals = reverse-                [ ("I",     1)-                , ("IV",    4)-                , ("V",     5)-                , ("IX",    9)-                , ("X",    10)-                , ("XL",   40)-                , ("L",    50)-                , ("XC",   90)-                , ("C",   100)-                , ("CD",  400)-                , ("D",   500)-                , ("CM",  900)-                , ("M",  1000)-                ]--fromRoman :: Integral a => T.Text -> a-fromRoman s =-  case find ((`T.isPrefixOf` s) . fst) romanNumerals of-    Nothing -> 0-    Just (d,n) -> n+fromRoman (T.drop (T.length d) s)--readHexRealLit :: RealFloat a => T.Text -> Alex a-readHexRealLit s =-  let num =  (T.drop 2 s) in-  -- extract number into integer, fractional and (optional) exponent-  let comps = T.split (`elem` ['.','p','P']) num in-  case comps of-    [i, f, p] ->-        let runTextReader r = fromIntegral . fst . fromRight (error "internal error") . r-            intPart = runTextReader T.hexadecimal i-            fracPart = runTextReader T.hexadecimal f-            exponent = runTextReader (T.signed T.decimal) p--            fracLen = fromIntegral $ T.length f-            fracVal = fracPart / (16.0 ** fracLen)-            totalVal = (intPart + fracVal) * (2.0 ** exponent) in-        return totalVal-    _ -> error "bad hex real literal"--alexGetPosn :: Alex (Int, Int, Int)-alexGetPosn = Alex $ \s ->-  let (AlexPn off line col) = alex_pos s-  in Right (s, (line, col, off))--alexEOF = do-  posn <- alexGetPosn-  return (posn, posn, EOF)---- | A value tagged with a source location.-data L a = L SrcLoc a deriving (Show)--instance Eq a => Eq (L a) where-  L _ x == L _ y = x == y--instance Located (L a) where-  locOf (L (SrcLoc loc) _) = loc---- | A lexical token.  It does not itself contain position--- information, so in practice the parser will consume tokens tagged--- with a source position.-data Token = ID Name-           | INDEXING Name-           | QUALINDEXING [Name] Name-           | QUALPAREN [Name] Name-           | SYMBOL BinOp [Name] Name-           | CONSTRUCTOR Name-           | PROJ_INTFIELD Name--           | INTLIT Integer-           | STRINGLIT T.Text-           | I8LIT Int8-           | I16LIT Int16-           | I32LIT Int32-           | I64LIT Int64-           | U8LIT Word8-           | U16LIT Word16-           | U32LIT Word32-           | U64LIT Word64-           | FLOATLIT Double-           | F16LIT Half-           | F32LIT Float-           | F64LIT Double-           | CHARLIT Char--           | COLON-           | COLON_GT-           | BACKSLASH-           | APOSTROPHE-           | APOSTROPHE_THEN_HAT-           | APOSTROPHE_THEN_TILDE-           | BACKTICK-           | HASH_LBRACKET-           | DOT-           | TWO_DOTS-           | TWO_DOTS_LT-           | TWO_DOTS_GT-           | THREE_DOTS-           | LPAR-           | RPAR-           | RPAR_THEN_LBRACKET-           | LBRACKET-           | RBRACKET-           | LCURLY-           | RCURLY-           | COMMA-           | UNDERSCORE-           | RIGHT_ARROW-           | QUESTION_MARK--           | EQU-           | ASTERISK-           | NEGATE-           | BANG-           | DOLLAR-           | LTH-           | HAT-           | TILDE-           | PIPE--           | IF-           | THEN-           | ELSE-           | DEF-           | LET-           | LOOP-           | IN-           | FOR-           | DO-           | WITH-           | ASSERT-           | TRUE-           | FALSE-           | WHILE-           | INCLUDE-           | IMPORT-           | ENTRY-           | TYPE-           | MODULE-           | VAL-           | OPEN-           | LOCAL-           | MATCH-           | CASE--           | DOC String--           | EOF--             deriving (Show, Eq, Ord)--runAlex' :: AlexPosn -> ByteString.ByteString -> Alex a -> Either String a-runAlex' start_pos input__ (Alex f) =-  case f (AlexState { alex_pos = start_pos-                    , alex_bpos = 0-                    , alex_inp = input__-                    , alex_chr = '\n'-                    , alex_scd = 0}) of Left msg -> Left msg-                                        Right ( _, a ) -> Right a---getToken :: FilePath -> Alex (Lexeme Token)-getToken file = do-  inp__@(_,_,_,n) <- alexGetInput+getToken :: Alex (Lexeme Token)+getToken = do+  inp@(_,_,_,n) <- alexGetInput   sc <- alexGetStartCode-  case alexScan inp__ sc of-    AlexEOF -> alexEOF-    AlexError ((AlexPn _ line column),_,_,_) ->-      alexError $ "Error at " ++ file ++ ":" ++ show line ++ ":" ++ show column ++ ": lexical error."-    AlexSkip  inp__' _len -> do-      alexSetInput inp__'-      getToken file-    AlexToken inp__'@(_,_,_,n') _ action -> let len = n'-n in do-      alexSetInput inp__'-      action (ignorePendingBytes inp__) len---- | Given a starting position, produce tokens from the given text (or--- a lexer error).  Returns the final position.-scanTokensText :: Pos -> T.Text -> Either String ([L Token], Pos)-scanTokensText pos = scanTokens pos . BS.fromStrict . T.encodeUtf8+  case alexScan inp sc of+    AlexEOF -> do pos <- alexGetPos+                  pure (pos, pos, EOF)+    AlexError (pos,_,_,_) ->+      alexError (Loc pos pos) "Invalid lexical syntax."+    AlexSkip  inp' _len -> do+      alexSetInput inp'+      getToken+    AlexToken inp'@(_,_,_,n') _ action -> let len = n'-n in do+      alexSetInput inp'+      action inp len -scanTokens :: Pos -> BS.ByteString -> Either String ([L Token], Pos)-scanTokens (Pos file start_line start_col start_off) str =-  runAlex' (AlexPn start_off start_line start_col) str $ do+scanTokens :: Pos -> BS.ByteString -> Either LexerError ([L Token], Pos)+scanTokens pos str =+  runAlex' pos str $ do   fix $ \loop -> do-    tok <- getToken file+    tok <- getToken     case tok of       (start, end, EOF) ->-        return ([], posnToPos end)+        pure ([], end)       (start, end, t) -> do         (rest, endpos) <- loop-        return (L (pos start end) t : rest, endpos)-  where pos start end = SrcLoc $ Loc (posnToPos start) (posnToPos end)-        posnToPos (line, col, off) = Pos file line col off+        pure (L (Loc start end) t : rest, endpos)++-- | Given a starting position, produce tokens from the given text (or+-- a lexer error).  Returns the final position.+scanTokensText :: Pos -> T.Text -> Either LexerError ([L Token], Pos)+scanTokensText pos = scanTokens pos . BS.fromStrict . T.encodeUtf8 }

@@ -0,0 +1,283 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Strict #-}++-- | Definition of the tokens used in the lexer.+--+-- Also defines other useful building blocks for constructing tokens.+module Language.Futhark.Parser.Lexer.Tokens+  ( Token (..),+    Lexeme,+    fromRoman,+    symbol,+    mkQualId,+    tokenPosM,+    tokenM,+    tokenC,+    keyword,+    tokenS,+    indexing,+    suffZero,+    tryRead,+    readIntegral,+    readHexRealLit,+  )+where++import qualified Data.ByteString.Lazy as BS+import Data.Char (digitToInt, ord)+import Data.Either+import Data.List (find, foldl')+import Data.Loc (Loc (..), Pos (..))+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Read as T+import Language.Futhark.Core+  ( Int16,+    Int32,+    Int64,+    Int8,+    Name,+    Word16,+    Word32,+    Word64,+    Word8,+  )+import Language.Futhark.Parser.Lexer.Wrapper+import Language.Futhark.Prop (leadingOperator)+import Language.Futhark.Syntax (BinOp, nameFromText, nameToText)+import Numeric.Half+import Prelude hiding (exponent)++-- | A lexical token.  It does not itself contain position+-- information, so in practice the parser will consume tokens tagged+-- with a source position.+data Token+  = ID Name+  | INDEXING Name+  | QUALINDEXING [Name] Name+  | QUALPAREN [Name] Name+  | SYMBOL BinOp [Name] Name+  | CONSTRUCTOR Name+  | PROJ_INTFIELD Name+  | INTLIT Integer+  | STRINGLIT T.Text+  | I8LIT Int8+  | I16LIT Int16+  | I32LIT Int32+  | I64LIT Int64+  | U8LIT Word8+  | U16LIT Word16+  | U32LIT Word32+  | U64LIT Word64+  | FLOATLIT Double+  | F16LIT Half+  | F32LIT Float+  | F64LIT Double+  | CHARLIT Char+  | COLON+  | COLON_GT+  | BACKSLASH+  | APOSTROPHE+  | APOSTROPHE_THEN_HAT+  | APOSTROPHE_THEN_TILDE+  | BACKTICK+  | HASH_LBRACKET+  | DOT+  | TWO_DOTS+  | TWO_DOTS_LT+  | TWO_DOTS_GT+  | THREE_DOTS+  | LPAR+  | RPAR+  | RPAR_THEN_LBRACKET+  | LBRACKET+  | RBRACKET+  | LCURLY+  | RCURLY+  | COMMA+  | UNDERSCORE+  | RIGHT_ARROW+  | QUESTION_MARK+  | EQU+  | ASTERISK+  | NEGATE+  | BANG+  | DOLLAR+  | LTH+  | HAT+  | TILDE+  | PIPE+  | IF+  | THEN+  | ELSE+  | DEF+  | LET+  | LOOP+  | IN+  | FOR+  | DO+  | WITH+  | ASSERT+  | TRUE+  | FALSE+  | WHILE+  | INCLUDE+  | IMPORT+  | ENTRY+  | TYPE+  | MODULE+  | VAL+  | OPEN+  | LOCAL+  | MATCH+  | CASE+  | DOC String+  | EOF+  deriving (Show, Eq, Ord)++keyword :: T.Text -> Token+keyword s =+  case s of+    "true" -> TRUE+    "false" -> FALSE+    "if" -> IF+    "then" -> THEN+    "else" -> ELSE+    "def" -> DEF+    "let" -> LET+    "loop" -> LOOP+    "in" -> IN+    "val" -> VAL+    "for" -> FOR+    "do" -> DO+    "with" -> WITH+    "local" -> LOCAL+    "open" -> OPEN+    "include" -> INCLUDE+    "import" -> IMPORT+    "type" -> TYPE+    "entry" -> ENTRY+    "module" -> MODULE+    "while" -> WHILE+    "assert" -> ASSERT+    "match" -> MATCH+    "case" -> CASE+    _ -> ID $ nameFromText s++indexing :: (Loc, T.Text) -> Alex Name+indexing (loc, s) = case keyword s of+  ID v -> return v+  _ -> alexError loc $ "Cannot index keyword '" ++ T.unpack s ++ "'."++mkQualId :: T.Text -> Alex ([Name], Name)+mkQualId s = case reverse $ T.splitOn "." s of+  [] -> error "mkQualId: no components"+  k : qs -> return (map nameFromText (reverse qs), nameFromText k)++-- | Suffix a zero if the last character is dot.+suffZero :: T.Text -> T.Text+suffZero s = if T.last s == '.' then s <> "0" else s++tryRead :: Read a => String -> T.Text -> Alex a+tryRead desc s = case reads s' of+  [(x, "")] -> return x+  _ -> error $ "Invalid " ++ desc ++ " literal: `" ++ T.unpack s ++ "'."+  where+    s' = T.unpack s++readIntegral :: Integral a => T.Text -> a+readIntegral s+  | "0x" `T.isPrefixOf` s || "0X" `T.isPrefixOf` s = parseBase 16 (T.drop 2 s)+  | "0b" `T.isPrefixOf` s || "0B" `T.isPrefixOf` s = parseBase 2 (T.drop 2 s)+  | "0r" `T.isPrefixOf` s || "0R" `T.isPrefixOf` s = fromRoman (T.drop 2 s)+  | otherwise = parseBase 10 s+  where+    parseBase base = T.foldl (\acc c -> acc * base + fromIntegral (digitToInt c)) 0++tokenC :: a -> (Pos, Char, BS.ByteString, Int64) -> Int64 -> Alex (Lexeme a)+tokenC v = tokenS $ const v++tokenS :: (T.Text -> a) -> (Pos, Char, BS.ByteString, Int64) -> Int64 -> Alex (Lexeme a)+tokenS f = tokenM $ return . f++type Lexeme a = (Pos, Pos, a)++tokenM ::+  (T.Text -> Alex a) ->+  (Pos, Char, BS.ByteString, Int64) ->+  Int64 ->+  Alex (Lexeme a)+tokenM f = tokenPosM (f . snd)++tokenPosM ::+  ((Loc, T.Text) -> Alex a) ->+  (Pos, Char, BS.ByteString, Int64) ->+  Int64 ->+  Alex (Lexeme a)+tokenPosM f (pos, _, s, _) len = do+  x <- f (Loc pos pos', T.decodeUtf8 $ BS.toStrict s')+  return (pos, pos', x)+  where+    pos' = advance pos s'+    s' = BS.take len s++advance :: Pos -> BS.ByteString -> Pos+advance orig_pos = foldl' advance' orig_pos . init . BS.unpack+  where+    advance' (Pos f !line !col !addr) c+      | c == nl = Pos f (line + 1) 1 (addr + 1)+      | otherwise = Pos f line (col + 1) (addr + 1)+    nl = fromIntegral $ ord '\n'++symbol :: [Name] -> Name -> Token+symbol [] q+  | nameToText q == "*" = ASTERISK+  | nameToText q == "-" = NEGATE+  | nameToText q == "<" = LTH+  | nameToText q == "^" = HAT+  | nameToText q == "|" = PIPE+  | otherwise = SYMBOL (leadingOperator q) [] q+symbol qs q = SYMBOL (leadingOperator q) qs q++romanNumerals :: Integral a => [(T.Text, a)]+romanNumerals =+  reverse+    [ ("I", 1),+      ("IV", 4),+      ("V", 5),+      ("IX", 9),+      ("X", 10),+      ("XL", 40),+      ("L", 50),+      ("XC", 90),+      ("C", 100),+      ("CD", 400),+      ("D", 500),+      ("CM", 900),+      ("M", 1000)+    ]++fromRoman :: Integral a => T.Text -> a+fromRoman s =+  case find ((`T.isPrefixOf` s) . fst) romanNumerals of+    Nothing -> 0+    Just (d, n) -> n + fromRoman (T.drop (T.length d) s)++readHexRealLit :: RealFloat a => T.Text -> Alex a+readHexRealLit s =+  let num = T.drop 2 s+   in -- extract number into integer, fractional and (optional) exponent+      let comps = T.split (`elem` ['.', 'p', 'P']) num+       in case comps of+            [i, f, p] ->+              let runTextReader r = fromInteger . fst . fromRight (error "internal error") . r+                  intPart = runTextReader T.hexadecimal i+                  fracPart = runTextReader T.hexadecimal f+                  exponent = runTextReader (T.signed T.decimal) p++                  fracLen = fromIntegral $ T.length f+                  fracVal = fracPart / (16.0 ** fracLen)+                  totalVal = (intPart + fracVal) * (2.0 ** exponent)+               in return totalVal+            _ -> error "bad hex real literal"

@@ -0,0 +1,137 @@+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}++-- | Utility definitions used by the lexer.  None of the default Alex+-- "wrappers" are precisely what we need.  The code here is based on+-- the "monad-bytestring" wrapper.  The code here is completely+-- Futhark-agnostic, and perhaps it can even serve as inspiration for+-- other Alex lexer wrappers.+module Language.Futhark.Parser.Lexer.Wrapper+  ( runAlex',+    Alex,+    AlexInput,+    Byte,+    LexerError (..),+    alexSetInput,+    alexGetInput,+    alexGetByte,+    alexGetStartCode,+    alexMove,+    alexError,+    alexGetPos,+  )+where++import Control.Applicative (liftA)+import qualified Data.ByteString.Internal as BS (w2c)+import qualified Data.ByteString.Lazy as BS+import Data.Int (Int64)+import Data.Loc (Loc, Pos (..))+import Data.Word (Word8)++type Byte = Word8++-- | The input type.  Contains:+--+-- 1. current position+--+-- 2. previous char+--+-- 3. current input string+--+-- 4. bytes consumed so far+type AlexInput =+  ( Pos, -- current position,+    Char, -- previous char+    BS.ByteString, -- current input string+    Int64 -- bytes consumed so far+  )++{-# INLINE alexGetByte #-}+alexGetByte :: AlexInput -> Maybe (Byte, AlexInput)+alexGetByte (p, _, cs, n) =+  case BS.uncons cs of+    Nothing -> Nothing+    Just (b, cs') ->+      let c = BS.w2c b+          p' = alexMove p c+          n' = n + 1+       in p' `seq` cs' `seq` n' `seq` Just (b, (p', c, cs', n'))++tabSize :: Int+tabSize = 8++{-# INLINE alexMove #-}+alexMove :: Pos -> Char -> Pos+alexMove (Pos !f !l !c !a) '\t' = Pos f l (c + tabSize - ((c - 1) `mod` tabSize)) (a + 1)+alexMove (Pos !f !l _ !a) '\n' = Pos f (l + 1) 1 (a + 1)+alexMove (Pos !f !l !c !a) _ = Pos f l (c + 1) (a + 1)++data AlexState = AlexState+  { alex_pos :: !Pos, -- position at current input location+    alex_bpos :: !Int64, -- bytes consumed so far+    alex_inp :: BS.ByteString, -- the current input+    alex_chr :: !Char, -- the character before the input+    alex_scd :: !Int -- the current startcode+  }++runAlex' :: Pos -> BS.ByteString -> Alex a -> Either LexerError a+runAlex' start_pos input__ (Alex f) =+  case f+    ( AlexState+        { alex_pos = start_pos,+          alex_bpos = 0,+          alex_inp = input__,+          alex_chr = '\n',+          alex_scd = 0+        }+    ) of+    Left msg -> Left msg+    Right (_, a) -> Right a++newtype Alex a = Alex {unAlex :: AlexState -> Either LexerError (AlexState, a)}++data LexerError = LexerError Loc String++instance Show LexerError where+  show (LexerError _ s) = s++instance Functor Alex where+  fmap = liftA++instance Applicative Alex where+  pure a = Alex $ \s -> Right (s, a)+  fa <*> a = Alex $ \s -> case unAlex fa s of+    Left msg -> Left msg+    Right (s', f) -> case unAlex a s' of+      Left msg -> Left msg+      Right (s'', b) -> Right (s'', f b)++instance Monad Alex where+  m >>= k = Alex $ \s -> case unAlex m s of+    Left msg -> Left msg+    Right (s', a) -> unAlex (k a) s'++alexGetInput :: Alex AlexInput+alexGetInput =+  Alex $ \s@AlexState {alex_pos = pos, alex_bpos = bpos, alex_chr = c, alex_inp = inp} ->+    Right (s, (pos, c, inp, bpos))++alexSetInput :: AlexInput -> Alex ()+alexSetInput (pos, c, inp, bpos) =+  Alex $ \s -> case s+    { alex_pos = pos,+      alex_bpos = bpos,+      alex_chr = c,+      alex_inp = inp+    } of+    state@AlexState {} -> Right (state, ())++alexError :: Loc -> String -> Alex a+alexError loc message = Alex $ const $ Left $ LexerError loc message++alexGetStartCode :: Alex Int+alexGetStartCode = Alex $ \s@AlexState {alex_scd = sc} -> Right (s, sc)++alexGetPos :: Alex Pos+alexGetPos = Alex $ \s -> Right (s, alex_pos s)

@@ -31,7 +31,7 @@     addDoc,     addAttr,     twoDotsRange,-    ParseError (..),+    SyntaxError (..),     emptyArrayError,     parseError,     parseErrorAt,@@ -50,9 +50,10 @@ import qualified Data.Map.Strict as M import Data.Monoid import qualified Data.Text as T-import Futhark.Util.Loc hiding (L) -- Lexer has replacements.+import Futhark.Util.Loc import Futhark.Util.Pretty hiding (line) import Language.Futhark.Parser.Lexer+import Language.Futhark.Parser.Lexer.Wrapper (LexerError (..)) import Language.Futhark.Pretty () import Language.Futhark.Prop import Language.Futhark.Syntax@@ -88,18 +89,19 @@   parseErrorAt loc . Just $     "Only the keyword '" <> expected <> "' may appear here." -mustBeEmpty :: SrcLoc -> ValueType -> ParserMonad ()+mustBeEmpty :: Located loc => loc -> ValueType -> ParserMonad () mustBeEmpty _ (Array _ _ _ (ShapeDecl dims))   | 0 `elem` dims = pure () mustBeEmpty loc t =   parseErrorAt loc $ Just $ pretty t ++ " is not an empty array." -newtype ParserEnv = ParserEnv-  { parserFile :: FilePath+data ParserEnv = ParserEnv+  { _parserFile :: FilePath,+    parserInput :: T.Text,+    parserLexical :: ([L Token], Pos)   } -type ParserMonad =-  ExceptT String (StateT ParserEnv (StateT ([L Token], Pos) ReadLineMonad))+type ParserMonad = ExceptT SyntaxError (StateT ParserEnv ReadLineMonad)  data ReadLineMonad a   = Value a@@ -126,23 +128,23 @@   s <- fetch   getLinesFromM fetch $ f $ Just s -getNoLines :: ReadLineMonad a -> Either String a+getNoLines :: ReadLineMonad a -> Either SyntaxError a getNoLines (Value x) = Right x getNoLines (GetLine f) = getNoLines $ f Nothing -combArrayElements :: Value -> [Value] -> Either String Value+combArrayElements :: Value -> [Value] -> Either SyntaxError Value combArrayElements = foldM comb   where     comb x y       | valueType x == valueType y = Right x       | otherwise =-        Left $+        Left . SyntaxError NoLoc $           "Elements " <> pretty x <> " and "             <> pretty y             <> " cannot exist in same array."  arrayFromList :: [a] -> Array Int a-arrayFromList l = listArray (0, length l -1) l+arrayFromList l = listArray (0, length l - 1) l  applyExp :: [UncheckedExp] -> ParserMonad UncheckedExp applyExp all_es@((Constr n [] _ loc1) : es) =@@ -173,24 +175,24 @@     field (name, pat) = RecordFieldExplicit name <$> patternExp pat <*> pure loc  eof :: Pos -> L Token-eof pos = L (SrcLoc $ Loc pos pos) EOF+eof pos = L (Loc pos pos) EOF -binOpName :: L Token -> (QualName Name, SrcLoc)+binOpName :: L Token -> (QualName Name, Loc) binOpName (L loc (SYMBOL _ qs op)) = (QualName qs op, loc) binOpName t = error $ "binOpName: unexpected " ++ show t  binOp :: UncheckedExp -> L Token -> UncheckedExp -> UncheckedExp binOp x (L loc (SYMBOL _ qs op)) y =-  AppExp (BinOp (QualName qs op, loc) NoInfo (x, NoInfo) (y, NoInfo) (srcspan x y)) NoInfo+  AppExp (BinOp (QualName qs op, srclocOf loc) NoInfo (x, NoInfo) (y, NoInfo) (srcspan x y)) NoInfo binOp _ t _ = error $ "binOp: unexpected " ++ show t  getTokens :: ParserMonad ([L Token], Pos)-getTokens = lift $ lift get+getTokens = lift $ gets parserLexical  putTokens :: ([L Token], Pos) -> ParserMonad ()-putTokens = lift . lift . put+putTokens l = lift $ modify $ \env -> env {parserLexical = l} -primTypeFromName :: SrcLoc -> Name -> ParserMonad PrimType+primTypeFromName :: Loc -> Name -> ParserMonad PrimType primTypeFromName loc s = maybe boom pure $ M.lookup s namesToPrimTypes   where     boom = parseErrorAt loc $ Just $ "No type named " ++ nameToString s@@ -213,7 +215,13 @@ primNegate (BoolValue v) = BoolValue $ not v  readLine :: ParserMonad (Maybe T.Text)-readLine = lift $ lift $ lift readLineFromMonad+readLine = do+  s <- lift $ lift readLineFromMonad+  case s of+    Just s' ->+      lift $ modify $ \env -> env {parserInput = parserInput env <> "\n" <> s'}+    Nothing -> pure ()+  pure s  lexer :: (L Token -> ParserMonad a) -> ParserMonad a lexer cont = do@@ -229,10 +237,7 @@             case line of               Nothing -> throwError parse_e               Just line' -> pure $ scanTokensText (advancePos pos '\n') line'-          (ts'', pos') <--            case ts' of-              Right x -> pure x-              Left lex_e -> throwError lex_e+          (ts'', pos') <- either (throwError . lexerErrToParseErr) pure ts'           case ts'' of             [] -> cont $ eof pos             xs -> do@@ -244,49 +249,51 @@  parseError :: (L Token, [String]) -> ParserMonad a parseError (L loc EOF, expected) =-  parseErrorAt (srclocOf loc) . Just . unlines $-    [ "unexpected end of file.",+  parseErrorAt (locOf loc) . Just . unlines $+    [ "Unexpected end of file.",       "Expected one of the following: " ++ unwords expected     ] parseError (L loc DOC {}, _) =-  parseErrorAt (srclocOf loc) $-    Just "documentation comments ('-- |') are only permitted when preceding declarations."-parseError (L loc tok, expected) =+  parseErrorAt (locOf loc) $+    Just "Documentation comments ('-- |') are only permitted when preceding declarations."+parseError (L loc _, expected) = do+  input <- lift $ gets parserInput+  let ~(Loc (Pos _ _ _ beg) (Pos _ _ _ end)) = locOf loc+      tok_src = T.take (end - beg + 1) $ T.drop beg input   parseErrorAt loc . Just . unlines $-    [ "unexpected " ++ show tok,-      "Expected one of the following: " ++ unwords expected+    [ "Unexpected token: '" <> T.unpack tok_src <> "'",+      "Expected one of the following: " <> unwords expected     ] -parseErrorAt :: SrcLoc -> Maybe String -> ParserMonad a-parseErrorAt loc Nothing = throwError $ "Error at " ++ locStr loc ++ ": Parse error."-parseErrorAt loc (Just s) = throwError $ "Error at " ++ locStr loc ++ ": " ++ s+parseErrorAt :: Located loc => loc -> Maybe String -> ParserMonad a+parseErrorAt loc Nothing = throwError $ SyntaxError (locOf loc) "Syntax error."+parseErrorAt loc (Just s) = throwError $ SyntaxError (locOf loc) s -emptyArrayError :: SrcLoc -> ParserMonad a+emptyArrayError :: Loc -> ParserMonad a emptyArrayError loc =   parseErrorAt loc $     Just "write empty arrays as 'empty(t)', for element type 't'.\n" -twoDotsRange :: SrcLoc -> ParserMonad a+twoDotsRange :: Loc -> ParserMonad a twoDotsRange loc = parseErrorAt loc $ Just "use '...' for ranges, not '..'.\n"  --- Now for the parser interface. --- | A parse error.  Use 'show' to get a human-readable description.-newtype ParseError = ParseError String+-- | A syntax error.+data SyntaxError = SyntaxError {syntaxErrorLoc :: Loc, syntaxErrorMsg :: String} -instance Show ParseError where-  show (ParseError s) = s+lexerErrToParseErr :: LexerError -> SyntaxError+lexerErrToParseErr (LexerError loc msg) = SyntaxError loc msg -parseInMonad :: ParserMonad a -> FilePath -> T.Text -> ReadLineMonad (Either ParseError a)+parseInMonad :: ParserMonad a -> FilePath -> T.Text -> ReadLineMonad (Either SyntaxError a) parseInMonad p file program =-  either (Left . ParseError) Right-    <$> either-      (pure . Left)-      (evalStateT (evalStateT (runExceptT p) env))-      (scanTokensText (Pos file 1 1 0) program)+  either+    (pure . Left . lexerErrToParseErr)+    (evalStateT (runExceptT p) . env)+    (scanTokensText (Pos file 1 1 0) program)   where-    env = ParserEnv {parserFile = file}+    env = ParserEnv file program -parse :: ParserMonad a -> FilePath -> T.Text -> Either ParseError a+parse :: ParserMonad a -> FilePath -> T.Text -> Either SyntaxError a parse p file program =-  either (Left . ParseError) id $ getNoLines $ parseInMonad p file program+  either Left id $ getNoLines $ parseInMonad p file program

@@ -6,16 +6,20 @@ module Language.Futhark.Parser.Parser   ( prog   , expression+  , declaration   , modExpression   , futharkType   , anyValue   , anyValues   , parse-  , ParseError(..)-  , parseDecOrExpIncrM+  , ReadLineMonad (..)+  , getLinesFromM+  , parseInMonad+  , SyntaxError(..)   )   where +import Data.Bifunctor (second) import Control.Monad import Control.Monad.Trans import Control.Monad.Except@@ -37,7 +41,7 @@ import Language.Futhark.Pretty import Language.Futhark.Parser.Lexer import Futhark.Util.Pretty-import Futhark.Util.Loc hiding (L) -- Lexer has replacements.+import Futhark.Util.Loc import Language.Futhark.Parser.Monad  }@@ -195,7 +199,7 @@ -- The main parser.  Doc :: { DocComment }-     : doc { let L loc (DOC s) = $1 in DocComment s loc }+     : doc { let L loc (DOC s) = $1 in DocComment s (srclocOf loc) }  -- Four cases to avoid ambiguities. Prog :: { UncheckedProg }@@ -222,7 +226,7 @@     | TypeAbbr          { TypeDec $1 }     | SigBind           { SigDec $1 }     | ModBind           { ModDec $1 }-    | open ModExp       { OpenDec $2 $1 }+    | open ModExp       { OpenDec $2 (srclocOf $1) }     | import stringlit       { let L _ (STRINGLIT s) = $2 in ImportDec (T.unpack s) NoInfo (srcspan $1 $>) }     | local Dec         { LocalDec $2 (srcspan $1 $>) }@@ -232,7 +236,7 @@ ;  SigExp :: { UncheckedSigExp }-        : QualName            { let (v, loc) = $1 in SigVar v NoInfo loc }+        : QualName            { let (v, loc) = $1 in SigVar v NoInfo (srclocOf loc) }         | '{' Specs '}'  { SigSpecs $2 (srcspan $1 $>) }         | SigExp with TypeRef { SigWith $1 $3 (srcspan $1 $>) }         | '(' SigExp ')'      { SigParens $2 (srcspan $1 $>) }@@ -273,11 +277,11 @@             : '(' ModExp ')'               { ModParens $2 (srcspan $1 $>) }             | QualName-              { let (v, loc) = $1 in ModVar v loc }+              { let (v, loc) = $1 in ModVar v (srclocOf loc) }             | '{' Decs '}' { ModDecs $2 (srcspan $1 $>) }  SimpleSigExp :: { UncheckedSigExp }-             : QualName            { let (v, loc) = $1 in SigVar v NoInfo loc }+             : QualName            { let (v, loc) = $1 in SigVar v NoInfo (srclocOf loc) }              | '(' SigExp ')'      { $2 }  ModBind :: { ModBindBase NoInfo Name }@@ -312,7 +316,7 @@           in TypeSpec $2 name $4 Nothing (srcspan $1 $>) }       | type Liftedness 'id[' id ']' TypeParams         { let L _ (INDEXING name) = $3; L ploc (ID pname) = $4-          in TypeSpec $2 name (TypeParamDim pname ploc : $6) Nothing (srcspan $1 $>) }+          in TypeSpec $2 name (TypeParamDim pname (srclocOf ploc) : $6) Nothing (srcspan $1 $>) }        | module id ':' SigExp         { let L _ (ID name) = $2@@ -347,7 +351,7 @@  -- Note that this production does not include Minus, but does include -- operator sections.-BinOp :: { (QualName Name, SrcLoc) }+BinOp :: { (QualName Name, Loc) }       : '+...'     { binOpName $1 }       | '-...'     { binOpName $1 }       | '*...'     { binOpName $1 }@@ -384,7 +388,7 @@                    pure name }       | '-'   { nameFromString "-" } -BindingId :: { (Name, SrcLoc) }+BindingId :: { (Name, Loc) }      : id                   { let L loc (ID name) = $1 in (name, loc) }      | '(' BindingBinOp ')' { ($2, $1) } @@ -416,6 +420,19 @@             Nothing mempty (srcspan $1 $>)           } +        -- Some error cases+        | def '(' Pat ',' Pats1 ')' '=' Exp+          {% parseErrorAt (srcspan $2 $6) $ Just $+             unlines ["Cannot bind patterns at top level.",+                      "Bind a single name instead."]+          }++        | let '(' Pat ',' Pats1 ')' '=' Exp+          {% parseErrorAt (srcspan $2 $6) $ Just $+             unlines ["Cannot bind patterns at top level.",+                      "Bind a single name instead."]+          }+ TypeExpDecl :: { TypeDeclBase NoInfo Name }              : TypeExp %prec bottom { TypeDecl $1 NoInfo } @@ -425,7 +442,7 @@               in TypeBind name $2 $4 $6 NoInfo Nothing (srcspan $1 $>) }          | type Liftedness 'id[' id ']' TypeParams '=' TypeExp            { let L loc (INDEXING name) = $3; L ploc (ID pname) = $4-             in TypeBind name $2 (TypeParamDim pname ploc:$6) $8 NoInfo Nothing (srcspan $1 $>) }+             in TypeBind name $2 (TypeParamDim pname (srclocOf ploc):$6) $8 NoInfo Nothing (srcspan $1 $>) }  TypeExp :: { UncheckedTypeExp }          : '(' id ':' TypeExp ')' '->' TypeExp@@ -454,18 +471,18 @@            }  SumType :: { UncheckedTypeExp }-SumType  : SumClauses %prec sumprec { let (cs, loc) = $1 in TESum cs loc }+SumType  : SumClauses %prec sumprec { let (cs, loc) = $1 in TESum cs (srclocOf loc) } -SumClauses :: { ([(Name, [UncheckedTypeExp])], SrcLoc) }+SumClauses :: { ([(Name, [UncheckedTypeExp])], Loc) }             : SumClauses '|' SumClause %prec sumprec               { let (cs, loc1) = $1; (c, ts, loc2) = $3-                in (cs++[(c, ts)], srcspan loc1 loc2) }+                in (cs++[(c, ts)], locOf (srcspan loc1 loc2)) }             | SumClause  %prec sumprec               { let (n, ts, loc) = $1 in ([(n, ts)], loc) } -SumClause :: { (Name, [UncheckedTypeExp], SrcLoc) }+SumClause :: { (Name, [UncheckedTypeExp], Loc) }            : SumClause TypeExpAtom-             { let (n, ts, loc) = $1 in (n, ts ++ [$2], srcspan loc $>)}+             { let (n, ts, loc) = $1 in (n, ts ++ [$2], locOf (srcspan loc $>))}            | Constr             { (fst $1, [], snd $1) } @@ -474,10 +491,10 @@                 { TEApply $1 $2 (srcspan $1 $>) }               | 'id[' DimExp ']'                 { let L loc (INDEXING v) = $1-                  in TEApply (TEVar (qualName v) loc) (TypeArgExpDim $2 loc) (srcspan $1 $>) }+                  in TEApply (TEVar (qualName v) (srclocOf loc)) (TypeArgExpDim $2 (srclocOf loc)) (srcspan $1 $>) }               | 'qid[' DimExp ']'                 { let L loc (QUALINDEXING qs v) = $1-                  in TEApply (TEVar (QualName qs v) loc) (TypeArgExpDim $2 loc) (srcspan $1 $>) }+                  in TEApply (TEVar (QualName qs v) (srclocOf loc)) (TypeArgExpDim $2 (srclocOf loc)) (srcspan $1 $>) }               | TypeExpAtom                 { $1 } @@ -487,11 +504,11 @@              | '(' TypeExp ',' TupleTypes ')' { TETuple ($2:$4) (srcspan $1 $>) }              | '{' '}'                        { TERecord [] (srcspan $1 $>) }              | '{' FieldTypes1 '}'            { TERecord $2 (srcspan $1 $>) }-             | QualName                       { TEVar (fst $1) (snd $1) }+             | QualName                       { TEVar (fst $1) (srclocOf (snd $1)) }              | SumType                        { $1 } -Constr :: { (Name, SrcLoc) }-        : constructor { let L _ (CONSTRUCTOR c) = $1 in (c, srclocOf $1) }+Constr :: { (Name, Loc) }+        : constructor { let L _ (CONSTRUCTOR c) = $1 in (c, locOf $1) }  TypeArg :: { TypeArgExp Name }          : '[' DimExp ']' { TypeArgExpDim $2 (srcspan $1 $>) }@@ -510,10 +527,10 @@  DimExp :: { DimExp Name }         : QualName-          { DimExpNamed (fst $1) (snd $1) }+          { DimExpNamed (fst $1) (srclocOf (snd $1)) }         | intlit           { let L loc (INTLIT n) = $1-            in DimExpConst (fromIntegral n) loc }+            in DimExpConst (fromIntegral n) (srclocOf loc) }         |           { DimExpAny } @@ -528,12 +545,12 @@ FunParams :                     { [] }            | FunParam FunParams { $1 : $2 } -QualName :: { (QualName Name, SrcLoc) }+QualName :: { (QualName Name, Loc) }           : id FieldAccesses             { let L vloc (ID v) = $1 in               foldl (\(QualName qs v', loc) (y, yloc) ->-                      (QualName (qs ++ [v']) y, srcspan loc yloc))-                    (qualName v, vloc) $2 }+                      (QualName (qs ++ [v']) y, locOf (srcspan loc yloc)))+                    (qualName v, locOf vloc) $2 }  -- Expressions are divided into several layers.  The first distinction -- (between Exp and Exp2) is to factor out ascription, which we do not@@ -591,7 +608,7 @@      | Exp2 '<|...' Exp2   { binOp $1 $2 $3 }       | Exp2 '<' Exp2              { binOp $1 (L $2 (SYMBOL Less [] (nameFromString "<"))) $3 }-     | Exp2 '`' QualName '`' Exp2 { AppExp (BinOp $3 NoInfo ($1, NoInfo) ($5, NoInfo) (srcspan $1 $>)) NoInfo }+     | Exp2 '`' QualName '`' Exp2 { AppExp (BinOp (second srclocOf $3) NoInfo ($1, NoInfo) ($5, NoInfo) (srcspan $1 $>)) NoInfo }       | Exp2 '...' Exp2           { AppExp (Range $1 Nothing (ToInclusive $3) (srcspan $1 $>)) NoInfo }      | Exp2 '..<' Exp2           { AppExp (Range $1 Nothing (UpToExclusive $3) (srcspan $1 $>)) NoInfo }@@ -601,8 +618,8 @@      | Exp2 '..' Exp2 '..>' Exp2 { AppExp (Range $1 (Just $3) (DownToExclusive $5) (srcspan $1 $>)) NoInfo }      | Exp2 '..' Atom            {% twoDotsRange $2 }      | Atom '..' Exp2            {% twoDotsRange $2 }-     | '-' Exp2  %prec juxtprec  { Negate $2 $1 }-     | '!' Exp2 %prec juxtprec   { Not $2 $1 }+     | '-' Exp2  %prec juxtprec  { Negate $2 (srcspan $1 $>) }+     | '!' Exp2 %prec juxtprec   { Not $2 (srcspan $1 $>) }        | Exp2 with '[' DimIndices ']' '=' Exp2@@ -626,19 +643,19 @@             { [$1] }  Atom :: { UncheckedExp }-Atom : PrimLit        { Literal (fst $1) (snd $1) }-     | Constr         { Constr (fst $1) [] NoInfo (snd $1) }+Atom : PrimLit        { Literal (fst $1) (srclocOf (snd $1)) }+     | Constr         { Constr (fst $1) [] NoInfo (srclocOf (snd $1)) }      | charlit        { let L loc (CHARLIT x) = $1-                        in IntLit (toInteger (ord x)) NoInfo loc }-     | intlit         { let L loc (INTLIT x) = $1 in IntLit x NoInfo loc }-     | floatlit       { let L loc (FLOATLIT x) = $1 in FloatLit x NoInfo loc }+                        in IntLit (toInteger (ord x)) NoInfo (srclocOf loc) }+     | intlit         { let L loc (INTLIT x) = $1 in IntLit x NoInfo (srclocOf loc) }+     | floatlit       { let L loc (FLOATLIT x) = $1 in FloatLit x NoInfo (srclocOf loc) }      | stringlit      { let L loc (STRINGLIT s) = $1 in-                        StringLit (BS.unpack (T.encodeUtf8 s)) loc }+                        StringLit (BS.unpack (T.encodeUtf8 s)) (srclocOf loc) }      | '(' Exp ')' FieldAccesses        { foldl (\x (y, _) -> Project y x NoInfo (srclocOf x))                (Parens $2 (srcspan $1 ($3:map snd $>)))                $4 }-     | '(' Exp ')[' DimIndices ']'    { AppExp (Index (Parens $2 $1) $4 (srcspan $1 $>)) NoInfo }+     | '(' Exp ')[' DimIndices ']'    { AppExp (Index (Parens $2 (srclocOf $1)) $4 (srcspan $1 $>)) NoInfo }      | '(' Exp ',' Exps1 ')'          { TupLit ($2 : fst $4 : snd $4) (srcspan $1 $>) }      | '('      ')'                   { TupLit [] (srcspan $1 $>) }      | '[' Exps1 ']'                  { ArrayLit (fst $2:snd $2) NoInfo (srcspan $1 $>) }@@ -647,14 +664,14 @@      | QualVarSlice FieldAccesses        { let ((v, vloc),slice,loc) = $1          in foldl (\x (y, _) -> Project y x NoInfo (srcspan x (srclocOf x)))-                  (AppExp (Index (Var v NoInfo vloc) slice (srcspan vloc loc)) NoInfo)+                  (AppExp (Index (Var v NoInfo (srclocOf vloc)) slice (srcspan vloc loc)) NoInfo)                   $2 }      | QualName-       { Var (fst $1) NoInfo (snd $1) }+       { Var (fst $1) NoInfo (srclocOf (snd $1)) }      | '{' Fields '}' { RecordLit $2 (srcspan $1 $>) }      | 'qid.(' Exp ')'        { let L loc (QUALPAREN qs name) = $1 in-         QualParens (QualName qs name, loc) $2 (srcspan $1 $>) }+         QualParens (QualName qs name, srclocOf loc) $2 (srcspan $1 $>) }       -- Operator sections.      | '(' '-' ')'@@ -676,7 +693,7 @@        { IndexSection $4 NoInfo (srcspan $1 $>) }  -NumLit :: { (PrimValue, SrcLoc) }+NumLit :: { (PrimValue, Loc) }         : i8lit   { let L loc (I8LIT num)  = $1 in (SignedValue $ Int8Value num, loc) }         | i16lit  { let L loc (I16LIT num) = $1 in (SignedValue $ Int16Value num, loc) }         | i32lit  { let L loc (I32LIT num) = $1 in (SignedValue $ Int32Value num, loc) }@@ -692,7 +709,7 @@         | f64lit { let L loc (F64LIT num) = $1 in (FloatValue $ Float64Value num, loc) }  -PrimLit :: { (PrimValue, SrcLoc) }+PrimLit :: { (PrimValue, Loc) }         : true   { (BoolValue True, $1) }         | false  { (BoolValue False, $1) }         | NumLit { $1 }@@ -706,20 +723,20 @@         : Exps1_ ',' Exp { (snd $1 : fst $1, $3) }         | Exp            { ([], $1) } -FieldAccess :: { (Name, SrcLoc) }+FieldAccess :: { (Name, Loc) }              : '.' id { let L loc (ID f) = $2 in (f, loc) }              | '.int' { let L loc (PROJ_INTFIELD x) = $1 in (x, loc) } -FieldAccesses :: { [(Name, SrcLoc)] }+FieldAccesses :: { [(Name, Loc)] }                : FieldAccess FieldAccesses { $1 : $2 }                |                           { [] } -FieldAccesses_ :: { [(Name, SrcLoc)] }+FieldAccesses_ :: { [(Name, Loc)] }                : FieldId FieldAccesses { (fst $1, snd $1) : $2 }  Field :: { FieldBase NoInfo Name }        : FieldId '=' Exp { RecordFieldExplicit (fst $1) $3 (srcspan (snd $1) $>) }-       | id              { let L loc (ID s) = $1 in RecordFieldImplicit s NoInfo loc }+       | id              { let L loc (ID s) = $1 in RecordFieldImplicit s NoInfo (srclocOf loc) }  Fields :: { [FieldBase NoInfo Name] }         : Fields1 { $1 }@@ -742,7 +759,7 @@                    NoInfo}       | let VarSlice '=' Exp LetBody-       { let ((v,_),slice,loc) = $2; ident = Ident v NoInfo loc+       { let ((v,_),slice,loc) = $2; ident = Ident v NoInfo (srclocOf loc)          in AppExp (LetWith ident ident slice $4 $5 (srcspan $1 $>)) NoInfo }  LetBody :: { UncheckedExp }@@ -778,16 +795,16 @@            | CPat ',' CPats1 { $1 : $3 }  CInnerPat :: { PatBase NoInfo Name }-               : id                                 { let L loc (ID name) = $1 in Id name NoInfo loc }+               : id                                 { let L loc (ID name) = $1 in Id name NoInfo (srclocOf loc) }                | '(' BindingBinOp ')'               { Id $2 NoInfo (srcspan $1 $>) }-               | '_'                                { Wildcard NoInfo $1 }+               | '_'                                { Wildcard NoInfo (srclocOf $1) }                | '(' ')'                            { TuplePat [] (srcspan $1 $>) }                | '(' CPat ')'                       { PatParens $2 (srcspan $1 $>) }                | '(' CPat ',' CPats1 ')'            { TuplePat ($2:$4) (srcspan $1 $>) }                | '{' CFieldPats '}'                 { RecordPat $2 (srcspan $1 $>) }-               | CaseLiteral                        { PatLit (fst $1) NoInfo (snd $1) }+               | CaseLiteral                        { PatLit (fst $1) NoInfo (srclocOf (snd $1)) }                | Constr                             { let (n, loc) = $1-                                                      in PatConstr n NoInfo [] loc }+                                                      in PatConstr n NoInfo [] (srclocOf loc) }  ConstrFields :: { [PatBase NoInfo Name] }               : CInnerPat                { [$1] }@@ -797,9 +814,9 @@                : FieldId '=' CPat                { (fst $1, $3) }                | FieldId ':' TypeExpDecl-               { (fst $1, PatAscription (Id (fst $1) NoInfo (snd $1)) $3 (srcspan (snd $1) $>)) }+               { (fst $1, PatAscription (Id (fst $1) NoInfo (srclocOf (snd $1))) $3 (srcspan (snd $1) $>)) }                | FieldId-               { (fst $1, Id (fst $1) NoInfo (snd $1)) }+               { (fst $1, Id (fst $1) NoInfo (srclocOf (snd $1))) }  CFieldPats :: { [(Name, PatBase NoInfo Name)] }                 : CFieldPats1 { $1 }@@ -809,7 +826,7 @@                  : CFieldPat ',' CFieldPats1 { $1 : $3 }                  | CFieldPat                    { [$1] } -CaseLiteral :: { (PatLit, SrcLoc) }+CaseLiteral :: { (PatLit, Loc) }              : charlit  { let L loc (CHARLIT x) = $1                           in (PatLitInt (toInteger (ord x)), loc) }              | PrimLit  { (PatLitPrim (fst $1), snd $1) }@@ -827,17 +844,17 @@          | while Exp            { While $2 } -VarSlice :: { ((Name, SrcLoc), UncheckedSlice, SrcLoc) }+VarSlice :: { ((Name, Loc), UncheckedSlice, Loc) }           : 'id[' DimIndices ']'             { let L vloc (INDEXING v) = $1-              in ((v, vloc), $2, srcspan $1 $>) }+              in ((v, vloc), $2, locOf (srcspan $1 $>)) } -QualVarSlice :: { ((QualName Name, SrcLoc), UncheckedSlice, SrcLoc) }+QualVarSlice :: { ((QualName Name, Loc), UncheckedSlice, Loc) }               : VarSlice                 { let ((v, vloc), y, loc) = $1 in ((qualName v, vloc), y, loc) }               | 'qid[' DimIndices ']'                 { let L vloc (QUALINDEXING qs v) = $1-                  in ((QualName qs v, vloc), $2, srcspan $1 $>) }+                  in ((QualName qs v, vloc), $2, locOf (srcspan $1 $>)) }  DimIndex :: { UncheckedDimIndex }          : Exp2                   { DimFix $1 }@@ -859,9 +876,9 @@              | DimIndex ',' DimIndices1 { ($1, fst $3 : snd $3) }  VarId :: { IdentBase NoInfo Name }-VarId : id { let L loc (ID name) = $1 in Ident name NoInfo loc }+VarId : id { let L loc (ID name) = $1 in Ident name NoInfo (srclocOf loc) } -FieldId :: { (Name, SrcLoc) }+FieldId :: { (Name, Loc) }          : id     { let L loc (ID name) = $1 in (name, loc) }          | intlit { let L loc (INTLIT n) = $1 in (nameFromString (show n), loc) } @@ -875,9 +892,9 @@        | Pat ',' Pats1          { $1 : $3 }  InnerPat :: { PatBase NoInfo Name }-InnerPat : id                               { let L loc (ID name) = $1 in Id name NoInfo loc }+InnerPat : id                               { let L loc (ID name) = $1 in Id name NoInfo (srclocOf loc) }              | '(' BindingBinOp ')'         { Id $2 NoInfo (srcspan $1 $>) }-             | '_'                          { Wildcard NoInfo $1 }+             | '_'                          { Wildcard NoInfo (srclocOf $1) }              | '(' ')'                      { TuplePat [] (srcspan $1 $>) }              | '(' Pat ')'                  { PatParens $2 (srcspan $1 $>) }              | '(' Pat ',' Pats1 ')'        { TuplePat ($2:$4) (srcspan $1 $>) }@@ -887,9 +904,9 @@               : FieldId '=' Pat                 { (fst $1, $3) }               | FieldId ':' TypeExpDecl-                { (fst $1, PatAscription (Id (fst $1) NoInfo (snd $1)) $3 (srcspan (snd $1) $>)) }+                { (fst $1, PatAscription (Id (fst $1) NoInfo (srclocOf (snd $1))) $3 (srcspan (snd $1) $>)) }               | FieldId-                { (fst $1, Id (fst $1) NoInfo (snd $1)) }+                { (fst $1, Id (fst $1) NoInfo (srclocOf (snd $1))) }  FieldPats :: { [(Name, PatBase NoInfo Name)] }                : FieldPats1 { $1 }@@ -903,12 +920,12 @@ maybeAscription(p) : ':' p { Just $2 }                    |       { Nothing } -AttrAtom :: { (AttrAtom Name, SrcLoc) }+AttrAtom :: { (AttrAtom Name, Loc) }           : id     { let L loc (ID s) =     $1 in (AtomName s, loc) }           | intlit { let L loc (INTLIT x) = $1 in (AtomInt x, loc) }  AttrInfo :: { AttrInfo Name }-         : AttrAtom         { uncurry AttrAtom $1 }+         : AttrAtom         { let (x,y) = $1 in AttrAtom x (srclocOf y) }          | id '('       ')' { let L _ (ID s) = $1 in AttrComp s [] (srcspan $1 $>) }          | id '(' Attrs ')' { let L _ (ID s) = $1 in AttrComp s $3 (srcspan $1 $>) } @@ -947,7 +964,7 @@ BoolValue : true           { PrimValue $ BoolValue True }           | false          { PrimValue $ BoolValue False } -SignedLit :: { (IntValue, SrcLoc) }+SignedLit :: { (IntValue, Loc) }           : i8lit   { let L loc (I8LIT num)  = $1 in (Int8Value num, loc) }           | i16lit  { let L loc (I16LIT num) = $1 in (Int16Value num, loc) }           | i32lit  { let L loc (I32LIT num) = $1 in (Int32Value num, loc) }@@ -955,13 +972,13 @@           | intlit  { let L loc (INTLIT num) = $1 in (Int32Value $ fromInteger num, loc) }           | charlit { let L loc (CHARLIT char) = $1 in (Int32Value $ fromIntegral $ ord char, loc) } -UnsignedLit :: { (IntValue, SrcLoc) }+UnsignedLit :: { (IntValue, Loc) }             : u8lit  { let L pos (U8LIT num)  = $1 in (Int8Value $ fromIntegral num, pos) }             | u16lit { let L pos (U16LIT num) = $1 in (Int16Value $ fromIntegral num, pos) }             | u32lit { let L pos (U32LIT num) = $1 in (Int32Value $ fromIntegral num, pos) }             | u64lit { let L pos (U64LIT num) = $1 in (Int64Value $ fromIntegral num, pos) } -FloatLit :: { (FloatValue, SrcLoc) }+FloatLit :: { (FloatValue, Loc) }          : f16lit { let L loc (F16LIT num) = $1 in (Float16Value num, loc) }          | f32lit { let L loc (F32LIT num) = $1 in (Float32Value num, loc) }          | f64lit { let L loc (F64LIT num) = $1 in (Float64Value num, loc) }@@ -1006,32 +1023,3 @@ Values : Value ',' Values { $1 : $3 }        | Value            { [$1] }        |                  { [] }--{-  -- | Parse an Futhark expression incrementally from monadic actions, using the--- 'FilePath' as the source name for error messages.-parseExpIncrM ::-  Monad m =>-  m T.Text ->-  FilePath ->-  T.Text ->-  m (Either ParseError UncheckedExp)-parseExpIncrM fetch file program =-  getLinesFromM fetch $ parseInMonad expression file program---- | Parse either an expression or a declaration incrementally;--- favouring declarations in case of ambiguity.-parseDecOrExpIncrM ::-  Monad m =>-  m T.Text ->-  FilePath ->-  T.Text ->-  m (Either ParseError (Either UncheckedDec UncheckedExp))-parseDecOrExpIncrM fetch file input =-  case parseInMonad declaration file input of-    Value Left {} -> fmap Right <$> parseExpIncrM fetch file input-    Value (Right d) -> pure $ Right $ Left d-    GetLine c -> do-      l <- fetch-      parseDecOrExpIncrM fetch file $ input <> "\n" <> l-}

@@ -13,6 +13,7 @@ module Language.Futhark.Syntax   ( module Language.Futhark.Core,     pretty,+    prettyText,      -- * Types     Uniqueness (..),

@@ -11,7 +11,7 @@     checkExp,     checkDec,     checkModExp,-    TypeError,+    TypeError (..),     Warnings,     initialEnv,     envWithImports,@@ -403,7 +403,7 @@   case mtyMod f_mty of     ModFun functor -> do       (e_abs, e_mty, e') <- checkOneModExp e-      (mty, psubsts, rsubsts) <- applyFunctor loc functor e_mty+      (mty, psubsts, rsubsts) <- applyFunctor (locOf loc) functor e_mty       return         ( mtyAbs mty <> f_abs <> e_abs,           mty,@@ -414,7 +414,7 @@ checkOneModExp (ModAscript me se NoInfo loc) = do   (me_abs, me_mod, me') <- checkOneModExp me   (se_abs, se_mty, se') <- checkSigExp se-  match_subst <- badOnLeft $ matchMTys me_mod se_mty loc+  match_subst <- badOnLeft $ matchMTys me_mod se_mty (locOf loc)   return (se_abs <> me_abs, se_mty, ModAscript me' se' (Info match_subst) loc) checkOneModExp (ModLambda param maybe_fsig_e body_e loc) =   withModParam param $ \param' param_abs param_mod -> do@@ -476,7 +476,7 @@         )     Just fsig_e -> do       (fsig_abs, fsig_mty, fsig_e') <- checkSigExp fsig_e-      fsig_subst <- badOnLeft $ matchMTys body_mty fsig_mty loc+      fsig_subst <- badOnLeft $ matchMTys body_mty fsig_mty (locOf loc)       return         ( fsig_abs <> body_e_abs,           Just (fsig_e', Info fsig_subst),

@@ -251,7 +251,7 @@   TySet ->   Mod ->   TySet ->-  SrcLoc ->+  Loc ->   Either TypeError (M.Map VName (QualName VName, TypeBinding)) resolveAbsTypes mod_abs mod sig_abs loc = do   let abs_mapping =@@ -282,7 +282,7 @@         missingType loc $ fmap baseName name   where     mismatchedLiftedness name_l abs name mod_t =-      Left . TypeError loc mempty $+      Left . TypeError (locOf loc) mempty $         "Module defines"           </> indent 2 (ppTypeAbbr abs name mod_t)           </> "but module type requires" <+> text what <> "."@@ -293,11 +293,10 @@           Lifted -> "a lifted type"      anonymousSizes abs name mod_t =-      Left $-        TypeError loc mempty $-          "Module defines"-            </> indent 2 (ppTypeAbbr abs name mod_t)-            </> "which contains anonymous sizes, but module type requires non-lifted type."+      Left . TypeError (locOf loc) mempty $+        "Module defines"+          </> indent 2 (ppTypeAbbr abs name mod_t)+          </> "which contains anonymous sizes, but module type requires non-lifted type."  resolveMTyNames ::   MTy ->@@ -338,38 +337,34 @@         resolve' name _ =           M.lookup (namespace, baseName name) $ envNameMap mod_env -missingType :: Pretty a => SrcLoc -> a -> Either TypeError b+missingType :: Pretty a => Loc -> a -> Either TypeError b missingType loc name =-  Left $-    TypeError loc mempty $-      "Module does not define a type named" <+> ppr name <> "."+  Left . TypeError loc mempty $+    "Module does not define a type named" <+> ppr name <> "." -missingVal :: Pretty a => SrcLoc -> a -> Either TypeError b+missingVal :: Pretty a => Loc -> a -> Either TypeError b missingVal loc name =-  Left $-    TypeError loc mempty $-      "Module does not define a value named" <+> ppr name <> "."+  Left . TypeError loc mempty $+    "Module does not define a value named" <+> ppr name <> "." -missingMod :: Pretty a => SrcLoc -> a -> Either TypeError b+missingMod :: Pretty a => Loc -> a -> Either TypeError b missingMod loc name =-  Left $-    TypeError loc mempty $-      "Module does not define a module named" <+> ppr name <> "."+  Left . TypeError loc mempty $+    "Module does not define a module named" <+> ppr name <> "."  mismatchedType ::-  SrcLoc ->+  Loc ->   [VName] ->   VName ->   (Liftedness, [TypeParam], StructRetType) ->   (Liftedness, [TypeParam], StructRetType) ->   Either TypeError b mismatchedType loc abs name spec_t env_t =-  Left $-    TypeError loc mempty $-      "Module defines"-        </> indent 2 (ppTypeAbbr abs name env_t)-        </> "but module type requires"-        </> indent 2 (ppTypeAbbr abs name spec_t)+  Left . TypeError loc mempty $+    "Module defines"+      </> indent 2 (ppTypeAbbr abs name env_t)+      </> "but module type requires"+      </> indent 2 (ppTypeAbbr abs name spec_t)  ppTypeAbbr :: [VName] -> VName -> (Liftedness, [TypeParam], StructRetType) -> Doc ppTypeAbbr abs name (l, ps, RetType [] (Scalar (TypeVar () _ tn args)))@@ -390,7 +385,7 @@ matchMTys ::   MTy ->   MTy ->-  SrcLoc ->+  Loc ->   Either TypeError (M.Map VName VName) matchMTys orig_mty orig_mty_sig =   matchMTys'@@ -402,7 +397,7 @@       M.Map VName (Subst StructRetType) ->       MTy ->       MTy ->-      SrcLoc ->+      Loc ->       Either TypeError (M.Map VName VName)      matchMTys' _ (MTy _ ModFun {}) (MTy _ ModEnv {}) loc =@@ -433,7 +428,7 @@       M.Map VName (Subst StructRetType) ->       Mod ->       Mod ->-      SrcLoc ->+      Loc ->       Either TypeError (M.Map VName VName)     matchMods _ ModEnv {} ModFun {} loc =       Left $@@ -466,7 +461,7 @@       M.Map VName (Subst StructRetType) ->       Env ->       Env ->-      SrcLoc ->+      Loc ->       Either TypeError (M.Map VName VName)     matchEnvs abs_subst_to_type env sig loc = do       -- XXX: we only want to create substitutions for visible names.@@ -505,7 +500,7 @@       return $ val_substs <> mod_substs <> abbr_name_substs      matchTypeAbbr ::-      SrcLoc ->+      Loc ->       M.Map VName (Subst StructRetType) ->       VName ->       Liftedness ->@@ -559,7 +554,7 @@       nomatch      matchVal ::-      SrcLoc ->+      Loc ->       VName ->       BoundV ->       VName ->@@ -577,7 +572,7 @@                 </> indent 2 (ppValBind spec_name v)                 </> fromMaybe mempty problem -    matchValBinding :: SrcLoc -> BoundV -> BoundV -> Maybe (Maybe Doc)+    matchValBinding :: Loc -> BoundV -> BoundV -> Maybe (Maybe Doc)     matchValBinding loc (BoundV _ orig_spec_t) (BoundV tps orig_t) =       case doUnification loc tps (toStruct orig_spec_t) (toStruct orig_t) of         Left (TypeError _ notes msg) ->@@ -596,7 +591,7 @@  -- | Apply a parametric module to an argument. applyFunctor ::-  SrcLoc ->+  Loc ->   FunSig ->   MTy ->   TypeM

@@ -91,11 +91,11 @@ aNote = Notes . pure . Note . ppr  -- | Information about an error during type checking.-data TypeError = TypeError SrcLoc Notes Doc+data TypeError = TypeError Loc Notes Doc  instance Pretty TypeError where   ppr (TypeError loc notes msg) =-    text (inRed $ "Error at " <> locStr loc <> ":")+    text (inRed $ "Error at " <> locStr (srclocOf loc) <> ":")       </> msg <> ppr notes  errorIndexUrl :: Doc@@ -370,7 +370,7 @@                     qualifyTypeVars outer_env mempty qs t'                 ) -  typeError loc notes s = throwError $ TypeError (srclocOf loc) notes s+  typeError loc notes s = throwError $ TypeError (locOf loc) notes s  -- | Extract from a type a first-order type. getType :: TypeBase dim as -> Maybe (TypeBase dim as)

@@ -1098,11 +1098,11 @@         | (d, dloc) : _ <-             mapMaybe (unknown constraints known) $               S.toList $ typeDimNames $ toStruct t =-          Just $ lift $ causality what loc d dloc t+          Just $ lift $ causality what (locOf loc) d dloc t         | otherwise = Nothing        checkParamCausality known p =-        checkCausality (ppr p) known (patternType p) (srclocOf p)+        checkCausality (ppr p) known (patternType p) (locOf p)        onExp ::         S.Set VName ->

@@ -500,10 +500,10 @@     case checking of       Just checking' ->         throwError $-          TypeError (srclocOf loc) notes $+          TypeError (locOf loc) notes $             ppr checking' <> line </> doc <> ppr bcs       Nothing ->-        throwError $ TypeError (srclocOf loc) notes $ doc <> ppr bcs+        throwError $ TypeError (locOf loc) notes $ doc <> ppr bcs    matchError loc notes bcs t1 t2 = do     checking <- asks termChecking@@ -511,14 +511,14 @@       Just checking'         | hasNoBreadCrumbs bcs ->           throwError $-            TypeError (srclocOf loc) notes $+            TypeError (locOf loc) notes $               ppr checking'         | otherwise ->           throwError $-            TypeError (srclocOf loc) notes $+            TypeError (locOf loc) notes $               ppr checking' <> line </> doc <> ppr bcs       Nothing ->-        throwError $ TypeError (srclocOf loc) notes $ doc <> ppr bcs+        throwError $ TypeError (locOf loc) notes $ doc <> ppr bcs     where       doc =         "Types"@@ -686,9 +686,9 @@     checking <- asks termChecking     case checking of       Just checking' ->-        throwError $ TypeError (srclocOf loc) notes (ppr checking' <> line </> s)+        throwError $ TypeError (locOf loc) notes (ppr checking' <> line </> s)       Nothing ->-        throwError $ TypeError (srclocOf loc) notes s+        throwError $ TypeError (locOf loc) notes s  onFailure :: Checking -> TermTypeM a -> TermTypeM a onFailure c = local $ \env -> env {termChecking = Just c}

@@ -2,10 +2,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} +-- | Type checking of patterns. module Language.Futhark.TypeChecker.Terms.Pat   ( binding,     bindingParams,-    checkPat,     bindingPat,     bindingIdent,     bindingSizes,@@ -66,6 +66,9 @@   | otherwise =     return () +-- | Bind these identifiers locally while running the provided action.+-- Checks that the identifiers are used properly within the scope+-- (e.g. consumption). binding :: [Ident] -> TermTypeM a -> TermTypeM a binding stms = check . handleVars   where@@ -170,6 +173,7 @@   Just $ Ident v (Info $ Scalar $ Prim $ Signed Int64) loc typeParamIdent _ = Nothing +-- | Bind a single term-level identifier. bindingIdent ::   IdentBase NoInfo Name ->   PatType ->@@ -181,6 +185,8 @@     let ident = Ident v' (Info t) vloc     binding [ident] $ m ident +-- | Bind @let@-bound sizes.  This is usually followed by 'bindingPat'+-- immediately afterwards. bindingSizes :: [SizeBinder Name] -> ([SizeBinder VName] -> TermTypeM a) -> TermTypeM a bindingSizes [] m = m [] -- Minor optimisation. bindingSizes sizes m = do@@ -217,6 +223,7 @@     dimIdent _ NamedDim {} = Nothing patternDims _ = [] +-- | Check and bind a @let@-pattern. bindingPat ::   [SizeBinder VName] ->   PatBase NoInfo Name ->@@ -394,6 +401,7 @@     [] ->       bindNameMap (patNameMap p') $ m p' +-- | Check and bind type and value parameters. bindingParams ::   [UncheckedTypeParam] ->   [UncheckedPat] ->

@@ -1152,10 +1152,10 @@   curLevel = pure 0    unifyError loc notes bcs doc =-    throwError $ TypeError (srclocOf loc) notes $ doc <> ppr bcs+    throwError $ TypeError (locOf loc) notes $ doc <> ppr bcs    matchError loc notes bcs t1 t2 =-    throwError $ TypeError (srclocOf loc) notes $ doc <> ppr bcs+    throwError $ TypeError (locOf loc) notes $ doc <> ppr bcs     where       doc =         "Types"@@ -1175,13 +1175,13 @@ -- The type parameters are allowed to be instantiated; all other types -- are considered rigid. doUnification ::-  SrcLoc ->+  Loc ->   [TypeParam] ->   StructType ->   StructType ->   Either TypeError StructType doUnification loc tparams t1 t2 = runUnifyM tparams $ do-  expect (Usage Nothing loc) t1 t2+  expect (Usage Nothing (srclocOf loc)) t1 t2   normTypeFully t2  -- Note [Linking variables to sum types]

@@ -6,6 +6,7 @@     anyWarnings,     singleWarning,     singleWarning',+    listWarnings,   ) where @@ -59,3 +60,7 @@ -- trace (sort of) to the location. singleWarning' :: SrcLoc -> [SrcLoc] -> Doc -> Warnings singleWarning' loc locs problem = Warnings [(loc, locs, problem)]++-- | Exports Warnings into a list of (location, problem).+listWarnings :: Warnings -> [(SrcLoc, Doc)]+listWarnings (Warnings ws) = map (\(loc, _, doc) -> (loc, doc)) ws

@@ -14,7 +14,6 @@ import Data.Void import Futhark.IR.Primitive.Parse (constituent, keyword, lexeme) import Futhark.IR.PrimitiveTests ()-import Futhark.Util.Pretty (prettyText) import Language.Futhark import Language.Futhark.Parser import Test.QuickCheck@@ -62,7 +61,7 @@  instance IsString UncheckedTypeExp where   fromString =-    either (error . show) id . parseType "IsString UncheckedTypeExp" . fromString+    either (error . syntaxErrorMsg) id . parseType "IsString UncheckedTypeExp" . fromString  type Parser = Parsec Void T.Text