migrate to 9.8.1

app/Commands/Extra/Package.hs

@@ -1,6 +1,5 @@
 module Commands.Extra.Package where
 
-import Data.Text.IO.Utf8 qualified as Utf8
 import Juvix.Compiler.Pipeline.Package.Base
 import Juvix.Compiler.Pipeline.Package.Loader
 import Juvix.Extra.Paths
@@ -11,11 +10,9 @@ renderPackage = renderPackageVersion currentPackageVersion
 
 writePackageFile' :: (Member (Embed IO) r) => PackageVersion -> Path Abs Dir -> Package -> Sem r ()
 writePackageFile' v root pkg =
-  embed
-    ( Utf8.writeFile @IO
-        (toFilePath (root <//> packageFilePath))
-        (renderPackageVersion v pkg)
-    )
+  writeFileEnsureLn
+    (root <//> packageFilePath)
+    (renderPackageVersion v pkg)
 
 writePackageFile :: (Member (Embed IO) r) => Path Abs Dir -> Package -> Sem r ()
 writePackageFile = writePackageFile' currentPackageVersion

app/Commands/Repl.hs

@@ -339,7 +339,7 @@ printDefinition = replParseIdentifiers >=> printIdentifiers
                 KNameFixity -> impossible
                 KNameAlias -> impossible
           where
-            printLocation :: (HasLoc s) => s -> Repl ()
+            printLocation :: (HasLoc c) => c -> Repl ()
             printLocation def = do
               s' <- ppConcrete s
               let txt :: Text = " is " <> prettyText (nameKindWithArticle (getNameKind s)) <> " defined at " <> prettyText (getLoc def)

app/HaskelineJH.hs

@@ -28,13 +28,13 @@ type RunTerm = $(importHiddenConT "haskeline" "System.Console.Haskeline.Term" "R
 type History = $(importHiddenConT "haskeline" "System.Console.Haskeline.History" "History")
 
 unInputT :: InputT m a -> InputTArg m a
-unInputT = $(importHidden "haskeline" "System.Console.Haskeline.InputT" "unInputT")
+unInputT = $(importHiddenField "InputT" "haskeline" "System.Console.Haskeline.InputT" "unInputT")
 
 mkInputT :: InputTArg m a -> InputT m a
 mkInputT = $(importHiddenCon "haskeline" "System.Console.Haskeline.InputT" "InputT")
 
 unHaskelineT :: HaskelineT m a -> InputT m a
-unHaskelineT = $(importHidden "repline" "System.Console.Repline" "unHaskeline")
+unHaskelineT = $(importHiddenField "HaskelineT" "repline" "System.Console.Repline" "unHaskeline")
 
 mkHaskelineT :: InputT m a -> HaskelineT m a
 mkHaskelineT = $(importHiddenCon "repline" "System.Console.Repline" "HaskelineT")

package.yaml

@@ -97,7 +97,6 @@ dependencies:
   - utf8-string == 1.0.*
   - vector == 0.13.*
   - versions == 6.0.*
-  - with-utf8 == 1.1.*
   - xdg-basedir == 0.2.*
   - yaml == 0.11.*
 
@@ -123,6 +122,8 @@ ghc-options:
   - -Wno-missing-import-lists
   - -Wno-missing-kind-signatures
   - -Wno-missing-safe-haskell-mode
+  - -Wno-missing-role-annotations
+  - -Wno-missing-poly-kind-signatures
   - -Wno-safe
   - -Wno-unsafe
   - -Wno-unused-packages

src/Juvix/Compiler/Backend/C/Translation/FromReg.hs

@@ -1,7 +1,6 @@
 module Juvix.Compiler.Backend.C.Translation.FromReg where
 
 import Data.HashMap.Strict qualified as HashMap
-import Data.List qualified as List
 import Juvix.Compiler.Backend
 import Juvix.Compiler.Backend.C.Data.CBuilder
 import Juvix.Compiler.Backend.C.Data.Types
@@ -343,7 +342,7 @@ fromRegInstr bNoStack info = \case
         Reg.MemRepUnit ->
           stmtsAssign (fromVarRef _instrAllocResult) (macroVar "OBJ_UNIT")
         Reg.MemRepUnpacked {} ->
-          stmtsAssign (fromVarRef _instrAllocResult) (fromValue (List.head _instrAllocArgs))
+          stmtsAssign (fromVarRef _instrAllocResult) (fromValue (head' _instrAllocArgs))
 
     fromAllocClosure :: Reg.InstrAllocClosure -> [Statement]
     fromAllocClosure Reg.InstrAllocClosure {..} =

src/Juvix/Compiler/Backend/Geb/Translation/FromCore.hs

@@ -1,7 +1,6 @@
 module Juvix.Compiler.Backend.Geb.Translation.FromCore where
 
 import Data.HashMap.Strict qualified as HashMap
-import Data.List qualified as List
 import Juvix.Compiler.Backend.Geb.Extra
 import Juvix.Compiler.Backend.Geb.Language
 import Juvix.Compiler.Core.Data.IdentDependencyInfo qualified as Core
@@ -408,7 +407,7 @@ fromCore tab = case tab ^. Core.infoMain of
         -- `_caseDefault` is the body of those branches which were not present in
         -- `_caseBranches`.
         branches = sortOn (^. Core.caseBranchTag) (_caseBranches ++ ctrBrs)
-        codomainType = convertType (Info.getNodeType (List.head branches ^. Core.caseBranchBody))
+        codomainType = convertType (Info.getNodeType (head' branches ^. Core.caseBranchBody))
 
         mkCtrBranch :: Core.ConstructorInfo -> Core.CaseBranch
         mkCtrBranch ci =

src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs

@@ -632,8 +632,8 @@ sourceAndSelfLink tmp name = do
              $ "#"
          )
 
-tagIden :: (IsString a) => NameId -> a
-tagIden x = fromText $ prettyText x
+tagIden :: (IsString c) => NameId -> c
+tagIden = fromText . prettyText
 
-selfLinkName :: (IsString a) => NameId -> a
+selfLinkName :: (IsString c) => NameId -> c
 selfLinkName x = fromText $ "#" <> tagIden x

src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs

@@ -214,9 +214,9 @@ renderTree = go
 
 -- | printed without comments
 ppCodeHtml ::
-  (PrettyPrint a, Members '[Reader HtmlOptions] r) =>
+  (PrettyPrint c, Members '[Reader HtmlOptions] r) =>
   Options ->
-  a ->
+  c ->
   Sem r Html
 ppCodeHtml opts = ppCodeHtmlHelper opts Nothing
 
@@ -238,29 +238,29 @@ docToHtml d = ppCodeHtml' <$> ask
         docStream' = layoutPretty defaultLayoutOptions d
 
 ppCodeHtmlHelper ::
-  (PrettyPrint a, Members '[Reader HtmlOptions] r) =>
+  (PrettyPrint c, Members '[Reader HtmlOptions] r) =>
   Options ->
   Maybe FileComments ->
-  a ->
+  c ->
   Sem r Html
 ppCodeHtmlHelper opts cs = docToHtml . docHelper cs opts
 
 ppCodeHtmlComments ::
-  (HasLoc a, PrettyPrint a, Members '[Reader HtmlOptions] r) =>
+  (HasLoc c, PrettyPrint c, Members '[Reader HtmlOptions] r) =>
   Options ->
   Comments ->
-  a ->
+  c ->
   Sem r Html
 ppCodeHtmlComments opts cs x = ppCodeHtmlHelper opts (Just (fileComments (getLoc x ^. intervalFile) cs)) x
 
-ppCodeHtmlInternal :: (Members '[Reader HtmlOptions] r, Internal.PrettyCode a) => a -> Sem r Html
+ppCodeHtmlInternal :: (Members '[Reader HtmlOptions] r, Internal.PrettyCode c) => c -> Sem r Html
 ppCodeHtmlInternal x = do
   o <- ask
   return (ppCodeHtmlInternal' o Internal.defaultOptions x)
   where
-    ppCodeHtmlInternal' :: (Internal.PrettyCode a) => HtmlOptions -> Internal.Options -> a -> Html
+    ppCodeHtmlInternal' :: (Internal.PrettyCode c) => HtmlOptions -> Internal.Options -> c -> Html
     ppCodeHtmlInternal' htmlOpts opts = run . runReader htmlOpts . renderTree . treeForm . docStreamInternal' opts
-    docStreamInternal' :: (Internal.PrettyCode a) => Internal.Options -> a -> SimpleDocStream Ann
+    docStreamInternal' :: (Internal.PrettyCode c) => Internal.Options -> c -> SimpleDocStream Ann
     docStreamInternal' opts m = layoutPretty defaultLayoutOptions (Internal.runPrettyCode opts m)
 
 go :: (Members '[Reader HtmlOptions] r) => SimpleDocTree Ann -> Sem r Html

src/Juvix/Compiler/Backend/Markdown/Translation/FromTyped/Source.hs

@@ -166,7 +166,10 @@ go = do
           modify @ProcessingState $ const newState
           return _processingStateMk
 
-goRender :: (Concrete.PrettyPrint a, Members '[Reader HtmlRender.HtmlOptions, Reader ProcessJuvixBlocksArgs] r) => a -> Sem r Html
+goRender ::
+  (Concrete.PrettyPrint c, Members '[Reader HtmlRender.HtmlOptions, Reader ProcessJuvixBlocksArgs] r) =>
+  c ->
+  Sem r Html
 goRender xs = do
   concreteOpts <- asks @ProcessJuvixBlocksArgs (^. processJuvixBlocksArgsConcreteOpts)
   HtmlRender.ppCodeHtml concreteOpts xs

src/Juvix/Compiler/Core/Data/BinderList.hs

@@ -66,9 +66,9 @@ lookupsSortedRev bl = go [] 0 bl
         let skipped = v ^. varIndex - off
             off' = off + skipped
             ctx' = drop skipped ctx
-         in go ((v, head' ctx') : acc) off' ctx' vs
-    head' :: BinderList a -> a
-    head' = lookup 0
+         in go ((v, bhead' ctx') : acc) off' ctx' vs
+    bhead' :: BinderList a -> a
+    bhead' = lookup 0
 
 lookupMay :: Index -> BinderList a -> Maybe a
 lookupMay idx bl

src/Juvix/Compiler/Core/Transformation/MatchToCase.hs

@@ -1,7 +1,6 @@
 module Juvix.Compiler.Core.Transformation.MatchToCase where
 
 import Data.HashSet qualified as HashSet
-import Data.List qualified as List
 import Juvix.Compiler.Core.Error
 import Juvix.Compiler.Core.Extra
 import Juvix.Compiler.Core.Info.LocationInfo
@@ -102,7 +101,7 @@ goMatchToCase recur node = case node of
         where
           pat = err (replicate (length vs) ValueWildcard)
           seq = if length pat == 1 then "" else "sequence "
-          pat' = if length pat == 1 then doc defaultOptions (List.head pat) else docValueSequence pat
+          pat' = if length pat == 1 then doc defaultOptions (head' pat) else docValueSequence pat
           mockFile = $(mkAbsFile "/match-to-case")
           defaultLoc = singletonInterval (mkInitialLoc mockFile)
       r@PatternRow {..} : _
@@ -113,8 +112,8 @@ goMatchToCase recur node = case node of
         -- Section 4, case 3
         -- Select the first column
         tab <- ask
-        let vl = List.head vs
-            vs' = List.tail vs
+        let vl = head' vs
+            vs' = tail' vs
             val = mkVal bindersNum vl
             (col, matrix') = decompose val matrix
             tagsSet = getPatTags col
@@ -125,7 +124,7 @@ goMatchToCase recur node = case node of
                     compileDefault Nothing err bindersNum vs' col matrix'
                 | otherwise -> do
                     -- Section 4, case 3(a)
-                    let ind = lookupConstructorInfo tab (List.head tags) ^. constructorInductive
+                    let ind = lookupConstructorInfo tab (head' tags) ^. constructorInductive
                         ctrsNum = length (lookupInductiveInfo tab ind ^. inductiveConstructors)
                     branches <- mapM (compileBranch err bindersNum vs' col matrix') tags
                     defaultBranch <-
@@ -150,14 +149,14 @@ goMatchToCase recur node = case node of
     decompose :: Node -> PatternMatrix -> ([Pattern], PatternMatrix)
     decompose val matrix = (col, matrix')
       where
-        col = map (List.head . (^. patternRowPatterns)) matrix
+        col = map (head' . (^. patternRowPatterns)) matrix
         matrix' = map updateRow matrix
-        binder = getPatternBinder (List.head col)
+        binder = getPatternBinder (head' col)
 
         updateRow :: PatternRow -> PatternRow
         updateRow row =
           row
-            { _patternRowPatterns = List.tail (row ^. patternRowPatterns),
+            { _patternRowPatterns = tail' (row ^. patternRowPatterns),
               _patternRowIgnoredPatternsNum = max 0 (nIgnored - 1),
               _patternRowBinderChangesRev =
                 if

src/Juvix/Compiler/Core/Transformation/NatToPrimInt.hs

@@ -1,7 +1,6 @@
 module Juvix.Compiler.Core.Transformation.NatToPrimInt (natToPrimInt) where
 
 import Data.HashMap.Strict qualified as HashMap
-import Data.List qualified as List
 import Juvix.Compiler.Core.Extra
 import Juvix.Compiler.Core.Info qualified as Info
 import Juvix.Compiler.Core.Info.NameInfo
@@ -84,7 +83,7 @@ convertNode md = rmap go
                         (go (recur . (BCAdd 1 :)) br)
                         (go (recur . ([BCAdd 1, BCRemove (BinderRemove binder subNode)] ++)) _caseBranchBody)
                     where
-                      binder = List.head _caseBranchBinders
+                      binder = head' _caseBranchBinders
                       name = binder ^. binderName
                       binder' = over binderType (go recur) binder
                       subNode = mkBuiltinApp' OpIntSub [mkVar (Info.singleton (NameInfo name)) 0, mkConstant' (ConstInteger 1)]

src/Juvix/Compiler/Core/Transformation/Optimize/CaseCallLifting.hs

@@ -1,7 +1,6 @@
 module Juvix.Compiler.Core.Transformation.Optimize.CaseCallLifting (caseCallLifting) where
 
 import Data.HashSet qualified as HashSet
-import Data.List qualified as List
 import Juvix.Compiler.Core.Extra
 import Juvix.Compiler.Core.Transformation.Base
 
@@ -55,17 +54,17 @@ convertNode md = umap go
 
           computeArgs :: [[Node]] -> Maybe [Node] -> [Node]
           computeArgs args dargs
-            | null (List.head args) = []
+            | null (head' args) = []
             | otherwise =
                 shift
                   (-idx - 1)
                   (mkCase' ind (shift (lvl + 1) val) (zipWithExact (set caseBranchBody) hbs brs) hdef)
                   : computeArgs args' dargs'
             where
-              hbs = map List.head args
-              hdef = fmap List.head dargs
-              args' = map List.tail args
-              dargs' = fmap List.tail dargs
+              hbs = map head' args
+              hdef = fmap head' dargs
+              args' = map tail' args
+              dargs' = fmap tail' dargs
 
     gatherIdents :: HashSet Symbol -> Node -> HashSet Symbol
     gatherIdents = sgather go'

src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/CheckerNew.hs

@@ -1120,7 +1120,7 @@ holesHelper mhint expr = do
     extendCtx funParam arg' = whenJust (funParam ^. paramName) $ \nm -> do
       modify' (over appBuilderTypeCtx (set (at nm) (Just arg')))
 
-    applyCtx :: (Members '[State AppBuilder, NameIdGen] r', HasExpressions expr) => expr -> Sem r' expr
+    applyCtx :: (Members '[State AppBuilder, NameIdGen] r', HasExpressions exp) => exp -> Sem r' exp
     applyCtx x = do
       s <- gets (^. appBuilderTypeCtx)
       substitutionE s x

src/Juvix/Compiler/Tree/Translation/FromAsm/Translator.hs

@@ -1,6 +1,5 @@
 module Juvix.Compiler.Tree.Translation.FromAsm.Translator where
 
-import Data.List qualified as List
 import Juvix.Compiler.Asm.Extra.Base (getCommandLocation)
 import Juvix.Compiler.Asm.Language
 import Juvix.Compiler.Tree.Error
@@ -27,12 +26,12 @@ runTranslator' st m = do
   unless (null (st' ^. stateCode)) $
     throw
       TreeError
-        { _treeErrorLoc = getCommandLocation $ List.head (st' ^. stateCode),
+        { _treeErrorLoc = getCommandLocation $ head' (st' ^. stateCode),
           _treeErrorMsg = "extra instructions"
         }
   return a
   where
-    interp :: Translator m a' -> Sem (State TranslatorState ': r) a'
+    interp :: Translator w a' -> Sem (State TranslatorState ': r) a'
     interp = \case
       NextCommand -> do
         s <- get
@@ -42,8 +41,8 @@ runTranslator' st m = do
               { _treeErrorLoc = s ^. statePrevLoc,
                 _treeErrorMsg = "expected instruction"
               }
-        cmd <- gets (List.head . (^. stateCode))
-        modify' (over stateCode tail)
+        cmd <- gets (head' . (^. stateCode))
+        modify' (over stateCode tail')
         modify' (set statePrevLoc (getCommandLocation cmd))
         return cmd
       HasNextCommand -> do

src/Juvix/Prelude/Base.hs

@@ -117,7 +117,7 @@ import Data.Int
 import Data.IntMap.Strict (IntMap)
 import Data.IntMap.Strict qualified as IntMap
 import Data.IntSet (IntSet)
-import Data.List.Extra hiding (allSame, foldr1, groupSortOn, head, last, mconcatMap, replicate)
+import Data.List.Extra hiding (allSame, foldr1, groupSortOn, head, last, mconcatMap, replicate, unzip)
 import Data.List.Extra qualified as List
 import Data.List.NonEmpty qualified as NonEmpty
 import Data.List.NonEmpty.Extra
@@ -148,9 +148,9 @@ import Data.String
 import Data.Text (Text, pack, strip, unpack)
 import Data.Text qualified as Text
 import Data.Text.Encoding
-import Data.Text.IO hiding (appendFile, putStr, putStrLn, readFile, writeFile)
+import Data.Text.IO hiding (appendFile, getContents, getLine, hGetContents, hGetLine, hPutStr, hPutStrLn, interact, putStr, putStrLn, readFile, writeFile)
 import Data.Text.IO qualified as Text
-import Data.Text.IO.Utf8 hiding (writeFile)
+import Data.Text.IO.Utf8 hiding (putStr, putStrLn, readFile, writeFile)
 import Data.Text.IO.Utf8 qualified as Utf8
 import Data.Traversable
 import Data.Tuple.Extra hiding (both)
@@ -374,6 +374,16 @@ zip4Exact _ _ _ _ = error "zip4Exact"
 nonEmptyUnsnoc :: NonEmpty a -> (Maybe (NonEmpty a), a)
 nonEmptyUnsnoc e = (NonEmpty.nonEmpty (NonEmpty.init e), NonEmpty.last e)
 
+tail' :: (HasCallStack) => [a] -> [a]
+tail' = \case
+  [] -> impossible
+  _ : xs -> xs
+
+head' :: (HasCallStack) => [a] -> a
+head' = \case
+  [] -> impossible
+  x : _ -> x
+
 nonEmpty' :: (HasCallStack) => [a] -> NonEmpty a
 nonEmpty' = fromJust . nonEmpty
 
@@ -598,6 +608,10 @@ ensureLn t =
       '\n' -> t
       _ -> Text.snoc t '\n'
 
-writeFileEnsureLn :: (MonadMask m, MonadIO m) => Path Abs File -> Text -> m ()
-writeFileEnsureLn p = Utf8.writeFile (toFilePath p)
+writeFileEnsureLn :: (MonadIO m) => Path Abs File -> Text -> m ()
+writeFileEnsureLn p = liftIO . Utf8.writeFile (toFilePath p)
 {-# INLINE writeFileEnsureLn #-}
+
+-- TODO: change FilePath to Path Abs File
+readFile :: (MonadIO m) => FilePath -> m Text
+readFile = liftIO . Utf8.readFile

src/Juvix/Prelude/DarkArts.hs

@@ -41,3 +41,6 @@ importHiddenCon = importHiddenName ConE DataName
 
 importHidden :: String -> String -> String -> Q Exp
 importHidden = importHiddenName VarE VarName
+
+importHiddenField :: String -> String -> String -> String -> Q Exp
+importHiddenField constructorName = importHiddenName VarE (FldName constructorName)